Goals and Motivation

Proposed Solution

Point-Form Grammar

Coding Choices

Language & Environment

Literate Programming

Code Conventions & Style

Programming Paradigm

Error Handling

Source Files




System Definition

Package Definition

(in-package :fileworthy)


(defstruct app
  "Contains general, high-level app details."
  (debug t)
  (app-dir (empty 'pathname) :type PATHNAME)
  (min-password-length 4 :type INTEGER)
  (version "0.0" :type STRING)
  (last-updated (empty 'timestamp) :type TIMESTAMP)
  (web-static-dir (empty 'pathname) :type PATHNAME)
  (config-file-path (empty 'pathname) :type PATHNAME))

(empty=> (local-time:encode-timestamp 0 0 0 0 1 1 1))
(empty=> (make-app))


(defstruct config
  (site-name "" :type STRING)
  (root-dir "" :type STRING)
  (port 0 :type INTEGER)
  (allow-anonymous-read t)
  (reserved-resource-path "" :type STRING)
  (next-user-id 1 :type INTEGER)
  (users '() :type LIST))

(empty=> (make-config))

;; TODO: expand environment variables in ROOT-DIR
(defun load-config (path)
  "Load an instance of `CONFIG` from the config file."
  (let* ((config (read-file-form path)))
    ;; If no root dir is specified, use user's home dir
    (if (blank? (config-root-dir config))
      (setf (config-root-dir config)
            (to-string (uiop/common-lisp:user-homedir-pathname))))
    (if (not (char-equal #\/
                         (char (config-root-dir config)
                               (1- (length (config-root-dir config))))))
      (setf (config-root-dir config)
            (sf "~A/" (config-root-dir config))))
    (if (not (directory-exists-p (config-root-dir config)))
      (error (sf "Directory '~A' not found or inaccessible."
                 (config-root-dir config))))

Global Variables

(defvar *app*
  (empty 'app)
  "Singleton instance containing general app details.")

(defvar *config*
  (empty 'config)
  "Singleton instance contain config details.")

(defvar *acceptor*
  "Singleton Hunchentoot web handler.")


(defun create-app (debug)
  "Create APP instance."
  (let* ((app-dir (asdf:system-source-directory :fileworthy))
         (version-file-path (asdf:system-relative-pathname
         (xdg-config-home (xdg-config-home))
         (config-file-name "config")
         (config-file-dir "")
         (config-file-path ""))

    ;; If $XDG_CONFIG_HOME not set, set it to ~/.config
    (if (empty? xdg-config-home)
      (setf xdg-config-home (merge-pathnames* ".config" (user-homedir-pathname))))

    (setf config-file-dir (merge-pathnames* "fileworthy/" xdg-config-home))
    (setf config-file-path (merge-pathnames* config-file-name config-file-dir))

    (when (not (directory-exists-p config-file-dir))
      (format t
              "Creating '~A' as it doesn't exist.~%"
      (ensure-directories-exist config-file-dir))

    (when (not (file-exists-p config-file-path))
      (format t
              "Creating '~A' from default config as it doesn't exist.~%"
      (copy-file (merge-pathnames* "config" app-dir) config-file-path))

    (make-app :debug debug
              :app-dir app-dir 
              :version (asdf::read-file-form version-file-path)
                (file-write-date version-file-path))
              :web-static-dir (merge-pathnames #P"static/" app-dir)
              :config-file-path config-file-path)))

Startup and Shutdown


(defun start-app (&key (port 9090 port-given?) (debug t))
  "Starts the app."

  (if *acceptor*
    (let* ((res (new-r :error "Server is already running.")))
      (format t (r-message res))
      (return-from start-app res)))

  (setf *app* (create-app debug))
  (setf *config* (load-config (app-config-file-path *app*)))

  (if (not port-given?)
    (setf port (config-port *config*)))

  (setf *acceptor* (create-web-acceptor :port port :debug debug))


  (when debug
    (setf *catch-errors-p* nil)
    (setf *show-lisp-errors-p* t))

  (start *acceptor*)

  (setf *session-max-time* (* 60 60 24 30 3)) ; 3 months

  (let* ((res (new-r :success
                     (sf "Fileworthy ~A started on port ~A, working out of '~A'."
                         (app-version *app*)
                         (config-root-dir *config*)))))
    (format t (r-message res))


(defun stop-app ()
  "Stops the app."
  (when *acceptor*
    (stop *acceptor* :soft t)
    (setf *acceptor* nil)
    (format t "Stopped Fileworthy ~A~%" (app-version *app*))))


(defun restart-app (&key (debug t))
  "Restarts the app."
  (start-app :debug debug))


(defun create-web-acceptor (&key (port 9090) (debug t))
  "Creates an 'easy-acceptor' which will listen on the specified port."
  (make-instance 'easy-acceptor
                 :port port
                 :document-root (app-web-static-dir *app*)
                 :access-log-destination (if debug
                 :message-log-destination (if debug

Core Domain Logic


(defstruct user
  (id 0 :type INTEGER)
  (name "" :type STRING)
  (email "" :type STRING)
  (root-dir "" :type STRING) 
  (password "" :type STRING)
  (salt "" :type STRING)
  (admin? nil :type BOOLEAN))

(empty=> (make-user))

(defun get-user (&key (id 0 id-given?) name email)
  "Get user with one or more of the specified parameters."
  (if (or id-given? name email)
    (find-if (λ (user)
                (and (or (not id-given?) (= id (user-id user)))
                     (or (null name) (string-equal name (user-name user)))
                     (or (null email) (string-equal email (user-email user)))))
             (config-users *config*))))

(defun get-abs-user-root-dir (user)
  "Get the absolute root directory for the specified user."
  (if user
    (let* ((abs-dir (config-root-dir *config*)))
      (if (not (blank? (user-root-dir user)))
        (setf abs-dir
              (sf "~A~A/"
                  (string-trim '(#\/) (user-root-dir user)))))

(defun authenticate-user (user pwd)
  "Authenticate the given user."
  (and user
       (not (blank? pwd))
       (string= (gen-hash pwd (user-salt user))
                (user-password user))))


(defun random-string (&optional (n 16))
  "Return a random hex string with N digits."
  (to-string (ironclad:byte-array-to-hex-string (ironclad:make-random-salt n))))


(defun gen-hash (to-hash &optional salt)
  "Generate a hash of TO-HASH."
      (ironclad:digest-sequence :sha512
                                  (sf "~A~A" to-hash (or salt "")))))))


(defun get-fs-path-from-url (user &optional path-name)
  "Gets an absolute local file-system path from the given URL path name."
  (let* ((abs-path (get-abs-user-root-dir user)))
    (if (not (blank? path-name))
      (setf abs-path (join abs-path (trim path-name #\/ :left-only t))))


(defun get-dir-names (curr-user &optional (parent ""))
  "Gets directory names."
  (map 'list
       (λ (abs-dir)
          (last1 (split-sequence #\/
                                 (princ-to-string abs-dir)
                                 :remove-empty-subseqs t)))
         (concatenate 'string
                      (config-root-dir *config*)
                      (string-trim '(#\/) (user-root-dir curr-user))
                      (string-left-trim '(#\/) parent)))))


(defun get-file-names (dir)
  "Gets a list of file names at `DIR`."
  (map 'list
       (λ (abs-file)
          (last1 (split-sequence #\/
                                 (princ-to-string abs-file)
                                 :remove-empty-subseqs t)))
       (uiop/filesystem:directory-files dir)))


(defun get-file-content (path)
  "Get file contents of `PATH`."
  (with-open-file (stream path)
    (let ((data (make-string (file-length stream))))
      (read-sequence data stream)
      (or data ""))))


(defun pretty-time (time)
  "Formats a date/time to a user-friendly form. TIME is expected to either be a
   timestamp readable by LOCAL-TIME, or a LOCAL-TIME:TIMESTAMP object."
  (if (empty? time)
      (let* ((format-desc '())
             (timestamp (if (stringp time)
                            (parse-timestring time)

        (setf format-desc '(:short-weekday " " :short-month " " :day " "
                            :year ", " :hour12 ":" (:min 2) " " :ampm))

        (format-timestring nil timestamp :format format-desc))))


(defun is-file-binary? (path)
  "Try to detect if PATH is a binary file."
  (with-open-file (stream path
                          :element-type '(unsigned-byte 8)
                          :if-does-not-exist nil)
    (loop :for i :from 0
          :for b = (read-byte stream nil nil)
          :while b
          :when (zerop b)
          :do (return-from is-file-binary? t)))


(defun create-config-lock-file ()
  "Create a file indicating that the config file is locked."
  (let* ((lock-file (sf "~A.lck" (app-config-file-path *app*))))
    (with-open-file (stream
                      :direction :output
                      :if-exists nil
                      :if-does-not-exist :create)
      (if (null stream)
        (new-r :warning "Config file is already locked.")
          (format stream "~A" (get-universal-time))
          (new-r :success "Config file lock created."))))))


(defun delete-config-lock-file ()
  "Delete config lock file."
  (delete-file-if-exists (sf "~A.lck" (app-config-file-path *app*))))


(defun save-config (change-fn)
  "Save/update config file with contents of `*CONFIG*`."
  (let* ((lockedR (create-config-lock-file)))
    (if (failed? lockedR)
      (return-from save-config lockedR))
    (with-open-file (stream
                      (app-config-file-path *app*)
                      :direction :output
                      :if-exists :supersede
                      :if-does-not-exist :create)
      (funcall change-fn)
      (write *config* :stream stream :readably t))
  (new-r :success "Config updated."))

Web Utils

(defmacro gen-html (&body body)
  "Generate an HTML string from the given s-exp."
  `(with-html-output-to-string (*standard-output* nil)
    (htm ,@body)))
(defmethod session-cookie-name ((acceptor easy-acceptor))

(defun set-http-code (code)
  "Set the current request's HTTP status code to `CODE`."
  (setf (return-code*) code))

(defun url-for (section-or-obj)
  "Create URL for a particular section/object"
  (cond ((eq 'about section-or-obj)
         (sf "/~A/about"
             (config-reserved-resource-path *config*)))
        ((eq 'settings section-or-obj)
         (sf "/~A/settings"
             (config-reserved-resource-path *config*)))
        ((eq 'users section-or-obj)
         (sf "/~A/users"
             (config-reserved-resource-path *config*)))
        ((typep section-or-obj 'user)
         (if (= 0 (user-id section-or-obj))
           (sf "/~A/users/new"
               (config-reserved-resource-path *config*))
           (sf "/~A/users/~A/~(~A~)"
               (config-reserved-resource-path *config*)
               (user-id section-or-obj)
               (user-name section-or-obj))))
        (t "")))

(defun json-result (result &optional data)
  "Converts the given R instance to a JSON string."
    `(level ,(r-level result)
            message ,(r-message result)
            data ,(or data (r-data result)))))

(defun json-error (status-code)
  "Create a JSON response indicating an error with the specified HTTP status
  (set-http-code status-code)
    '(level error
            message "Sorry, you don't have permission to perform this request.")))

(defun set-auth-cookie (name value)
  "Create a secure cookie."
  (set-cookie name
              :value value
              ;; Expire a month from now
              :max-age (* 60 60 24 30)
              :path "/"
              :secure (not (app-debug *app*))
              :http-only t))

(defun parse-js-bool (val)
  "Parse a Javascript boolean taken from a post parameter to a Lisp bool."
  (or (string-equal "true" val)
      (string-equal "1" val)))

Web Resource Routes

(defun define-routes ()
  "Define web resource routes."
  (setq *dispatch-table*
          ;; Static files
            (sf "/~A/css/"
                (config-reserved-resource-path *config*))
            (merge-pathnames* "css/" (app-web-static-dir *app*)))
            (sf "/~A/deps/"
                (config-reserved-resource-path *config*))
            (merge-pathnames* "deps/" (app-web-static-dir *app*)))
            (sf "/~A/js/"
                (config-reserved-resource-path *config*))
            (merge-pathnames* "js/" (app-web-static-dir *app*)))

          ;; About page
            (sf "^/~A/about/?$"
                (config-reserved-resource-path *config*))

          ;; Settings page
            (sf "^/~A/settings/?$"
                (config-reserved-resource-path *config*))

          ;; Settings save API
            (sf "^/~A/api/settings/?$"
                (config-reserved-resource-path *config*))

          ;; User list page
            (sf "^/~A/users/?$"
                (config-reserved-resource-path *config*))

          ;; User detail page
            (sf "^/~A/users/.+/?$"
                (config-reserved-resource-path *config*))

          ;; User save API
            (sf "^/~A/api/users/.+/?$"
                (config-reserved-resource-path *config*))

          ;; Login API
            (sf "^/~A/api/login/?$"
                (config-reserved-resource-path *config*))

          ;; Logout page
            (sf "^/~A/logout/?$"
                (config-reserved-resource-path *config*))

          ;; File-system search API
            (sf "^/~A/api/search/?$" (config-reserved-resource-path *config*))

          ;; File-system path page (this should be the last entry)

Web Pages


(defun page-template (title page-id content)
  "Base template for all web pages."
  (let* ((rrp (config-reserved-resource-path *config*))
         (user (empty 'user :unless (session-value 'user)))
         (path-name (script-name* *request*))
         (path-segs (split-sequence #\/ path-name :remove-empty-subseqs t))
         (first-path-seg (first path-segs))
         (fw-info-page? (string-equal rrp first-path-seg)))
      (*standard-output* nil :prologue t :indent t)
      (:html :lang "en"
             (:meta :charset "utf-8")
             (:meta :name "robots" :content "noindex, nofollow")
             (:meta :http-equiv "X-UA-Compatible" :content "IE=edge")
               :name "viewport"
               :content "width=device-width, initial-scale=1")
               (if (blank? (config-site-name *config*))
                 (str title)
                 (fmt "~A - ~A"
                      (config-site-name *config*))))
             (:link :href "/images/favicon.ico" :rel "shortcut icon")
               (sf "/~A/deps/font-awesome/css/font-awesome.min.css" rrp)
               :rel "stylesheet")
               :href (sf "/~A/deps/highlightjs/styles/monokai.css" rrp)
               :rel "stylesheet")
               :href (sf "/~A/css/main.css?v=~A" rrp (app-version *app*))
               :rel "stylesheet")
               :href (sf "/~A/css/"
                         (app-version *app*))
               :rel "stylesheet")
               :href (sf "/~A/css/main.print.css?v=~A" rrp (app-version *app*))
               :rel "stylesheet")

             (:script :src (sf "/~A/deps/lodash/lodash.min.js" rrp) "")
             (:script :src (sf "/~A/deps/rxjs/Rx.min.js" rrp) "")
             (:script :src (sf "/~A/deps/momentjs/moment.min.js" rrp) "")
             (:script :src (sf "/~A/deps/markedjs/marked.min.js" rrp) "")
               :src (sf "/~A/deps/highlightjs/highlight.pack.js" rrp) "")
               :src (sf "/~A/js/utils.js?v=~A" rrp (app-version *app*)) "")
               :src (sf "/~A/js/main.js?v=~A" rrp (app-version *app*)) ""))
             :data-rrp rrp
             ;; Overlay (for dialogs)
             (:div :id "overlay" :class "hidden" " ")
             ;; Top Bar
             (:header :id "top-bar"
              ;; Menu Icon
                :href "javascript:site.toggleMenu()"
                :title "Settings"
                (:i :class "fa fa-bars" " "))
              ;; Site Name
              (:a :id "app-name" :href "/" :title "Home"
               (str (config-site-name *config*)))
              ;; User Info
              (:div :id "user-info"
               (if (empty? user)
                 ;; Logged Out
                     (:a :href "javascript:site.showLogin()"
                      (:i :class "fa fa-sign-in" "")
                      " Log In"))
                 ;; Logged In
                       :href (url-for user)
                       (str (user-name user)))
                     (:span " ")
                       :href (sf "/~A/logout" rrp)
                       :title "Log Out"
                       (:i :class "fa fa-sign-out" "")))))
              (:div :class "clear-fix"))
             ;; Fileworthy Info/Settings
               :id "info-menu"
               :class (if fw-info-page? "flat-list" "flat-list hidden")
                 :class (if (string-equal "about" (nth 1 path-segs))
                 (:a :href (url-for 'about)
                  (:i :class "fa fa-info-circle" "")
                  " About"))
               (if (user-admin? user)
                     :class (if (string-equal "settings"
                                              (nth 1 path-segs))
                     (:a :href (url-for 'settings)
                      (:i :class "fa fa-cog" "")
                      " Settings"))))
               (if (not (empty? user))
                     :class (if (and (string-equal
                                       (nth 1 path-segs))
                                       (to-string (user-id user))
                                       (nth 2 path-segs)))
                       :href (url-for user)
                       (:i :class "fa fa-user" "")
                       " My Account"))))
               (if (user-admin? user)
                     :class (if (and (string-equal "users"
                                                   (nth 1 path-segs))
                                     (empty? (nth 2 path-segs)))
                     (:a :href (url-for 'users)
                      (:i :class "fa fa-users" "")
                      " Users")))))
             (if (or (config-allow-anonymous-read *config*)
                     (not (empty? user)))
                     (:ul :id "main-menu-items" :class "flat-list"
                      ;; Root Folders
                      (loop :for dir-name :in (get-dir-names user)
                            :collect (htm
                                           (if (string= first-path-seg dir-name)
                                           :href (sf "/~A/" dir-name)
                                           (str dir-name))))))
                     ;; Sub-folders
                     (let* ((expanded-dirs (expand-sub-dirs path-name))
                            (sub-dir-name-lst (map 'list
                                                   (λ (sub-dir)
                       (loop :for sub-dir-names :in sub-dir-name-lst
                             :for i :from 0
                             :when (not (empty? sub-dir-names))
                               (:ul :class "sub-menu-items flat-list"
                                (loop :for dir-name :in sub-dir-names
                                            (if (string= dir-name
                                                         (nth (1+ i) path-segs))
                                            :href (sf "/~A/~A/"
                                                      (nth i expanded-dirs)
                                            (str dir-name))))))))))))
             (:main :id page-id
              (str content))
             ;; Login Dialog
             (:section :id "login-dialog" :class "dialog"
              (:div :class "dialog-content"
               (:h2 "Welcome!")
                   :id "username"
                   :class "full-width"
                   :onkeyup "ui.onEnter(event, site.login)"
                   :placeholder "Username/Email Address"
                   :title "Username/Email Address"
                   :type "text"))
                   :id "password"
                   :class "full-width"
                   :onkeyup "ui.onEnter(event, site.login)"
                   :placeholder "Password"
                   :title "Password"
                   :type "password"))
               (:p :id "login-result")
                   :id "login-btn"
                   :class "button full-width"
                   :href "javascript:site.login()"
                   "Log In"))
                   :id "forgot-pwd"
                   :href "javascript:forgotPwd()"
                   :style "float:left"
                   "Forgot password")
                   :href "javascript:site.closeLogin()"
                   :style "float:right"
(defun expand-sub-dirs (path-name)
  "Expand all the path segments in `PATH-NAME` to a list of sub-directories."
  (let* ((path-name (string-trim '(#\/) (or path-name ""))))
    (if (empty? path-name)
      (return-from expand-sub-dirs '()))
    (loop :for c :across path-name
          :for i :from 0
          :when (char= #\/ c)
          :collect (subseq path-name 0 i) :into lst
          :finally (return (append lst (list path-name))))))

Error pages

(defun page-error-not-found ()
  "Not found error page."
  (set-http-code +http-not-found+)
    "Not Found"
      (:h2 "Not Found")
      (:p "The page or resource you requested could not be found.")
      (if (not (string-equal "/" (script-name* *request*)))
            (:a :href "/"
             (:i :class "fa fa-home" "")
             (:b " Go back to the home page"))))))))

(defmethod acceptor-status-message (acceptor (http-status-code (eql 404)) &key)

(defun page-error-not-authorised ()
  "Not authorised error page."
  (set-http-code +http-forbidden+)
    "Not Authorised"
      (:h2 "Not Authorised")
      (:p "Sorry, you don't have permission to view this page or resource.")
      (if (not (string-equal "/" (script-name* *request*)))
            (:a :href "/"
             (:i :class "fa fa-home" "")
             (:b " Go back to the home page"))))))))

(defun page-error-server ()
  "Internal server error page."
  (set-http-code +http-internal-server-error+)
    "Server Error"
      (:h2 "Server Error")
      (:p (sf '("Sorry, it looks like something went wrong on the server. "
                "Please try again later if the problem persists.")))
      (if (not (string-equal "/" (script-name* *request*)))
            (:a :href "/"
             (:i :class "fa fa-home" "")
             (:b " Go back to the home page"))))))))

(defmethod acceptor-status-message (acceptor (http-status-code (eql 500)) &key)


(defun page-about ()
  "About page."
      (:h2 "About Fileworthy")
      (:p (sf '("Fileworthy aims to be a simple solution to managing your "
                "notes and files across many devices. It is half static site "
                "generator, half file-system.")))
      (:table :class "simple-table"
         (:td "Version")
         (:td (str (app-version *app*))))
         (:td "Last Updated")
         (:td (str (pretty-time (app-last-updated *app*)))))
         (:td "Source Code")
         (:td (:a :href ""
               "Hosted at Github")))
         (:td "License")
           (:a :href "" "GPL v3")))
         (:td "Copyright")
         (:td "2017 Thirushanth Thirunavukarasu"))))))


(defun page-settings ()
  "App settings page."
  (let* ((curr-user (session-value 'user)))
    ;; Only admins can view this page
    (if (or (null curr-user)
            (not (user-admin? curr-user)))
      (return-from page-settings (page-error-not-authorised)))
        (:h2 "Settings")
        (:ul :id "inputs" :class "flat-list"
             (:span "Site Name")
             (:input :id "site-name" :value (config-site-name *config*))
             (:div :class "clear-fix")))
             (:span "Root Folder")
             (:input :id "root-dir" :value (config-root-dir *config*))
             (:div :class "clear-fix")))
             (:span "Port")
             (:input :id "port" :value (to-string (config-port *config*)))
             (:div :class "clear-fix")))
             (:span "Allow anonymous read access")
             (if (config-allow-anonymous-read *config*)
                   (:input :id "anon-read" :checked "" :type "checkbox"))
                   (:input :id "anon-read" :type "checkbox")))
             (:div :class "clear-fix")))
           :title (sf '("The glob pattern specifying binary files to search. "
                        "Leaving this blank will search ALL binary files and "
                        "may be VERY SLOW depending on the number and size "
                        "of binary files in your root folder."))
             (:span "Binary file search glob")
               :id "bin-files-glob"
               :value (config-bin-files-glob *config*))
             (:div :class "clear-fix"))
             (:span "Reserved Resource Path")
               :id "rrp"
               :value (config-reserved-resource-path *config*))
             (:div :class "clear-fix"))))
        (:div :id "save-result" "")
          :id "save-btn"
          :class "button full-width"
          :onclick ""


(defun api-settings-save ()
  "Settings save API."
  (setf (content-type*) "application/json")
  (let* ((curr-user (empty 'user :unless (session-value 'user)))
         (site-name (post-parameter "siteName"))
         (root-dir (post-parameter "rootDir"))
         (port (loose-parse-int (post-parameter "port")))
         (port-changed? (/= port (config-port *config*)))
         (anon-read? (parse-js-bool (post-parameter "anonRead")))
         (bin-files-glob (post-parameter "binFilesGlob"))
         (rrp (post-parameter "rrp"))
         (rrp-changed? (not (string= rrp
                                     (config-reserved-resource-path *config*))))
         (save-res (new-r :error "Settings save unexpectedly aborted.")))

    ;; Validation
    (if (or (empty? curr-user)
            (not (user-admin? curr-user))) 
      (return-from api-settings-save (json-error +http-forbidden+)))
    (if (not (plusp port))
        (json-result (new-r :error "Port must be a positive integer."))))
    (if (blank? rrp)
        (json-result (new-r :error "Reserved Resource Path is required."))))

    ;; Persist
    (setf save-res
            (λ ()
               (setf (config-site-name *config*) site-name)
               (setf (config-root-dir *config*) root-dir)
               (setf (config-port *config*) port)
               (setf (config-allow-anonymous-read *config*) anon-read?)
               (setf (config-bin-files-glob *config*) bin-files-glob)
               (setf (config-reserved-resource-path *config*) rrp))))

    ;; Return success/failure
    (if (succeeded? save-res)
        (setf *config* (load-config (app-config-file-path *app*)))
        (if rrp-changed?
        ;; TODO: automatically reset if the port changed
        (if port-changed?
            (new-r :success (sf '("Config updated. Please restart the app to "
                                  "use the new port."))))
          (json-result save-res)))
      (json-result save-res))))


(defun page-user-list ()
  "User listing page."
  (let* ((curr-user (session-value 'user)))
    ;; Only admins can view this page
    (if (or (null curr-user)
            (not (user-admin? curr-user)))
      (return-from page-user-list (page-error-not-authorised)))
          :id "new-user-btn"
          :class "button"
          :href (url-for (empty 'user))
          "New User")
        (:ul :class "big-list"
            :for user :in (config-users *config*)
                  :href (url-for user)
                  (str (user-name user)))))))))))


(defun page-user-detail ()
  "User details page."
  (let* ((curr-user (empty 'user :unless (session-value 'user)))
         (path-segs (split-sequence #\/ (script-name*) :remove-empty-subseqs t))
         (user-id-str (nth 2 path-segs))
         (new-user? (string-equal "new" user-id-str))
         (req-user (empty
                     :unless (get-user :id (loose-parse-int user-id-str)))))
    ;; Redirect to Not Found page if user not found
    (if (and (not new-user?) (empty? req-user))
      (return-from page-user-detail (page-error-not-found)))
    ;; Redirect to Forbidden page if not admin and not current user
    (if (and (not (user-admin? curr-user))
             (not (eq curr-user req-user)))
      (return-from page-user-detail (page-error-not-authorised)))
      (if new-user? "New User" (user-name req-user))
          :id "name-heading"
          :data-user-id (to-string (user-id req-user))
         (if new-user? "New User" (user-name req-user)))
        (:div :id "input-fields"
           :id "user-name"
           :placeholder "Name"
           :title "Name"
           :type "text"
           :value (user-name req-user))
           :id "email-address"
           :placeholder "Email Address"
           :title "Email Address"
           :type "email"
           :value (user-email req-user))
         (if (user-admin? curr-user)
                 :id "root-dir"
                 :placeholder "Root Folder"
                 :title "Root Folder"
                 :type "text"
                 :value (user-root-dir req-user))))
         (if (user-admin? curr-user)
                 (if (user-admin? req-user)
                       (:input :id "is-admin" :checked "" :type "checkbox"))
                       (:input :id "is-admin" :type "checkbox")))
                 " Administrator")))
           :class (if new-user? "hidden" "")
             :id "show-pwds-btn"
             :class "button"
             :href "javascript:page.toggleChangePwd()"
             "Change Password")
             :id "hide-pwds-btn"
             :class "button hidden"
             :href "javascript:page.toggleChangePwd()"
             "Don't Change Password"))
           :id "password-fields"
           :class (if new-user? "" "hidden")
             :id "current-pwd"
             :class (if new-user? "hidden" "")
             :placeholder "Current Password"
             :title "Current Password"
             :type "password")
             :id "new-pwd"
             :placeholder "New Password"
             :title "New Password"
             :type "password")
             :id "new-pwd-confirm"
             :placeholder "Confirm New Password"
             :title "Confirm New Password"
             :type "password")))
        (:p :id "save-result" "")
          :id "save-btn"
          :class "button full-width"
          :href ""


(defun api-user-save ()
  "User save API."
  (setf (content-type*) "application/json")
  (let* ((curr-user (empty 'user :unless (session-value 'user)))
         (path-segs (split-sequence #\/ (script-name*) :remove-empty-subseqs t))
         (id (loose-parse-int (nth 3 path-segs)))
         (new-user? (zerop id))
         (req-user (empty 'user :unless (get-user :id id)))
         (name (post-parameter "name"))
         (email (post-parameter "email"))
         (root-dir (or (post-parameter "rootDir") ""))
         (admin? (and (user-admin? curr-user)
                      (parse-js-bool (post-parameter "isAdmin"))))
         (current-pwd (post-parameter "currentPwd"))
         (new-pwd (post-parameter "newPwd"))
         (save-res (new-r :error "User save unexpectedly aborted.")))

    ;; Validation
    (if (empty? curr-user)
      (return-from api-user-save (json-error +http-forbidden+)))
    (if (and (not new-user?) (empty? req-user))
        (json-result (new-r :error "User with id ~A not found." id))))
    ;; Non-admins cannot change another user's password
    (if (and (not new-user?)
             (not (user-admin? curr-user))
             (/= (user-id curr-user) (user-id req-user)))
        (json-error +http-forbidden+)))
    (if (empty? name)
        (json-result (new-r :error "No user name provided."))))
    (if (empty? email)
        (json-result (new-r :error "No email address provided."))))
    (if (and (empty? new-pwd)
             (or new-user?
                 (and (not new-user?) (not (empty? current-pwd)))))
        (json-result (new-r :error "No password provided."))))
    (if (and (blank? new-pwd)
             (or new-user?
                 (and (not new-user?) (not (empty? current-pwd)))))
        (json-result (new-r :error "Password can't be blank."))))
    (if (and (> (app-min-password-length *app*) (length new-pwd))
             (or new-user?
                 (and (not new-user?) (not (empty? current-pwd)))))
          (new-r :error
                 (sf "Password must be at least ~A characters."
                     (app-min-password-length *app*))))))
    (if (and (not new-user?)
             (not (user-admin? curr-user))
             (not (empty? new-pwd))
             (not (authenticate-user req-user current-pwd)))
          (new-r :error "Current password is incorrect."))))

    ;; Persist
    (setf save-res
            (λ ()
               (let* ((curr-config *config*)
                      (salt (random-string)))
                 (if new-user?
                         :id (config-next-user-id curr-config)
                         :name name
                         :email email
                         ;; Only admins can change a user's root dir
                         :root-dir (if (user-admin? curr-user)
                                     (user-root-dir req-user))
                         :admin? admin?
                         :salt salt
                         :password (gen-hash new-pwd salt))
                       (config-users curr-config))
                     (incf (config-next-user-id curr-config)))
                     (setf (user-name req-user) name)
                     (setf (user-email req-user) email)
                     (if (user-admin? curr-user)
                       (setf (user-root-dir req-user) root-dir))
                     (setf (user-admin? req-user) admin?)
                     (when (not (empty? new-pwd))
                       (setf (user-salt req-user) salt)
                       (setf (user-password req-user)
                             (gen-hash new-pwd salt)))))))))

    (if (failed? save-res)
      (return-from api-user-save (json-result save-res)))

    ;; If the password changed for an existing user, remove all session
    ;; objects for the user, except the current session
    (when (and (not new-user?)
               (not (empty? new-pwd)))
        ((session-db-lock *acceptor*))
        (setf (session-db *acceptor*)
              (loop :for (k . v) in (session-db *acceptor*)
                    :when (or (= (session-id v)
                                 (session-id *session*))
                              (/= (user-id req-user)
                                  (user-id (session-value 'user v))))
                    :collect (cons k v)))))

    ;; Return success
    (json-result (new-r :success
                        (if new-user?
                          (sf "Saved new user, ~A." name)
                          (sf "Updated ~A's account." name))))))


(defun api-login ()
  "User login API."
  (setf (content-type*) "application/json")
  (let* ((email (post-parameter "email"))
         (pwd (post-parameter "pwd"))
         (user (get-user :email email)))
    (if (empty? email)
        (json-result (new-r :error "No email address provided."))))
    (if (empty? pwd)
        (json-result (new-r :error "No password provided."))))
    (when (not (authenticate-user user pwd))
      (sleep 2)
        (json-result (new-r :error "Incorrect credentials."))))

    ;; Create session for user
    (setf (session-value 'user) user)

    (json-result (new-r :success (sf "Welcome ~A." (user-name user))))))


(defun page-logout ()
  (when *session*
    (delete-session-value 'user)
    (remove-session *session*))
      (:h2 "Thank you, come again!")
        (:a :class "full-width"
         :href "/"
         "Go back to Home page")))))


(defun api-fs-search ()
  "File-system search API."
  (setf (content-type*) "application/json")
  (let* ((user (empty 'user :unless (session-value 'user)))
         (user-root-dir-length (length (get-abs-user-root-dir user)))
         (search-path (post-parameter "search-path"))
         (search-type (post-parameter "search-type"))
         (search-txt (post-parameter "search"))
         (abs-search-path (merge-pathnames*
                            (string-left-trim '(#\/) search-path)
                            (get-abs-user-root-dir user)))
         (search-result nil))

    (log-message* :info "*** Absolute search path: ~A" abs-search-path)

    ;; Check anonymous access
    (if (and (empty? user)
             (not (config-allow-anonymous-read *config*)))
      (return-from api-fs-search (json-error +http-forbidden+)))

    (setf search-txt
          ;; Show all files if search text is "*"
          (if (string-equal "*" search-txt)
            ;; Maybe being overly cautious on allowed characters
            (ppcre:regex-replace-all "[^a-zA-Z0-9\\-_ \\./]+" search-txt "")))

    ;; Get search results (in absolute path form)
    (setf search-result
          ;; Search file names by default
          (cond ((string-equal search-type "text")
                 (search-file-content search-txt
                                      :path abs-search-path))
                ((string-equal search-type "text+binary")
                 (search-file-content search-txt
                                      :path abs-search-path
                                      :search-binary? t))
                 (search-file-names search-txt abs-search-path))))

    ;; Trim absolute path segment
    (setf (r-data search-result)
          (map 'list
               (λ (x)
                  (if (empty? x)
                    (subseq x user-root-dir-length)))
               (r-data search-result)))

    (json-result search-result)))

(defun run-cmd (cmd)
  "Run command specified by `CMD'.
   A result object is returned."
  (multiple-value-bind (std-out std-err ret-val)
      (uiop:run-program cmd
                        :ignore-error-status t
                        :output '(:string :stripped t)
                        :error-output '(:string :stripped t))
    (if (zerop ret-val)
        (new-r :success "" std-out)
        (new-r :error
               (sf "ERROR ~A: ~A"
                   (if (and (empty? std-out) (empty? std-err))
                       "unknown (cmd reported no info)"
                       (or std-err std-out)))))))


(defun search-file-names (pattern &optional path)
  "Search for files matching `pattern` at `path`."
  (let* ((cmd (sf "rg --follow --ignore-case --glob '~A' --files ~A"
                  (if (empty? pattern) pattern (sf "*~A*" pattern))
                  (or path "")))
         (search-result nil))
    (log-message* :info "Filename search cmd: ~A" cmd)
    (setf search-result (run-cmd cmd))
    (if (succeeded? search-result)
      (setf (r-data search-result)
            (sort (split-sequence #\linefeed (r-data search-result))


(defun search-file-content (pattern &key path search-binary?)
  "Search for files containing text matching `pattern` within the `path`. Optionally search
   binary files."
  (let* ((text-search-cmd
           (sf '("rg --files-with-matches --fixed-strings --follow"
                 " --ignore-case '~A' ~A")
               (or path "")))
           (sf '("rg --files-with-matches --fixed-strings --follow"
                 " --glob '~A' --ignore-case --text '~A' ~A")
               (config-bin-files-glob *config*)
               (or path "")))
         (text-search-result (new-r :info ""))
         (bin-search-result (new-r :info ""))
         (file-matches '()))

    ;; First search text files
    (log-message* :info "Text file content search cmd: ~A" text-search-cmd)
    (setf text-search-result (run-cmd text-search-cmd))
    (if (succeeded? text-search-result)
      (setf file-matches
            (split-sequence #\linefeed (r-data text-search-result))))
    (format t "TEXT-MATCHES: ~A~%" file-matches)

    ;; Then search binary files
    (when search-binary?
      (log-message* :info "Binary file content search cmd: ~A" bin-search-cmd)
      (setf bin-search-result (run-cmd bin-search-cmd))
      (if (succeeded? bin-search-result)
        (setf file-matches
              (append file-matches
                      (split-sequence #\linefeed (r-data bin-search-result))))))

    ;; Join results and sort
    (if (empty? file-matches)
      (new-r :error
               " "
               (concatenate 'string
                            (r-message text-search-result)
                            " "
                            (r-message bin-search-result))))
      (new-r :success "" (sort file-matches #'string-lessp)))))


(defun page-fs-path ()
  "File-system path page."
  (let* ((user (empty 'user :unless (session-value 'user)))
         (path-name (script-name* *request*))
         (path-segs (split-sequence #\/ path-name :remove-empty-subseqs t))
         (last-path-seg (last1 path-segs))
         (expanded-paths (expand-sub-dirs path-name))
         (abs-fs-path (empty 'string
                             :unless (get-fs-path-from-url user path-name)))
         (path-is-dir? (if (not (empty? abs-fs-path))
                         (directory-exists-p abs-fs-path)))
         (path-is-file? (if (and (not path-is-dir?)
                                 (not (empty? abs-fs-path)))
                         (file-exists-p abs-fs-path)))
         (binary-file? (if path-is-file? (is-file-binary? abs-fs-path)))
         (curr-file-name "")
         (file-content nil)
         (file-names (get-file-names abs-fs-path))
         (dir-contains-index-file? (and file-names
                                        (find ""
                                              :test #'string-equal))))
    ;; Check anonymous access
    (if (and (empty? user)
             (not (config-allow-anonymous-read *config*)))
      (return-from page-fs-path (page-error-not-authorised)))
    ;; Show 404 page if dir/file not found
    (if (and (not path-is-dir?) (not path-is-file?))
      (return-from page-fs-path (page-error-not-found)))
    ;; Download file
    (if (and path-is-file?
             (or binary-file? (get-parameter "download")))
      (return-from page-fs-path (handle-static-file abs-fs-path)))
    ;; File requested
    (when path-is-file?
      (setf curr-file-name last-path-seg)
      (when (or (not binary-file?) (get-parameter "force-show"))
        (setf file-content (get-file-content abs-fs-path))))
    ;; Directory requested, but only one text file in dir so show it
    (when (and path-is-dir?
               (= 1 (length file-names)))
      (setf abs-fs-path (concatenate 'string
                                     (to-string abs-fs-path)
                                     (first file-names)))
      (if (is-file-binary? abs-fs-path)
        (setf curr-file-name (first file-names))
        (when (or (not binary-file?) (get-parameter "force-show"))
          (setf file-content (get-file-content abs-fs-path)))))
    ;; Directory requested and has "" file, so show it
    (when (and path-is-dir? dir-contains-index-file?)
      (setf abs-fs-path (concatenate 'string
                                     (to-string abs-fs-path)
      (setf curr-file-name "")
      (setf file-content (get-file-content abs-fs-path)))
    ;; TODO: fix JS injection
      (if (empty? last-path-seg) "Home" last-path-seg)
        (:div :id "search-group"
            :id "search"
            :autocomplete "off"
            :placeholder "Search page names"
            :onclick "page.onSearchTxtClick(event)"
            :onkeydown "page.onSearchTxtKeyDown(event)"
            :onkeyup "page.onSearchTxtKeyUp(event)")
            :id "search-type"
            :onchange "page.onSearchTypeChange(event)"
            :title "Select the type of search to perform"
             :data-long-text "Search page names"
             :title "Search names of pages"
             :value "page"
             :data-long-text "Search page content (text)"
             :title "Search within plain text pages (i.e. not binary)"
             :value "text"
             :data-long-text "Search page content (text + binary)"
             :title "Searches within all pages, including binary (e.g. Word, Excel, etc.)"
             :value "text+binary"
        (:div :id "search-info" "")
          :id "search-results"
          :class "hidden"
          :data-default-size "10"
          :onclick "page.onSearchResultsClick(event)"
          :onkeydown "page.onSearchResultsKeyDown(event)"
          :size 10)
        (if (not (empty? file-names))
            (:div :id "file-names-nav"
               :id "file-names-toggle"
               :href "javascript:site.toggleFilesNav()"
               :title "Hide list of pages"
               "Hide "
               (:i :class "fa fa-minus-square" " "))
             (:table :id "files" :class "file-names"
                  :for file-name :in file-names
                      (if (string= file-name curr-file-name)
                          :href file-name
                          (str file-name)))
                          :class "download"
                          :href (sf "~A?download" file-name)
                          :title "Download file"
                          (:i :class "fa fa-download" "")))))))))))
        (if (>= (length path-segs) 2)
            (:section :id "path-trail"
               (:a :href "/"
                (:i :class "fa fa-folder-open" " "))
               " ")
             (loop :for path :in expanded-paths
                   :for i :from 0
                     (if (> i 0)
                         (:span "/")))
                       (if (and path-is-file?
                                (= (1+ i) (length expanded-paths)))
                         (sf "/~A" path)
                         (sf "/~A/" path))
                       (str (nth i path-segs))))))))
        (if (not (null file-content))
            (:section :id "file-details"
             (if (or (not binary-file?) (get-parameter "force-show"))
               (let* ((is-markdown? (cl-ppcre:scan "\\.mk?d$" abs-fs-path))
                      (file-content (cl-ppcre:regex-replace-all
                 (if (not is-markdown?)
                   (setf file-content (escape-string file-content)))
                   (:pre :id "raw-file-content" :class "hidden"
                    (:code (write-string file-content)))
                   (:div :id "gen-file-content")))
                 (:p "It looks like this is a binary file, so it isn't displayed.")
                   "You can "
                     :href (sf "~A?download" curr-file-name)
                     "download the file")
                   " or try to "
                     :href (sf "~A?force-show" curr-file-name)
                     "display it anyway.")))))))))))