#lang racket/base

(require "config.rkt"
         "planet-archives.rkt"
         
         "private/planet-shared.rkt"
         "private/linkage.rkt"
         
         "resolver.rkt"
         net/url
         xml/xml
         
         mzlib/file
         mzlib/list
         mzlib/etc
         
         racket/contract
         racket/port
         racket/path
         racket/class
         racket/match
         
         setup/pack
         setup/plt-single-installer 
         setup/getinfo
         setup/unpack
         
         (for-syntax racket/base)
         (prefix-in srfi1: srfi/1)
         )

#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#

(provide 
 
 current-cache-contents
 current-linkage
 make-planet-archive
 unpack-planet-archive
 force-package-building?
 build-scribble-docs?
 get-installed-planet-archives
 get-hard-linked-packages
 unlink-all
 lookup-package-by-keys
 resolve-planet-path
 display-plt-file-structure
 display-plt-archived-file
 get-package-from-cache
 pkg->download-url
 exn:fail:planet?
 make-exn:fail:planet
 pkg-spec?)

(provide/contract
 [get-package-spec
  (->* (string? string?) (natural-number/c any/c) pkg-spec?)]
 [download-package 
  (-> pkg-spec? 
      (or/c string?
            (list/c #t path? natural-number/c natural-number/c)
            (list/c #f string?)))]
 [download/install-pkg
  (-> string? string? natural-number/c any/c (or/c pkg? #f))]
 [install-pkg
  (-> pkg-spec? path-string? natural-number/c any/c (or/c pkg? #f))]
 [add-hard-link 
  (-> string? string? natural-number/c natural-number/c path? void?)]
 [remove-hard-link 
  (-> string? string? natural-number/c natural-number/c void?)]
 [remove-pkg
  (-> string? string? natural-number/c natural-number/c void?)]
 [erase-pkg
  (-> string? string? natural-number/c natural-number/c void?)])


;; get-package-spec : string string [nat | #f] [min-ver-spec | #f] -> pkg?
;; gets the package that corresponds to the given arguments, which are
;; values corresponding to the four parts of a package specifier in require syntax
(define (get-package-spec owner pkg [maj #f] [min #f])
  (define arg
    (cond
      [(not maj) (list owner pkg)]
      [(not min) (list owner pkg maj)]
      [else      (list owner pkg maj min)]))
  (pkg-spec->full-pkg-spec arg #f))

;; download/install-pkg : string string nat nat -> pkg | #f
(define (download/install-pkg owner name maj min)
  (let* ([pspec (pkg-spec->full-pkg-spec (list owner name maj min) #f)]
         [upkg (get-package-from-server pspec)])
    (cond
      [(uninstalled-pkg? upkg)
       (pkg-promise->pkg upkg)]
      [else #f])))

;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
;; returns the packages installed in the local PLaneT cache
(define (current-cache-contents)
  (cdr (tree->list (repository-tree))))

;; just so it will be provided
(define unlink-all remove-all-linkage!)

;; to remove:
;;   -- setup-plt -c the package
;;   -- remove relevant infodomain cache entries
;;   -- delete files from cache directory
;;   -- remove any existing linkage for package
;; returns void if the removal worked; raises an exception if no package existed.

(define (remove-pkg owner name maj min)
  (let ((p (get-installed-package owner name maj min)))
    (unless p
      (raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
    (unless (normally-installed-pkg? p)
      (raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks))))
    
    (let ((path (pkg-path p)))
      (with-logging 
       (LOG-FILE)
       (lambda () 
         (printf "\n============= Removing ~a =============\n" (list owner name maj min))
         (clean-planet-package path (list owner name '() maj min))))
      (planet-log "Erasing metadata")
      (erase-metadata p)
      (planet-log "Deleting files in ~a" (path->string path))
      (delete-directory/files path)
      (planet-log "Trimming empty directories")
      (trim-directory (CACHE-DIR) path)
      (planet-log "Rebuilding documentation index")
      (reindex-user-documentation)
      (void))))

;; erase-metadata : pkg -> void
;; clears out any references to the given package in planet's metadata files
;; (i.e., linkage and info.rkt cache; not hard links which are not considered metadata)
(define (erase-metadata p)
  (remove-infodomain-entries (pkg-path p))
  (remove-linkage-to! p))

;; this really should go somewhere else. But what should setup's behavior be
;; when a package is cleaned? should it clear info-domain entries out? I think
;; no; an uncompiled package isn't necessarily not to be indexed and so on.
;; remove-infodomain-entries : path -> void
(define (remove-infodomain-entries path)
  (let* ([pathbytes (path->bytes path)]
         [cache-file (build-path (PLANET-DIR) "cache.rktd")])
    (when (file-exists? cache-file)
      (let ([cache-lines (with-input-from-file cache-file read)])
        (call-with-output-file cache-file
          (λ (op)
            (if (pair? cache-lines)
                (write (filter
                        (λ (line) 
                          (not 
                           (and
                            (pair? line)
                            (or (not (directory-exists? (bytes->path (car line))))
                                (subpath? path (bytes->path (car line)))))))                              
                        cache-lines)
                       op)
                (fprintf op "\n")))
          #:exists 'truncate/replace)))))

;; subpath? : path path -> boolean
;; determines if p1 is a subpath of p2.
(define (subpath? p1 p2)
  (let ([full-p1 (explode-path (simple-form-path p1))]
        [full-p2 (explode-path (simple-form-path p2))])
    (sublist? full-p1 full-p2 (o2 bytes=? path->bytes))))

;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
;; "compose-two"
(define (o2 a b) (λ (x y) (a (b x) (b y))))

;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
(define (sublist? l1 l2 =)
  (cond
    [(null? l1) #t]
    [(null? l2) #f]
    [(= (car l1) (car l2)) (sublist? (cdr l1) (cdr l2) =)]
    [else #f]))

(define (erase-pkg owner name maj min)
  (let* ([uninstalled-pkg-dir
          (build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
         [uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
         [uninstalled-file-exists? (file-exists? uninstalled-pkg-file)])
    (when uninstalled-file-exists?
      (delete-file uninstalled-pkg-file)
      (trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir))
    (with-handlers ([exn:fail:planet? 
                     (λ (e) (if uninstalled-file-exists? 
                                ;; not really a failure, just return
                                (void)
                                (raise e)))])
      (remove-pkg owner name maj min))))

;; listof X * listof X -> nonempty listof X
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2; 
;; signals an error otherwise.
(define (drop-common-base list1 list2)
  (let loop ((l1 list1) (l2 list2))
    (cond
      [(null? l2)
       (error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
      [(null? l1) l2]
      [(not (equal? (car l1) (car l2)))
       (error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
      [else (loop (cdr l1) (cdr l2))])))

;; pathify-list : path (listof path) -> listof path
;; given a base and a list of names, interprets each name as a subdirectory
;; of the previous, starting with base, and returns a list. (This list
;; is in reverse order, so the deepest subdirectory is returned first)
(define (pathify-list root dirs)
  (let loop ((base root) (dirs dirs) (acc '()))
    (cond
      [(null? dirs) acc]
      [else
       (let ((new (build-path base (car dirs))))
         (loop new (cdr dirs) (cons new acc)))])))

;; directory-empty? path -> bool
;; #t iff the given directory contains no subdirectories of files
(define (directory-empty? dir)
  (null? (directory-list dir)))

;; trim-directory: path path -> void
;; deletes empty directories starting with stem and working down to root
(define (trim-directory root stem)
  (let* ([rootl (explode-path root)]
         [steml (explode-path stem)]
         [extras (cdr (pathify-list root (drop-common-base rootl steml)))])
    (let loop ((dirs extras))
      (cond
        [(null? dirs) (void)]
        [(directory-empty? (car dirs))
         (delete-directory (car dirs))
         (loop (cdr dirs))]
        [else (void)]))))

;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
;; gives the current "linkage table"; a table that links modules to particular versions
;; of planet requires that satisfy those linkages
(define (current-linkage)
  (let* ((links 
          (if (file-exists? (LINKAGE-FILE))
              (with-input-from-file (LINKAGE-FILE) read-all)
              '()))
         (buckets (categorize caar links)))
    (map
     (lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
     buckets)))

;; regexp->filter : (string | regexp) -> (path -> bool)
;; computes a filter that accepts paths that match the given regexps and rejects other paths
(define (regexp->filter re-s)
  (let ([re (cond
              [(string? re-s) (regexp re-s)]
              [(regexp? re-s) re-s]
              [else (error 'regexp->filter "not a regular expression")])])
    (lambda (p) (regexp-match re (path->bytes p)))))

(define force-package-building? (make-parameter #f))
(define build-scribble-docs? (make-parameter #t))

;; ---
;; documentation stuff --- loaded on demand so that setup/scribble can be
;; omitted in the Racket distribution
(define-namespace-anchor anchor)

;; render : path[fully-expanded scribble file path] path[fully expanded directory] boolean? -> xref?
;; renders the given scribble doc file (in src dir) into the directory
;; dir as a real scribble document
(define (render src-file dest-dir multi-page?)
  (parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
    (make-directory* dest-dir)
    (let* ([index-dir (if multi-page?
                          (let-values ([(base name dir?) (split-path dest-dir)]) base)
                          dest-dir)]
           [renderer (new ((if multi-page?
                               (dynamic-require 'scribble/html-render 'render-multi-mixin)
                               values)
                           ((dynamic-require 'scribble/html-render 'render-mixin) 
                            (dynamic-require 'scribble/base-render 'render%)))
                          [dest-dir index-dir]
                          [root-path dest-dir])]
           [doc (dynamic-require `(file ,(path->string src-file)) 'doc)]
           [fp (send renderer traverse (list doc) (list dest-dir))]
           [ci (send renderer collect (list doc) (list dest-dir) fp)]
           [xref ((dynamic-require 'setup/xref 'load-collections-xref))]
           [_ ((dynamic-require 'scribble/xref 'xref-transfer-info) renderer ci xref)]
           [ri (send renderer resolve (list doc) (list dest-dir) ci)])
      (send renderer set-external-tag-path
            "/servlets/doc-search.rkt")
      (send renderer render 
            (list doc) 
            (list (if multi-page? 
                      dest-dir
                      (build-path dest-dir "index.html")))
            ri)
      ;; return cross-reference info:
      (send renderer serialize-info ri))))

;; this MUST BE a syntactic directory (with the trailing slash)
;; or the scribble renderer gets very confused
(define SCRIBBLE-DOCUMENT-DIR "planet-docs/")

;; scribble-entry? : Any -> Boolean
;; Recognizes valid list entries in info.rkt's scribblings field.
(define scribble-entry?
  (match-lambda
    [(or (list (? string?))
         (list (? string?) (? scribble-flags?))
         (list (? string?) (? scribble-flags?) (? scribble-category?))
         (list (? string?) (? scribble-flags?) (? scribble-category?) (? string?)))
     #t]
    [_ #f]))

;; scribble-flags? : Any -> Boolean
;; Recognizes a list of flags from an info.rkt scribblings entry.
(define scribble-flags?
  (match-lambda
    [(list (? symbol?) ...) #t]
    [_ #f]))

;; scribble-category : Any -> Boolean
;; Recognizes a category descriptor from an info.rkt scribblings entry.
(define scribble-category?
  (match-lambda
    [(or (list (? symbol?))
         (list (? symbol?) (? real?))) #t]
    [_ #f]))

;; scribble-entry-file : ScribbleEntry -> String
;; Produces the filename of an info.rkt scribblings entry.
(define scribble-entry-file
  (match-lambda [(list file _ ...) file]))

;; scribble-entry-flags : ScribbleEntry -> (Listof Symbol)
;; Produces the list of flags from an info.rkt scribblings entry.
(define scribble-entry-flags
  (match-lambda
    [(list _) null]
    [(list _ flags _ ...) flags]))

;; make-planet-archive: path<directory> [path<file>] -> path<file>
;; Makes a .plt archive file suitable for PLaneT whose contents are
;; all files in the given directory and returns that file's name.
;; If the optional filename argument is provided, that filename will 
;; be used as the output file's name.
(define make-planet-archive
  (case-lambda
    [(dir) 
     (let-values ([(path name must-be-dir?) (split-path dir)])
       (make-planet-archive 
        dir 
        (build-path (current-directory)
                    (string-append (path->string name) ".plt"))))]
    [(dir archive-name)
     (let ([abs-dir (simple-form-path dir)])
       (parameterize ((current-directory abs-dir))
         (let ([announcements '()]
               [warnings '()]
               [critical-errors '()])
           
           (define info.rkt
             (let ([real-info
                    (check-info.rkt-sanity 
                     dir
                     (λ (msg . args) (set! announcements (cons (apply format msg args) announcements)))
                     (λ (bad) (set! warnings (cons bad warnings)))
                     (λ (err) (set! critical-errors (cons err critical-errors))))])
               (or real-info (λ (x [y (λ () (error 'info.rkt (format "undefined field: ~a" x)))]) (y)))))

           (let ([scribble-files (info.rkt 'scribblings (λ () '()))])
             
             (define (outdir file-str)
               (let* ([filename (file-name-from-path file-str)]
                      [pathname (regexp-match #rx"(.*)\\.scrbl$" (path->bytes filename))])
                 (build-path SCRIBBLE-DOCUMENT-DIR (bytes->path (cadr pathname)))))
             
             (when (and (build-scribble-docs?)
                        (file-exists? (build-path (collection-path "setup") "scribble.rkt")))
               (with-handlers ([exn:fail? 
                                (lambda (e)
                                  (set! critical-errors
                                        (cons (format "Error generating scribble documentation: ~a" (render-exn e))
                                              critical-errors)))])
                 (unless (list? scribble-files)
                   (error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e" 
                                  scribble-files)))
                 (for ([entry scribble-files])
                   (unless (scribble-entry? entry)
                     (error "malformed scribblings entry"))
                   (let* ([filename (scribble-entry-file entry)]
                          [flags (scribble-entry-flags entry)])
                     (unless (and (relative-path? filename) 
                                  (subpath? abs-dir filename)
                                  (bytes=? (filename-extension filename) #"scrbl"))
                       (error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
                     (unless (file-exists? (build-path abs-dir filename))
                       (error (format "scribblings file ~a not found" filename)))
                     (printf "Building: ~a\n" filename)
                     (let* ([name.scrbl (file-name-from-path filename)]
                            [name       (path-replace-suffix name.scrbl #"")])
                       (render (build-path filename)
                               (build-path SCRIBBLE-DOCUMENT-DIR name)
                               (memq 'multi-page flags))))))))
           
           (unless 
               (or (null? critical-errors)
                   (force-package-building?))
             (error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors)))
           
           (pack archive-name
                 "archive" 
                 (list ".")
                 null
                 (if (PLANET-ARCHIVE-FILTER)
                     (regexp->filter (PLANET-ARCHIVE-FILTER))
                     std-filter)
                 #t
                 'file
                 #f
                 #f)
           
           (for-each display (reverse announcements))
           (newline)
           (for-each
            (λ (s) (fprintf (current-error-port) "WARNING:\n\t~a\n" s))
            (reverse warnings))))
       
       (simple-form-path archive-name))]))

(define (unpack-planet-archive plt-file target)
  (parameterize ([current-directory target])
    (unpack plt-file)))

(define (location->path loc)
  (match loc
    ['same (build-path 'same)]
    [(list 'same path) path]
    [(list other _) (error (format "bad location ~a (illegal in PLaneT packages)" other))]
    [other (error (format "bad location ~a" other))]))

(define (foreach-planet-archive plt-file on-dir on-file)
  (fold-plt-archive plt-file
                    void
                    void 
                    (λ (l _)     (on-dir (location->path l)))
                    (λ (l fip _) (on-file (location->path l) fip))
                    (void)))

;; hash-tree ::= (hash-table [string -o> (union string hash-tree)])

;; chop-path : path -> (listof (union path symbol))
;; fully chops up the given path into directory list, without
;; accessing the filesystem
(define (chop-path path)
  (let loop ([p path] [acc '()])
    (cond
      [(not (path? p)) acc]
      [else
       (let-values ([(base name _) (split-path p)])
         (loop base (cons name acc)))])))

;; ============================================================
;; hash trees

(define (new-hash-tree)
  (make-hash))

(define (hash-tree-get htree pth)
  (let loop ([pth pth]
             [htree htree]
             [route '()])
    (cond
      [(null? pth) htree]
      [(not (hash? htree))
       (error (format "subpath ~s maps to a value" (reverse route)))]
      [else 
       (let* ([head (car pth)]
              [next (hash-ref htree
                              head
                              (λ ()
                                (let ([extension (new-hash-tree)])
                                  (hash-set! htree head extension)
                                  extension)))])
         (loop (cdr pth) next (cons (car pth) route)))])))

(define (hash-tree-put-value htree pth val)
  (let-values ([(where key) (split-last pth)])
    (let ([ht (hash-tree-get htree where)])
      (unless (hash? ht)
        (error "subpath ~s maps to a value" where))
      (hash-set! ht key val))))

(define (split-last l)
  (let loop ([l l]
             [front '()])
    (cond
      [(null? (cdr l)) (values (reverse front) (car l))]
      [else
       (loop (cdr l) 
             (cons (car l) front))])))

(define (hash-tree->list ht)
  (let ([lst (hash-map ht 
                       (λ (k v)
                         (cons k 
                               (if (hash? v)
                                   (hash-tree->list v)
                                   (list v)))))])
    (sort lst (λ (a b) (string<? (car a) (car b))))))
              
;; a 'a treelist is ::= (list string 'a) | (list string ('a treelist) ...)

;; ============================================================

;; print out file treelists (treelists where 'file is the only non-structure
;; element)
(define (print-tree t depth)
  (cond
    [(and (not (null? (cdr t)))
          (not (pair? (cadr t))))
     (printf "~a~a\n" (padding depth) (car t))]
    [else
     (printf "~a~a:\n" (padding depth) (car t))
     (print-tree-list (cdr t) (add1 depth))]))

(define (print-tree-list ts depth)
  (for-each (λ (t) (print-tree t depth)) ts))
       
(define (padding n)
  (apply string-append (build-list n (λ (_) "  "))))

;; list-plt-file-contents : path-string[.plt-file] -> void
;; prints out a manifest of the given plt file
(define (display-plt-file-structure plt-file)
  
  (define root (new-hash-tree))

  (define (gen-put f)
    (λ (path) (f (chop-path (simplify-path path #f)))))
  
  (define put-directory
    (gen-put
     (λ (ps)
       (cond
         [(equal? ps '(same)) (void)]
         [else (hash-tree-get root (map path->string ps))]))))
  
  (define put-file 
    (gen-put
     (λ (ps)
       (hash-tree-put-value root (map path->string ps) 'file))))
  
  (foreach-planet-archive
   plt-file
   put-directory
   (λ (p _) (put-file p)))
  
  (print-tree-list (hash-tree->list root) 0))

;; display-plt-archived-file : path-string[.plt-file] string -> void
(define (display-plt-archived-file plt-file file-to-print)
  (let/ec finished
    (let ([target (simplify-path file-to-print #f)])
      (foreach-planet-archive
       plt-file
       void
       (λ (path fip)
         (when (equal? (simplify-path path #f) target)
           (copy-port fip (current-output-port))
           (finished (void))))))
    (error 'display-archived-plt-file "The given file was not found in the given package")))

;; check-info.rkt-sanity : path (string -> void) (string -> void) (string -> void) -> info.rkt-fn | #f
;; gets all the info.rkt fields that planet will use (using the info.rkt file
;; from the current directory) and calls the announce, warn, and fail functions with strings
;; that describe how PLaneT sees the info.rkt file. NOTA BENE: if this function calls fail, it may 
;; also warn on the same field, and the warning may not make sense. This is based on the
;; assumption that errors will be turned into some kind of critical failure that obliterates
;; all the other information produced.
(define (check-info.rkt-sanity dir announce warn fail)
  (with-handlers ([exn:fail:read? 
                   (λ (e) 
                     (fail (format "Package has an unreadable info.rkt file. ~a" (render-exn e))) 
                     #f)]
                  [exn:fail:syntax? 
                   (λ (e) 
                     (fail (format "Package's info.rkt has an syntactically ill-formed info.rkt file: ~a" (render-exn e)))
                     #f)])
    (let ([i* (get-info/full dir)])
      (cond
        [(not i*) 
         (warn "Package has no info.rkt file. This means it will not have a description or documentation on the PLaneT web site.")]
        [else
         (let ([i (λ (field) (i* field (λ () #f)))])
           (checkinfo i fail
                      [name     ; field name 
                       string?  ; check
                       (announce "Name: ~a\n" name)  ; success action
                       (warn "Package's info.rkt file has no name field.") ;failure action
                       ]
                      [blurb 
                       (λ (b) (and (list? b) (andmap xexpr? b)))
                       (announce "Package blurb: ~s\n" blurb)
                       (unless blurb
                         (warn "Package's info.rkt does not contain a blurb field. Without a blurb field, the package will have no description on planet.racket-lang.org."))]
                      [release-notes 
                       (λ (b) (and (list? b) (andmap xexpr? b)))
                       (announce "Release notes: ~s\n" release-notes)
                       (unless release-notes
                         (warn "Package's info.rkt does not contain a release-notes field. Without a release-notes field, the package will not have any listed release information on planet.racket-lang.org beyond the contents of the blurb field."))]
                      [categories
                       (λ (s) (and (list? s) (andmap symbol? s)))
                       (cond
                         [(ormap illegal-category categories)
                          =>
                          (λ (bad-cat)
                            (fail (format "Package's info.rkt file contains illegal category \"~a\". The legal categories are: ~a\n" 
                                          bad-cat
                                          legal-categories)))]
                         [else (announce "Categories: ~a\n" categories)])
                       (unless categories
                         (warn "Package's info.rkt file does not contain a category listing. It will be placed in the Miscellaneous category."))]
                      [doc.txt
                       string?
                       (announce "doc.txt file: ~a\n" doc.txt)
                       (when doc.txt
                         (warn "Package's info.rkt contains a doc.txt entry, which is now considered deprecated. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information)."))]
                      [html-docs
                       (lambda (s) (and (list? s) (andmap string? s)))
                       (warn "Package specifies an html-docs entry. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information).")]
                      [scribblings
                       (lambda (s) 
                         (and (list? s) 
                              (andmap scribble-entry? s)))
                       (void)
                       (unless scribblings
                         (warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))]
                      [homepage 
                       string?
                       (cond
                         [(url-string? homepage)
                          (announce "Home page: ~a\n" homepage)]
                         [else
                          (fail (format "The value of the package's info.rkt homepage field, ~s, does not appear to be a legal URL." homepage))])]
                      [primary-file
                       (λ (x) (or (string? x) (and (list? x) (andmap string? x))))
                       (begin
                         (cond
                           [(string? primary-file) 
                            (unless (file-in-current-directory? primary-file)
                              (warn (format "Package's info.rkt primary-file field is ~s, a file that does not exist in the package." 
                                            primary-file)))]
                           [(pair? primary-file)
                            (let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)])
                              (unless (null? bad-files)
                                (warn (format "Package's info.rkt primary-file field is ~s, which contains non-existant files ~s."
                                              primary-file bad-files))))])
                         (announce "Primary file: ~a\n" primary-file))
                       (unless primary-file
                         (warn "Package's info.rkt does not contain a primary-file field. The package's listing on planet.racket-lang.org will not have a valid require line for your package."))]
                      [required-core-version 
                       core-version?
                       (announce "Required racket version: ~a\n" required-core-version)]
                      [repositories
                       (λ (x) (and (list? x) 
                                   (srfi1:lset<= equal? x '("3xx" "4.x"))))
                       (announce "Repositories: ~s\n" repositories)
                       (warn "Package's info.rkt does not contain a repositories field. The package will be listed in all repositories by default.")]
                      [version
                       string?
                       (announce "Version description: ~a\n" version)]))])
      i*)))


(define (render-exn e)
  (let ([sp (open-output-string)])
    (parameterize ([current-output-port sp]
                   [current-error-port sp])
      ((error-display-handler) (exn-message e) e))
    (get-output-string sp)))

;; legal-categories : (listof symbol)
(define legal-categories
  '(devtools net media xml datastructures io scientific
             system ui metaprogramming planet misc))

;; legal-category : symbol -> boolean
;; determine if the given symbol is a legal category
(define (legal-category? x) (memq x legal-categories))

;; illegal-category : symbol -> (union symbol false)
;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
(define (illegal-category s) (if (legal-category? s) #f s)) 

;; url-string? : string -> boolean
;; determines if the given string is a reasonable homepage url
(define (url-string? s)
  (and (string? s)
       (let ([u (string->url s)])
         (and (url-scheme u)
              (url-host u)))))

;; file-in-current-directory? : string -> boolean
;; determines if the given string represents a file in the current directory
(define (file-in-current-directory? f)
  (and (string? f) (file-exists? f)))

;; core-version : string -> boolean
;; determines if the given string is something that (version) could've produced
(define (core-version? s)
  (and (string? s)
       (string->mz-version s)))

;; checkinfo: syntax
;; given an info.rkt function, a failure function, and a bunch of fields to check,
;; goes through the checklist calling either the success or the failure branch
;; of each check as appropriate
(define-syntax checkinfo
  (syntax-rules ()
    [(checkinfo fn fail clauses ...)
     (let ([fn* fn] [fail* fail])
       (checkinfo* () fn* fail* clauses ...))]))

(define-syntax checkinfo*
  (syntax-rules ()
    [(checkinfo* () fn fail) (void)]
    [(checkinfo* (handler1 handler ...) fn fail) (begin handler1 handler ...)]
    [(checkinfo* (handler ...) fn fail [id check on-success] clauses ...)
     (checkinfo* (handler ...) fn fail [id check on-success void] clauses ...)]
    [(checkinfo* (handler ...) fn fail [id check on-success on-fail] clauses ...)
     (checkinfo*
      (handler ...
       (let ([id (fn 'id)])
         (cond
           [id
            (let ([checked (check id)])
              (unless checked
                on-fail
                (fail (format "Package's info.rkt contained a malformed ~a field." 'id)))
              on-success)]
           [else on-fail])))
      fn fail clauses ...)]))

;; ============================================================
;; HARD LINKS (aka development links)

;; add-hard-link : string string num num path -> void
;; adds an entry in the hard-links table associating the given
;; require spec to the given path
(define (add-hard-link owner pkg-name maj min path)
  (unless (directory-exists? path)
    (if (file-exists? path)
        (error 'add-hard-link "Hard links must point to directories, not files")
        (fprintf (current-error-port) 
                 "Warning: directory ~a does not exist\n"
                 (path->string path))))
  (add-hard-link! pkg-name (list owner) maj min path))

;; remove-hard-link : string string num num -> void
;; removes any development association from the given package spec
(define (remove-hard-link owner pkg-name maj min)
  (filter-link-table!
   (lambda (row) 
     (not (points-to? row pkg-name (list owner) maj min)))
   (lambda (row) 
     (let ([p (row->package row)])
       (when p
         (erase-metadata p))))))

;; ============================================================
;; VERSION INFO

(provide this-package-version
         this-package-version-name
         this-package-version-owner
         this-package-version-maj
         this-package-version-min
         (rename-out [this-package-version/proc path->package-version]))

(define-syntax (this-package-version stx)
  (syntax-case stx ()
    [(_)
     #`(this-package-version/proc 
        #,(datum->syntax stx `(,#'this-expression-source-directory)))]))

(define-syntax define-getters
  (syntax-rules ()
    [(define-getters (name position) ...)
     (begin
       (define-syntax (name stx)
         (syntax-case stx ()
           [(name)
            #`(let ([p #,(datum->syntax stx `(,#'this-package-version))])
                (and p (position p)))]))
       ...)]))

(define-getters
  (this-package-version-name pd->name)
  (this-package-version-owner pd->owner)
  (this-package-version-maj pd->maj)
  (this-package-version-min pd->min))

;; ----------------------------------------

(define (this-package-version/proc srcdir)
  (let* ([package-roots (get-all-planet-packages)]
         [thepkg (ormap (predicate->projection (contains-dir? srcdir))
                        package-roots)])
    (and thepkg (archive-retval->simple-retval thepkg))))

;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))

;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
  (let* ([nsrcdir (simple-form-path srcdir)]
         [nsuperdir (simple-form-path (car alleged-superdir-pkg))]
         [nsrclist (explode-path nsrcdir)]
         [nsuperlist (explode-path nsuperdir)])
    (list-prefix? nsuperlist nsrclist)))

(define (list-prefix? sup sub)
  (let loop ([sub sub]
             [sup sup])
    (cond
      [(null? sup) #t]
      [(equal? (car sup) (car sub))
       (loop (cdr sub) (cdr sup))]
      [else #f])))

(define (archive-retval->simple-retval p)
  (list-refs p '(1 2 4 5)))

(define-values (pd->owner pd->name pd->maj pd->min)
  (apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))

(define (list-refs p ns)
  (map (λ (n) (list-ref p n)) ns))