serve-catalog.rkt (5698B)
1 #lang racket/base 2 (require web-server/servlet-env 3 web-server/dispatch 4 web-server/http/response-structs 5 web-server/http/request-structs 6 net/url 7 racket/format 8 racket/cmdline 9 racket/file 10 racket/path 11 racket/string 12 racket/tcp 13 racket/port 14 racket/system 15 (only-in distro-build/config extract-options) 16 distro-build/readme) 17 18 (module test racket/base) 19 20 (define from-dir "built") 21 22 (define-values (config-file config-mode 23 default-server-hosts default-server-port 24 during-cmd-line) 25 (command-line 26 #:once-each 27 [("--mode") dir "Serve package archives from <dir> subdirectory" 28 (set! from-dir dir)] 29 #:args (config-file config-mode server-hosts server-port . during-cmd) 30 (values config-file config-mode 31 server-hosts (string->number server-port) 32 during-cmd))) 33 34 (define server-hosts 35 (hash-ref (extract-options config-file config-mode) 36 '#:server-hosts 37 (string-split default-server-hosts ","))) 38 (define server-port 39 (hash-ref (extract-options config-file config-mode) 40 '#:server-port 41 default-server-port)) 42 43 (define build-dir (path->complete-path "build")) 44 (define built-dir (build-path build-dir from-dir)) 45 46 (define dirs (list built-dir)) 47 48 (define (pkg-name->info req name) 49 (for/or ([d (in-list dirs)]) 50 (define f (build-path d "catalog" "pkg" name)) 51 (and (file-exists? f) 52 ;; Change leading "../" to "./" in source, because 53 ;; we've shifted "pkg" relative to the site root 54 ;; by skipping over "catalog" in the URL. 55 (let ([ht (call-with-input-file* 56 f 57 read)]) 58 (hash-set ht 59 'source 60 (regexp-replace #rx"^[.][.]/" 61 (hash-ref ht 'source) 62 "./")))))) 63 64 (define (response/sexpr v) 65 (response 200 #"Okay" (current-seconds) 66 #"text/s-expr" null 67 (λ (op) (write v op)))) 68 69 (define (write-info req pkg-name) 70 (response/sexpr (pkg-name->info req pkg-name))) 71 72 (define (record-installer dir filename desc) 73 (when desc 74 (define table-file (build-path dir "table.rktd")) 75 (call-with-file-lock/timeout 76 #:max-delay 2 77 table-file 78 'exclusive 79 (lambda () 80 (define t (hash-set 81 (if (file-exists? table-file) 82 (call-with-input-file* table-file read) 83 (hash)) 84 desc 85 filename)) 86 (call-with-output-file table-file 87 #:exists 'truncate/replace 88 (lambda (o) 89 (write t o) 90 (newline o)))) 91 void))) 92 93 (define (receive-file req filename) 94 (unless (relative-path? filename) 95 (error "upload path name must be relative")) 96 (define dir (build-path build-dir "installers")) 97 (make-directory* dir) 98 (call-with-output-file (build-path dir filename) 99 #:exists 'truncate/replace 100 (lambda (o) 101 (write-bytes (request-post-data/raw req) o))) 102 (define desc 103 (for/or ([h (in-list (request-headers/raw req))]) 104 (and (equal? (header-field h) #"Description") 105 (bytes->string/utf-8 (header-value h))))) 106 (record-installer dir filename desc) 107 (response/sexpr #t)) 108 109 (define-values (dispatch main-url) 110 (dispatch-rules 111 [("pkg" (string-arg)) write-info] 112 [("upload" (string-arg)) #:method "put" receive-file])) 113 114 ;; Tunnel extra hosts to first one: 115 (when (and (pair? server-hosts) 116 (pair? (cdr server-hosts))) 117 (for ([host (in-list (cdr server-hosts))]) 118 (thread 119 (lambda () 120 (define l (tcp-listen server-port 5 #t host)) 121 (let loop () 122 (define-values (i o) (tcp-accept l)) 123 (define-values (i2 o2) (tcp-connect (car server-hosts) server-port)) 124 (thread (lambda () 125 (copy-port i o2) 126 (close-input-port i) 127 (close-output-port o2))) 128 (thread (lambda () 129 (copy-port i2 o) 130 (close-input-port i2) 131 (close-output-port o))) 132 (loop)))))) 133 134 (define (go) 135 (serve/servlet 136 dispatch 137 #:command-line? #t 138 #:listen-ip (if (null? server-hosts) 139 #f 140 (car server-hosts)) 141 #:extra-files-paths 142 (append 143 (list (build-path build-dir "origin")) 144 (list readmes-dir) 145 ;; for "pkgs" directories: 146 (for/list ([d (in-list dirs)]) 147 (path->complete-path d)) 148 ;; for ".git": 149 (list (current-directory))) 150 #:servlet-regexp #rx"" 151 #:port server-port)) 152 153 (define readmes-dir (build-path build-dir "readmes")) 154 (make-directory* readmes-dir) 155 156 (define readme-file (build-path readmes-dir "README.txt")) 157 (unless (file-exists? readme-file) 158 (printf "Generating default README\n") 159 (call-with-output-file* 160 readme-file 161 (lambda (o) 162 (display (make-readme (hash)) o)))) 163 164 (if (null? during-cmd-line) 165 ;; Just run server: 166 (go) 167 ;; Run server in a background thread, finish by 168 ;; running given command: 169 (let ([t (thread go)]) 170 (sync (system-idle-evt)) ; try to wait until server is ready 171 (unless (apply system* 172 (let ([exe (car during-cmd-line)]) 173 (if (and (relative-path? exe) 174 (not (path-only exe))) 175 (find-executable-path exe) 176 exe)) 177 (cdr during-cmd-line)) 178 (error 'server-catalog 179 "command failed: ~s" 180 during-cmd-line))))