You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
pollen/pollen/private/command.rkt

265 lines
13 KiB
Racket

#lang racket/base
(require racket/file
racket/path
racket/vector
racket/cmdline
racket/match
sugar/coerce
"file-utils.rkt"
"log.rkt"
"../setup.rkt")
;; The use of dynamic-require throughout this file is intentional:
;; this way, low-dependency raco commands (like "version") are faster.
;; Whereas with `require` or `local-require`, everything would have to be front-loaded.
;; but ... maybe most of the latency is due to pollen/setup environment checking.
;; todo: investigate this
(module+ raco
(define command-name (with-handlers ([exn:fail? (λ (exn) #f)])
(vector-ref (current-command-line-arguments) 0)))
(dispatch command-name))
(define (get-first-arg-or-current-dir [args (cdr (vector->list (current-command-line-arguments)))]) ; cdr to strip command name from front
(normalize-path
(with-handlers ([exn:fail? (λ (exn) (current-directory))])
;; incoming path argument is handled as described in docs for current-directory
(very-nice-path (car args)))))
(define (dispatch command-name)
(with-logging-to-port
(current-error-port)
(λ ()
(case command-name
[("test" "xyzzy") (handle-test)]
[(#f "help") (handle-help)]
[("start") (handle-start)] ; parses its own args
;; "second" arg is actually third in command line args, so use cddr not cdr
[("render") (handle-render)] ; render parses its own args from current-command-line-arguments
[("version") (handle-version)]
[("reset") (handle-reset (get-first-arg-or-current-dir))]
[("setup") (handle-setup)]
[("clone" "publish") (handle-publish)]
[else (handle-unknown command-name)]))
#:logger pollen-logger
'info
'pollen))
(define (very-nice-path x)
(path->complete-path (simplify-path (cleanse-path (->path x)))))
(define (handle-test)
(displayln "raco pollen is installed correctly"))
(define (handle-help)
(displayln (format "Pollen commands:
help show this message
start [dir] [port] starts project server in dir (default is current dir)
(default port is ~a)
render [dir] render project in dir (default is current dir)
render path ... render one or more paths (can be source or output name)
publish copy project to ~a without source files
publish [dir] [dest] copy project in dir to dest without source files
(warning: overwrites existing dest)
setup preload cache
reset reset cache
version print the version" (current-server-port) (make-publish-dir-name))))
(define (handle-version)
(displayln (dynamic-require 'pollen/private/version 'pollen:version)))
(define (handle-reset directory-maybe)
(message "resetting cache ...")
((dynamic-require 'pollen/cache 'reset-cache) directory-maybe))
(define (handle-setup)
(message "preheating cache ...")
(define setup-parallel? (make-parameter #false))
(define parsed-args
(command-line #:program "raco pollen setup"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'setup' from the front
#:once-any
[("-p" "--parallel") "Setup in parallel using all cores" (setup-parallel? #true)]
[("-j" "--jobs") job-count "Setup in parallel using <job-count> jobs" (setup-parallel? (or (string->number job-count) (raise-argument-error 'handle-setup "exact positive integer" job-count)))]
#:args other-args
other-args))
(define starting-dir (match parsed-args
[(list dir) dir]
[_ (current-directory)]))
((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) starting-dir (setup-parallel?)))
(define (handle-render)
(define render-batch (dynamic-require 'pollen/render 'render-batch))
(define string-join (dynamic-require 'racket/string 'string-join))
(define make-project-pagetree (dynamic-require 'pollen/pagetree 'make-project-pagetree))
(define render-target-wanted (make-parameter (current-poly-target)))
(define render-with-subdirs? (make-parameter #f))
(define render-parallel? (make-parameter #f))
(define parsed-args
(command-line #:program "raco pollen render"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
#:once-each
[("-t" "--target") target-arg "Render target for poly sources"
(render-target-wanted (->symbol target-arg))]
[("-r" "--recursive") "Render subdirectories recursively"
(render-with-subdirs? 'recursive)]
[("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
#:once-any
[("-p" "--parallel") "Render in parallel using all cores" (render-parallel? #true)]
[("-j" "--jobs") job-count "Render in parallel using <job-count> jobs" (render-parallel? (or (string->number job-count) (raise-argument-error 'handle-render "exact positive integer" job-count)))]
#:args other-args
other-args))
(parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
(let loop ([args parsed-args])
(match args
[(? null?) (loop (list (current-directory)))]
[(list dir) ;; directory mode: one directory as argument
#:when (directory-exists? dir)
(define top-dir (very-nice-path dir))
(let render-one-dir ([dir top-dir])
(parameterize ([current-directory dir]
[current-project-root (case (render-with-subdirs?)
[(recursive) dir]
[else top-dir])])
(define dirlist (directory-list dir))
(define preprocs (filter preproc-source? dirlist))
(define static-pagetrees (filter pagetree-source? dirlist))
;; if there are no static pagetrees, use make-project-pagetree
;; (which will synthesize a pagetree if needed, which includes all sources)
(define batch-to-render
(map very-nice-path
(match static-pagetrees
[(? null?)
(message (format "rendering generated pagetree for directory ~a" dir))
(cdr (make-project-pagetree dir))]
[_
(message (format "rendering preproc & pagetree files in directory ~a" dir))
(append preprocs static-pagetrees)])))
(apply render-batch batch-to-render #:parallel (render-parallel?))
(when (render-with-subdirs?)
(for ([path (in-list dirlist)]
#:when (and (directory-exists? path)
(not (omitted-path? path))))
(render-one-dir (->complete-path path))))))]
[path-args ;; path mode
(message (format "rendering ~a" (string-join (map ->string path-args) " ")))
(apply render-batch (map very-nice-path path-args) #:parallel (render-parallel?))]))))
(define (handle-start)
(define launch-wanted #f)
(define localhost-wanted #f)
(define clargs
(command-line #:program "raco pollen start"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
#:once-each
[("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
[("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
#:args other-args
other-args))
(define dir (path->directory-path (get-first-arg-or-current-dir clargs)))
(unless (directory-exists? dir)
(error (format "~a is not a directory" dir)))
(define http-port (with-handlers ([exn:fail? (λ (e) #f)])
(string->number (cadr clargs))))
(when (and http-port (not (exact-positive-integer? http-port)))
(error (format "~a is not a valid port number" http-port)))
(parameterize ([current-project-root dir]
[current-server-port (or http-port (setup:project-server-port))]
[current-server-listen-ip (and localhost-wanted "127.0.0.1")])
(message "starting project server ...")
((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted)))
(define (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f])
(define user-publish-path
(expand-user-path (->path (setup:publish-directory project-root))))
(if (complete-path? user-publish-path)
user-publish-path
(build-path (find-system-path 'desk-dir)
(->path (case arg-command-name
[("clone") "clone"] ; bw compat
[else user-publish-path])))))
(define (delete-it! path)
(match path
[(? directory-exists?) (delete-directory/files path)]
[(? file-exists?) (delete-file path)]
;; possible we'll get a file path whose parent directory
;; has been deleted (and so it too is already gone)
[_ (void)]))
(define (contains-directory? possible-superdir possible-subdir)
(define (has-prefix? xs prefix)
(and (>= (length xs) (length prefix))
(andmap equal? prefix (for/list ([(x idx) (in-indexed xs)]
#:break (= idx (length prefix)))
x))))
((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir)))
(define (handle-publish)
(define command-name ; either "publish" or "clone"
(vector-ref (current-command-line-arguments) 0))
(define force-target-overwrite? (make-parameter #true))
(define other-args (command-line
;; drop command name
#:argv (vector-drop (current-command-line-arguments) 1)
#:once-each
[("-c" "--confirm") "Confirm overwrite of existing dest dir"
(force-target-overwrite? #f)]
#:args other-args
other-args))
;; other-args looks like (list [maybe-source-dir-arg] [maybe-dest-dir-arg])
(define source-dir (simplify-path (get-first-arg-or-current-dir other-args)))
(define dest-dir
(simplify-path
;; the source-dir might have its own pollen.rkt specifying a publish destination
(with-handlers ([exn:fail? (λ (exn) (make-publish-dir-name source-dir command-name))])
(path->complete-path (string->path (cadr other-args))))))
(unless (directory-exists? source-dir)
(error 'publish (format "source directory ~a does not exist" source-dir)))
(when (source-dir . contains-directory? . dest-dir)
(error 'publish "aborted because destination directory for publishing (~a) can't be inside source directory (~a)" dest-dir source-dir))
(when (dest-dir . contains-directory? . source-dir)
(error 'publish "aborted because destination directory for publishing (~a) can't contain source directory (~a)" dest-dir source-dir))
(when (equal? dest-dir (current-directory))
(error 'publish "aborted because destination directory for publishing (~a) can't be the same as current directory (~a)" dest-dir (current-directory)))
(message (string-append (format "publishing from ~a to ~a ..." source-dir dest-dir)))
(define do-publish-operation?
(or (not (directory-exists? dest-dir))
(force-target-overwrite?)
(begin
(display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir))
(case (read)
[(y yes) #true]
[else #false]))))
(cond
[do-publish-operation?
(when (directory-exists? dest-dir)
(delete-directory/files dest-dir))
(copy-directory/files source-dir dest-dir)
;; if source-dir is provided, we want it to be treated as current-directory.
;; if no source-dir is provided, it is set to current-directory,
;; so the parameterize is a no-op.
(parameterize* ([current-directory source-dir]
[current-project-root (current-directory)])
(define (delete-from-publish-dir? p)
(and (omitted-path? p) (not (extra-path? p))))
(for-each delete-it! (find-files delete-from-publish-dir? dest-dir)))
(message "publish completed")]
[else (message "publish aborted")]))
(define (handle-unknown command)
(match command
[(regexp #rx"(shit|fuck)")
(define responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy."))
(displayln (list-ref responses (random (length responses))))]
[_ (displayln (format "`~a` is an unknown command." command))
(display "These are the available ") ; ... "Pollen commands:"
(handle-help)
(exit 1)]))