1#lang racket/base
2
3(require racket/match
4         racket/contract/base
5         planet/cachepath
6         syntax/modread
7         "dirs.rkt"
8         "path-relativize.rkt"
9         "private/encode-relative.rkt")
10
11;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this
12;; file to find mappings. PLaneT uses this to put info about installed
13;; planet packages.
14(define user-infotable (get-planet-cache-path))
15
16;; get-info : (listof path-or-string) -> info/#f
17(define (get-info coll-path #:namespace [ns #f] #:bootstrap? [bootstrap? #f])
18  (get-info/full (apply collection-path
19                        (map (lambda (x) (if (path? x) (path->string x) x))
20                             coll-path))
21                 #:namespace ns
22                 #:bootstrap? bootstrap?))
23
24;; These `require's ensure that the `#lang info' readers
25;; are loaded, so that no reader guard will be invoked for the reader
26;; intself when checking a language via a reader guard, and
27(require (only-in setup/infotab)
28         (only-in info)
29         (only-in setup/infotab/lang/reader)
30         (only-in (submod info reader)))
31
32;; get-info/full : path -> info/#f
33(define (get-info/full dir #:namespace [ns #f] #:bootstrap? [bootstrap? #f])
34  (or (get-info/full/ext dir "rkt" ns bootstrap?)
35      (get-info/full/ext dir "ss" ns bootstrap?)))
36
37(define (get-info/full/ext dir ext ns bootstrap?)
38  (define file (build-path dir (format "info.~a" ext)))
39  (define enclosing-ns (variable-reference->namespace
40                        (#%variable-reference)))
41  (define (err fmt . args)
42    (apply error 'get-info (string-append "info file " fmt " in ~a")
43           (append args (list file))))
44  (define (contents)
45    (parameterize ([current-reader-guard
46                    (lambda (x)
47                      (if (or (eq? x 'setup/infotab/lang/reader)
48                              (eq? x 'info/lang/reader)
49                              (equal? x '(submod setup/infotab reader))
50                              (equal? x '(submod info reader)))
51                        x
52                        (err "has illegal #lang or #reader")))]
53                   [current-namespace
54                    ;; Use this module's namespace; see the `only-in'
55                    ;; `require's above.
56                    enclosing-ns])
57      (with-input-from-file file
58        (lambda ()
59          (begin0
60           (with-module-reading-parameterization read)
61           (unless (eof-object? (read))
62             (err "has multiple expressions")))))))
63  (and (file-exists? file)
64       (match (contents)
65         [(list 'module 'info
66                (or '(lib "infotab.rkt" "setup")
67                    '(lib "infotab.ss" "setup")
68                    '(lib "setup/infotab.rkt")
69                    '(lib "setup/infotab.ss")
70                    '(lib "main.rkt" "info")
71                    'setup/infotab
72                    'info)
73                expr ...)
74          ;; Although `#lang info` is intended to be loaded as code,
75          ;; many modules are so simple that we can synthesize the
76          ;; procedure directly:
77          (cond
78           [(and (not bootstrap?)
79                 (= 1 (length expr))
80                 (list? (car expr))
81                 ((length (car expr)) . >= . 1)
82                 (eq? '#%module-begin (caar expr))
83                 (for/fold ([ht #hasheq()]) ([e (in-list (cdar expr))])
84                   (match e
85                     [`(define ,id ,rhs)
86                      (and (symbol? id)
87                           ht
88                           (eq? file (hash-ref ht id file))
89                           (or (string? rhs)
90                               (number? rhs)
91                               (boolean? rhs)
92                               (and (pair? rhs)
93                                    (eq? 'quote (car rhs))
94                                    (list? rhs)
95                                    (= 2 (length rhs))))
96                           (hash-set ht id (if (pair? rhs)
97                                               (cadr rhs)
98                                               rhs)))]
99                     [_ #f])))
100            => (lambda (ht)
101                 ;; This module is so simple that we don't need to `eval` it.
102                 (lambda (key [default (lambda () (error 'info.rkt "no info for ~a" key))])
103                   (hash-ref ht key default)))]
104           [else
105            ;; Load the module.
106            ;; No need to set a reader-guard, since we checked it
107            ;; above (a guard will see other uses of #lang for stuff
108            ;; that is required).
109            ;; We are, however, trusting that the bytecode form of the
110            ;; file (if any) matches the source.
111            (parameterize ([current-environment-variables
112                            (filter-environment-variables
113                             (current-environment-variables))])
114              (let ([ns (or ns (info-namespace))])
115                (if (and bootstrap?
116                         (parameterize ([current-namespace ns])
117                           (not (module-declared? file))))
118                    ;; Attach `info' language modules to target namespace, and
119                    ;; disable the use of compiled bytecode if it fails; we
120                    ;; need a trial namespace to try loading bytecode, since
121                    ;; the use of bytecode "sticks" for later attempts.
122                    (let ([attach!
123                           (lambda (ns)
124                             (namespace-attach-module enclosing-ns 'setup/infotab ns)
125                             (namespace-attach-module enclosing-ns 'setup/infotab/lang/reader ns)
126                             (namespace-attach-module enclosing-ns 'info ns)
127                             (namespace-attach-module enclosing-ns '(submod info reader) ns))]
128                          [try
129                           (lambda (ns)
130                             (parameterize ([current-namespace ns])
131                               (dynamic-require file '#%info-lookup)))])
132                      (define ns-id (namespace-module-registry ns))
133                      ((with-handlers ([exn:fail? (lambda (exn)
134                                                    ;; Trial namespace is damaged, so uncache:
135                                                    (hash-set! trial-namespaces ns-id #f)
136                                                    ;; Try again from source:
137                                                    (lambda ()
138                                                      (attach! ns)
139                                                      (parameterize ([use-compiled-file-paths null])
140                                                        (try ns))))])
141                         ;; To reduce the cost of the trial namespace, try to used a cached
142                         ;; one previously generated for the `ns':
143                         (define try-ns (or (hash-ref trial-namespaces ns-id #f)
144                                            (let ([try-ns (make-base-empty-namespace)])
145                                              (attach! try-ns)
146                                              try-ns)))
147                         (define v (try try-ns))
148                         (hash-set! trial-namespaces ns-id try-ns)
149                         (namespace-attach-module try-ns file ns)
150                         (lambda () v))))
151                    ;; Can use compiled bytecode, etc.:
152                    (parameterize ([current-namespace ns])
153                      (dynamic-require file '#%info-lookup)))))])]
154         [_ (err "does not contain a module of the right shape")])))
155
156(define (filter-environment-variables ev)
157  (let ([keep (environment-variables-ref ev #"PLT_INFO_ALLOW_VARS")]
158        [new-ev (make-environment-variables)])
159    (when keep
160      (for ([n (in-list (regexp-split #rx#";" keep))]
161            #:when (bytes-environment-variable-name? n))
162        (define v (environment-variables-ref ev n))
163        (when v
164          (environment-variables-set! new-ev n v))))
165    new-ev))
166
167(define info-namespace
168  ;; To avoid loading modules into the current namespace
169  ;; when get-info is called, load info modules in a separate
170  ;; namespace.
171  (let ([ns-box (make-weak-box #f)])
172    (lambda ()
173      (or (weak-box-value ns-box)
174          (let ([ns (make-base-empty-namespace)])
175            (set! ns-box (make-weak-box ns))
176            ns)))))
177
178;; Weak map from a namespace registry to a trial-loading namespace for
179;; bootstrap mode:
180(define trial-namespaces (make-weak-hasheq))
181
182;; directory-record = (make-directory-record nat nat key path (listof symbol))
183;; eg: (make-directory-record 1 0 '(lib "mzlib") #"mzlib" '(name))
184(define-struct directory-record (maj min spec path syms))
185
186(define-struct table (insert   ; directory-record (listof directory-record)
187                               ;  -> (listof directory-record)
188                      ht       ; hashtable[symbol -o> directory-record]
189                      paths    ; (listof (cons path boolean))
190                      )
191  #:mutable)
192
193(define preferred-table #f)
194(define all-available-table #f)
195(define no-planet-table #f)
196(define no-user-table #f)
197
198;; reset-relevant-directories-state! : -> void
199(define (reset-relevant-directories-state!)
200  (set! preferred-table
201        (make-table
202         (lambda (root-dir i l)
203           (if (or root-dir (null? l))
204             (cons i l)
205             (match-let ([(struct directory-record (my-maj my-min _ _ _)) i]
206                         [(struct directory-record (their-maj their-min _ _ _))
207                          (car l)])
208              (if (or (> my-maj their-maj)
209                      (and (= my-maj their-maj) (>= my-min their-min)))
210                (list i)
211                l))))
212         #f #f))
213  (define (always root-dir i l) (cons i l))
214  (set! all-available-table (make-table always #f #f))
215  (set! no-planet-table (make-table always #f #f))
216  (set! no-user-table (make-table always #f #f)))
217
218(reset-relevant-directories-state!)
219
220;; populate-table : table -> void
221(define (populate-table! t)
222  ;; Use the colls ht because a collection might be in multiple
223  ;; collection paths, and we only want one
224  (define-values (path->main-share-relative
225                  main-share-relative->path)
226    (make-relativize find-share-dir
227                     'share
228                     'path->main-share-relative
229                     'main-share-relative->path))
230  (define-values (path->main-lib-relative
231                  main-lib-relative->path)
232    (make-relativize find-lib-dir
233                     'lib
234                     'path->main-lib-relative
235                     'main-lib-relative->path))
236  (let ([colls (make-hash)])
237    (for ([f+root-dir (reverse (table-paths t))])
238      (let ([f (car f+root-dir)]
239            [root-dir (cdr f+root-dir)])
240        (define-values (path->info-relative
241                        info-relative->path)
242          (make-relativize (lambda () root-dir)
243                           'info
244                           'path->info-relative
245                           'info-relative->path))
246        (when (file-exists? f)
247          (for ([i (let ([l (with-input-from-file f read)])
248                     (cond [(list? l) l]
249                           [(eof-object? l) '()] ;; allow completely empty files
250                           [else (error 'find-relevant-directories
251                                        "bad info-domain cache file: ~a" f)]))])
252            (match i
253              [(list (and pathbytes (or (? bytes?)
254                                        (list (or 'info 'share 'lib) (? bytes?) ...)
255                                        (list 'rel (or 'up (? bytes?)) ...)))
256                     (list (? symbol? fields) ...)
257                     key ;; anything is okay here
258                     (? integer? maj)
259                     (? integer? min))
260               (let ([old-items (hash-ref colls key null)]
261                     [new-item
262                      (make-directory-record
263                       maj min key
264                       (if (bytes? pathbytes)
265                           (let ([p (bytes->path pathbytes)])
266                             (if (and (relative-path? p) root-dir)
267                                 ;; `raco setup' doesn't generate relative paths anyway,
268                                 ;; but it's ok to support them:
269                                 (simplify-path (build-path root-dir p))
270                                 p))
271                           (case (car pathbytes)
272                             [(rel) (simplify-path (build-path root-dir (decode-relative-path pathbytes)))]
273                             [(info) (info-relative->path pathbytes)]
274                             [(share) (main-share-relative->path pathbytes)]
275                             [(lib) (main-lib-relative->path pathbytes)]))
276                       fields)])
277                 (hash-set! colls key
278                            ((table-insert t) root-dir new-item old-items)))]
279              [_ (error 'find-relevant-directories
280                        "bad info-domain cache entry: ~e in: ~a" i f)])))))
281    ;; For each coll, invert the mapping, adding the col name to the list
282    ;; for each sym:
283    (for* ([(key vals) colls]
284           [val vals])
285      (match val
286        [(struct directory-record (maj min spec path syms))
287         (for ([sym syms])
288           (hash-set! (table-ht t) sym
289                      (cons val (hash-ref (table-ht t) sym null))))]
290        [_ (error 'get-info
291                  "Internal error: invalid info-domain value format: ~s" val)]))))
292
293(define (find-relevant-directories syms [key 'preferred])
294  (map directory-record-path (find-relevant-directory-records syms key)))
295
296(define (find-relevant-directory-records syms [key 'preferred])
297  (define t
298    (cond [(eq? key 'preferred) preferred-table]
299          [(eq? key 'all-available) all-available-table]
300          [(eq? key 'no-planet) no-planet-table]
301          [(eq? key 'no-user) no-user-table]
302          [else (error 'find-relevant-directories "Invalid key: ~s" key)]))
303  ;; A list of (cons cache.rktd-path root-dir-path)
304  ;;  If root-dir-path is not #f, then paths in the cache.rktd
305  ;;  file are relative to it. #f is used for the planet cache.rktd file.
306  (define search-path
307    ((if (or (eq? key 'no-planet)
308             (eq? key 'no-user))
309         (lambda (a l) l)
310         cons)
311     (cons user-infotable #f)
312     (append
313      (map (lambda (coll)
314             (cons (build-path coll "info-domain" "compiled" "cache.rktd")
315                   coll))
316           (if (eq? key 'no-user)
317               (get-main-collects-search-dirs)
318               (current-library-collection-paths)))
319      (map (lambda (base)
320             (cons (build-path base "info-cache.rktd")
321                   base))
322           (filter
323            values
324            (if (eq? key 'no-user)
325                (list (find-share-dir))
326                (list (find-share-dir) (find-user-share-dir))))))))
327  (when t
328    (unless (equal? (table-paths t) search-path)
329      (set-table-ht! t (make-hasheq))
330      (set-table-paths! t search-path)
331      (populate-table! t)))
332  (let ([unsorted
333         (if (= (length syms) 1)
334           ;; Simple case: look up in table
335           (hash-ref (table-ht t) (car syms) null)
336           ;; Use a hash table, because the same collection might work
337           ;; for multiple syms
338           (let ([result (make-hash)])
339             (for* ([sym syms]
340                    [c (hash-ref (table-ht t) sym null)])
341               (hash-set! result c #t))
342             ;; Extract the relevant collections:
343             (hash-map result (lambda (k v) k))))])
344    (sort unsorted bytes<?
345          #:key (lambda (dr) (dir->sort-key (directory-record-path dr)))
346          #:cache-keys? #t)))
347
348;; dir->sort-key : path -> bytes
349;; extracts the name of the directory, dropping any "."s it finds at the ends.
350(define (dir->sort-key path)
351  (let-values ([(base name dir?) (split-path path)])
352    (if (eq? name 'same) (dir->sort-key base) (path->bytes name))))
353
354(define info? (->* [symbol?] [(-> any/c)] any/c))
355(define path-or-string? (lambda (x) (or (path? x) (string? x))))
356
357(provide/contract
358 (reset-relevant-directories-state! (-> any))
359 (get-info (((listof path-or-string?))
360            (#:namespace (or/c namespace? #f) #:bootstrap? any/c)
361            . ->* . (or/c info? boolean?)))
362 (get-info/full ((path-string?)
363                 (#:namespace (or/c namespace? #f) #:bootstrap? any/c)
364                 . ->* . (or/c info? boolean?)))
365 (find-relevant-directories
366  (->* [(listof symbol?)]
367       [(or/c 'preferred 'all-available 'no-planet 'no-user)]
368       (listof path?)))
369 (struct directory-record
370         ([maj integer?]
371          [min integer?]
372          [spec any/c]
373          [path path?]
374          [syms (listof symbol?)]))
375 (find-relevant-directory-records
376  (->* [(listof symbol?)]
377       [(or/c 'preferred 'all-available 'no-planet 'no-user)]
378       (listof directory-record?))))
379