1 files changed, 195 insertions, 0 deletions
diff --git a/ctftilde/src/guile/ctftilde.scm b/ctftilde/src/guile/ctftilde.scm
new file mode 100644
index 0000000..e42fdb9
--- /dev/null
+++ b/ctftilde/src/guile/ctftilde.scm
@@ -0,0 +1,195 @@
+(define-module (ctftilde)
+  #:use-module ((srfi srfi-26) #:select (cut))
+
+  #:use-module ((ice-9 control) #:select (let/ec))
+  #:use-module ((ice-9 exceptions) #:select
+                (raise-exception with-exception-handler))
+  #:use-module ((ice-9 format) #:select (format))
+  #:use-module ((ice-9 getopt-long) #:select (getopt-long option-ref))
+  #:use-module ((ice-9 match) #:select (match match-lambda match-let))
+  #:use-module ((ice-9 textual-ports) #:prefix tp:)
+
+  #:use-module ((system repl debug) #:select (terminal-width))
+
+  #:use-module ((ctftilde main-site) #:select (run-website))
+  #:use-module ((ctftilde password) #:select (encrypt-password))
+  #:use-module ((ctftilde users) #:prefix cu:)
+
+  #:export (main))
+
+
+
+(define %ctftilde-exit
+  (make-parameter (lambda _
+                    (raise-exception
+                     "%ctftilde-exit called while not parameterized."))))
+
+(define (error-exit fmt . format-args)
+  (apply format (current-error-port)
+         fmt format-args)
+  ((%ctftilde-exit) EXIT_FAILURE))
+
+(define (require-option options option-sym)
+  (match (option-ref options option-sym #f)
+
+    (#f
+     (error-exit "--~a is required for this action.~%" option-sym))
+
+    (value
+     value)))
+
+(define %option-spec
+  '((site-host      (single-char #\h) (value #f))
+    (user-delete    (single-char #\d) (value #f))
+    (user-make      (single-char #\m) (value #f))
+    (users-recreate (single-char #\r) (value #f))
+
+    (password-file (single-char #\p) (value #t))
+    (username      (single-char #\u) (value #t))
+
+    (log-file      (single-char #\l) (value #t))))
+
+(define (site-host options)
+  (match-let (((sock-child . sock-parent) (socketpair AF_UNIX SOCK_STREAM 0)))
+
+    (force-output (current-output-port))
+    (force-output (current-error-port))
+
+    (match (primitive-fork)
+
+      (0
+       (let ((user (getpwnam "ctftilde")))
+         (close-port sock-parent)
+         (setgid (passwd:gid user))
+         (setuid (passwd:uid user))
+         (run-website sock-child sock-child)
+
+         ;; Likely unreachable.
+         (close-port sock-child)))
+
+      (child-pid
+       (close-port sock-child)
+       (cu:make-users-from-port sock-parent sock-parent)
+
+       ;; Other side should be closed already.
+       (close-port sock-parent)
+
+       (let ((status (cdr (waitpid child-pid))))
+         (when (> status 0)
+           (error-exit
+            "HTTP server child process terminated with error.  Stopping daemon.~%"))
+         status)))))
+
+(define (user-delete options)
+  (define username
+    (require-option options 'username))
+
+  (cu:delete-user username))
+
+(define (user-make options)
+  (define username
+    (require-option options 'username))
+
+  (define password
+    (call-with-input-file (require-option options 'password-file)
+      tp:get-string-all))
+
+  (define encrypted-password
+    (encrypt-password password))
+
+  (call-with-output-file "/dev/null"
+    (cut cu:make-user <> username encrypted-password)))
+
+(define (users-recreate options)
+  (cu:delete-users-from-dir)
+  (cu:make-users-from-dir))
+
+(define %actions
+  ;; global args
+  (map (cut append <> '(log-file))
+       ;; handler         action         allowed args
+       `((,site-host      site-host      . ())
+         (,user-delete    user-delete    . (username))
+         (,user-make      user-make      . (password-file username))
+         (,users-recreate users-recreate . ()))))
+
+(define (*main options)
+  (define chosen-actions
+    (filter (match-lambda ((_ action-sym . _)
+                           (option-ref options action-sym #f)))
+            %actions))
+
+  (match chosen-actions
+
+    (()
+     (error-exit "You need to choose one of the following actions: ~{--~a~^, ~}.~%"
+                 (map cadr %actions)))
+
+    (((action-handler . (and action-allowed-args
+                             (action-sym . _)))
+      . _)
+     (match (filter (lambda (option-sym)
+                      (and (not (memq option-sym action-allowed-args))
+                           (option-ref options option-sym #f)))
+                    (map car %option-spec))
+
+       ((illegal-option-sym . _)
+        (error-exit "You cannot use --~a with --~a.~%"
+                    illegal-option-sym action-sym))
+
+       (()
+        (action-handler options))))))
+
+(define (with-log-output-file path thunk)
+  (call-with-output-file path
+    (lambda (port)
+      ;; There're some issues with log messages not going to the right fd but I
+      ;; cba to investigate in more depth.
+      (parameterize ((current-output-port port)
+                     (current-error-port port))
+        (thunk)))))
+
+(define (call-with-logging-to-file path thunk)
+  (define logging-port
+    (open-file path "a"))
+
+  (setvbuf logging-port 'line)
+
+  (dynamic-wind
+
+    noop
+
+    (lambda _
+      (parameterize ((current-output-port logging-port)
+                     (current-error-port logging-port))
+        (thunk)))
+
+    (cut close-port logging-port)))
+
+(define (main . cli-args)
+  (define options
+    (getopt-long cli-args %option-spec))
+
+  (define (with-log-output thunk)
+    (match (option-ref options 'log-file #f)
+
+      (#f
+       (thunk))
+
+      (path
+       (call-with-logging-to-file path thunk))))
+
+  (with-log-output
+   (lambda _
+     (let/ec escape
+       (start-stack 'ctftilde
+         (parameterize ((%ctftilde-exit escape))
+           (with-exception-handler (lambda (ex)
+                                     (terminal-width 80)
+                                     (let ((err (current-error-port)))
+                                       (display-backtrace (make-stack #t) err 2)
+                                       (format err "~%~a~%~%" ex)
+                                       (escape EXIT_FAILURE)))
+             (lambda _
+               (*main options)
+               0))))))))