cli/cli.lisp (11662 bytes)
1 (defpackage :coleslaw-cli 2 (:use :cl :trivia) 3 (:export 4 #:copy-theme 5 #:setup 6 #:new 7 #:generate 8 #:preview 9 #:watch 10 #:watch-preview 11 #:help 12 #:stage 13 #:deploy)) 14 15 (in-package :coleslaw-cli) 16 17 (defun setup-coleslawrc (user &aux (path (merge-pathnames ".coleslawrc"))) 18 "Set up the default .coleslawrc file in the current directory." 19 (with-open-file (s path :direction :output :if-exists :supersede :if-does-not-exist :create) 20 (format t "~&Generating ~a ...~%" path) 21 ;; odd formatting in this source code because emacs has problem detecting the parenthesis inside a string 22 (format s ";;; -*- mode : lisp -*-~%(~ 23 ;; Required information 24 :author \"~a\" ;; to be placed on post pages and in the copyright/CC-BY-SA notice 25 :deploy-dir \"deploy/\" ;; for Coleslaw's generated HTML to go in 26 :domain \"\" ;; to generate absolute links to the site content. Note: with :cname option of gh-pages, this requires a url scheme, e.g. https://fake.org 27 :routing ((:post \"posts/~~a\") ;; to determine the URL scheme of content on the site 28 (:tag-index \"tag/~~a\") 29 (:month-index \"date/~~a\") 30 (:numeric-index \"~~d\") 31 (:feed \"~~a.xml\") 32 (:tag-feed \"tag/~~a.xml\") 33 (:sitemap \"~~a.xml\")) 34 :title \"Improved Means for Achieving Deteriorated Ends\" ;; a site title 35 :theme \"hyde\" ;; to select one of the themes in \"coleslaw/themes/\" 36 37 ;; Optional information 38 :excerpt-sep \"<!--more-->\" ;; to set the separator for excerpt in content 39 :feeds (\"lisp\") 40 :plugins ((analytics :tracking-code \"foo\") 41 (disqus :shortname \"my-site-name\") 42 ; (incremental) ;; *Remove comment to enable incremental builds. 43 (mathjax) 44 (sitemap) 45 (static-pages) 46 ;; deployment plugins 47 ;; deployment to github pages 48 ; (gh-pages :url \"git@github.com:myaccount/myrepo.git\" 49 ; ; :cname t ;; if you want to use the custom domain --- see http://pages.github.com/ 50 ; ) 51 ;; versioned deployment. Remove comment to enable symlinked, timestamped deploys. 52 ; (versioned) 53 ;; default deploy method is rsync 54 (rsync \"-avz\" \"--delete\" \"--exclude\" \".git/\" \"--exclude\" \".gitignore\" \"--copy-links\") 55 ) 56 :sitenav ((:url \"http://~a.github.com/\" :name \"Home\") 57 (:url \"http://twitter.com/~a\" :name \"Twitter\") 58 (:url \"http://github.com/~a\" :name \"Code\") 59 (:url \"http://soundcloud.com/~a\" :name \"Music\") 60 (:url \"http://redlinernotes.com/docs/talks/\" :name \"Talks\")) 61 :staging-dir \"/tmp/coleslaw/\" ;; for Coleslaw to do intermediate work, default: \"/tmp/coleslaw\" 62 ) 63 64 ;; * Prerequisites described in plugin docs." 65 user 66 user 67 user 68 user 69 user))) 70 71 (defun copy-theme (which &optional (target which)) 72 "Copy the theme named WHICH into the blog directory and rename it into TARGET" 73 (format t "~&Copying themes/~a ...~%" which) 74 (if (probe-file (format nil "themes/~a" which)) 75 (format t "~& themes/~a already exists.~%" which) 76 (progn 77 (ensure-directories-exist "themes/" :verbose t) 78 (uiop:run-program `("cp" "-v" "-r" 79 ,(namestring (coleslaw::app-path "themes/~a/" which)) 80 ,(namestring (merge-pathnames (format nil "themes/~a" target)))))))) 81 82 (defun setup (&optional (user (uiop:getenv "USER"))) 83 (setup-coleslawrc user) 84 (copy-theme "hyde" "default")) 85 86 (defun read-rc (&aux (path (merge-pathnames ".coleslawrc"))) 87 (with-open-file (s (if (probe-file path) 88 path 89 (merge-pathnames #p".coleslawrc" (user-homedir-pathname)))) 90 (read s))) 91 92 (defun new (&optional (type "post") name) 93 (let ((sep (getf (read-rc) :separator ";;;;;"))) 94 (multiple-value-match (get-decoded-time) 95 ((second minute hour date month year _ _ _) 96 (let* ((name (or name 97 (format nil "~a-~2,,,'0@a-~2,,,'0@a" year month date))) 98 (path (merge-pathnames (make-pathname :name name :type type)))) 99 (with-open-file (s path 100 :direction :output :if-exists :error :if-does-not-exist :create) 101 (format s "~ 102 ~a 103 title: ~a 104 tags: bar, baz 105 date: ~a-~2,,,'0@a-~2,,,'0@a ~2,,,'0@a:~2,,,'0@a:~2,,,'0@a 106 format: md 107 ~:[~*~;URL: pages/~a.html~%~]~ 108 ~a 109 110 <!-- **** your post here (remove this line) **** --> 111 <!-- format: could be 'html' (for raw html) or 'md' (for markdown). --> 112 113 Here is my content. 114 115 <!--more--> 116 117 Excerpt separator can also be extracted from content. 118 Add `excerpt: <string>` to the above metadata. 119 Excerpt separator is `<!--more-->` by default. 120 " 121 sep 122 name 123 year month date hour minute second 124 (string= type "page") name 125 sep) 126 (format *error-output* "~&Created a ~a \"~a\".~%" type name) 127 (format t "~&~a~%" path) 128 path)))))) 129 130 (defun generate () 131 (stage)) 132 133 (defun stage () 134 (prog1 (coleslaw:main *default-pathname-defaults* :deploy nil) 135 (format t "~&Page generated at the staging dir ~a~%" (getf (read-rc) :staging-dir)))) 136 137 (defun deploy () 138 (prog1 (coleslaw:main *default-pathname-defaults* :deploy t) 139 (format t "~&Page deployed at the deploy dir ~a~%" (getf (read-rc) :deploy-dir)))) 140 141 (defun preview (&optional (path (getf (read-rc) :staging-dir))) 142 ;; clack depends on the global binding of *default-pathname-defaults*. 143 (let ((oldpath *default-pathname-defaults*)) 144 (unwind-protect 145 (progn 146 (when path 147 (setf *default-pathname-defaults* (truename path))) 148 (format t "~%Starting a Clack server at ~a. Press C-c to stop it~%" path) 149 (clack:clackup 150 (lack:builder 151 :accesslog 152 (:static :path (lambda (p) 153 (if (char= #\/ (alexandria:last-elt p)) 154 (concatenate 'string p "index.html") 155 p))) 156 #'identity) 157 :use-thread nil)) 158 (setf *default-pathname-defaults* oldpath)))) 159 160 ;; code from fs-watcher 161 162 (defun mtime (pathname) 163 "Returns the mtime of a pathname" 164 (when (ignore-errors (probe-file pathname)) 165 (file-write-date pathname))) 166 167 (defun dir-contents (pathnames test) 168 (remove-if-not test 169 ;; uiop:slurp-input-stream 170 (uiop:run-program `("find" ,@(mapcar #'namestring pathnames)) 171 :output :lines))) 172 173 (defun run-loop (pathnames mtimes callback delay) 174 "The main loop constantly polling the filesystem" 175 (loop 176 (sleep delay) 177 (map nil 178 #'(lambda (pathname) 179 (let ((mtime (mtime pathname))) 180 (unless (eql mtime (gethash pathname mtimes)) 181 (funcall callback pathname) 182 (if mtime 183 (setf (gethash pathname mtimes) mtime) 184 (remhash pathname mtimes))))) 185 pathnames))) 186 187 (defun watch (&optional (source-path *default-pathname-defaults*)) 188 (format t "~&Start watching! : ~a~%" source-path) 189 (let ((pathnames 190 (dir-contents (list source-path) 191 (lambda (p) (not (equal "fasl" (pathname-type p)))))) 192 (mtimes (make-hash-table))) 193 (dolist (pathname pathnames) 194 (setf (gethash pathname mtimes) (mtime pathname))) 195 (ignore-errors 196 (run-loop pathnames 197 mtimes 198 (lambda (pathname) 199 (format t "~&Changes detected! : ~a~%" pathname) 200 (finish-output) 201 (handler-case 202 (coleslaw:main source-path) 203 (error (c) 204 (format *error-output* "something happened... ~a" c)))) 205 1)))) 206 207 (defun watch-preview (&optional (source-path *default-pathname-defaults*)) 208 (when (member :swank *features*) 209 (warn "FIXME: This command does not do what you intend from a SLIME session.")) 210 (ignore-errors 211 (uiop:run-program 212 ;; The hackiness here is because clack fails? to handle? SIGINT correctly when run in a threaded mode 213 `("sh" "-c" ,(format nil "coleslaw watch ~a &~ 214 coleslaw preview &~ 215 jobs -p;~ 216 trap \"kill $(jobs -p)\" EXIT;~ 217 wait" source-path)) 218 :output :interactive 219 :error-output :interactive))) 220 221 (defun help () 222 (format *error-output* " 223 224 225 Coleslaw, a Flexible Lisp Blogware. 226 Written by: Brit Butler <redline6561@gmail.com>. 227 Distributed by BSD license. 228 229 Command Line Syntax: 230 231 coleslaw setup [NAME] --- Sets up a new .coleslawrc file in the current directory. 232 coleslaw copy-theme THEME [TARGET] --- Copies the installed THEME in coleslaw to the current directory with a different name TARGET. 233 coleslaw new [TYPE] [NAME] --- Creates a new content file with the correct format. TYPE defaults to 'post', NAME defaults to the current date. 234 coleslaw stage --- Generates the static html in the staging dir. 235 coleslaw generate --- Alias to `coleslaw stage`. 236 coleslaw deploy --- Generates the static html in the staging dir, then publish it to the deploy dir. 237 coleslaw preview [DIRECTORY] --- Runs a preview server at port 5000. DIRECTORY defaults to the staging directory. 238 coleslaw watch [DIRECTORY] --- Watches the given directory and generates the site when changes are detected. Defaults to the current directory. 239 coleslaw --- Alias to `coleslaw stage`. 240 coleslaw -h --- Show this help 241 242 Corresponding REPL commands are available in coleslaw-cli package. 243 244 ```lisp 245 (ql:quickload :coleslaw-cli) 246 (coleslaw-cli:setup &optional name) 247 (coleslaw-cli:copy-theme theme &optional target) 248 (coleslaw-cli:new &optional type name) 249 (coleslaw-cli:stage) 250 (coleslaw-cli:generate) 251 (coleslaw-cli:deploy) 252 (coleslaw-cli:preview &optional directory) 253 (coleslaw-cli:watch &optional directory) 254 ``` 255 256 Examples: 257 258 * set up a blog 259 260 mkdir yourblog ; cd yourblog 261 git init 262 coleslaw setup 263 git commit -a -m 'initial repo' 264 265 * Copy the base theme to the current directory for modification 266 267 coleslaw copy-theme hyde mytheme 268 269 * Create a post 270 271 coleslaw new 272 273 * Create a page (static page) 274 275 coleslaw new page 276 277 * Generate a site 278 279 coleslaw generate 280 # or just: 281 coleslaw 282 283 * Preview a site 284 285 coleslaw preview 286 # or 287 coleslaw preview . 288 289 " 290 )) 291 292 (defun main (&rest argv) 293 (declare (ignorable argv)) 294 (match argv 295 ((list* "setup" rest) 296 (apply #'setup rest)) 297 ((list* "preview" rest) 298 (apply #'preview rest)) 299 ((list* "watch" rest) 300 (apply #'watch rest)) 301 ((list* "watch-preview" rest) 302 (apply #'watch-preview rest)) 303 ((list* "new" rest) 304 (apply #'new rest)) 305 ((list* "generate" rest) 306 (apply #'generate rest)) 307 ((list* "stage" rest) 308 (apply #'stage rest)) 309 ((list* "deploy" rest) 310 (apply #'deploy rest)) 311 (nil 312 (generate)) 313 ((list* "copy-theme" rest) 314 (apply #'copy-theme rest)) 315 ((list* (or "-v" "--version") _) 316 ) 317 ((list* (or "-h" "--help") _) 318 (help)))) 319 320 (when (member :swank *features*) 321 (help))