#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 ) ] ) )