(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))))))))