(local { : view} (require :fennel))

(local server (require :http.server))
(local headers (require :http.headers))
(local htls (require :http.tls))
(local ctx (require :openssl.ssl.context))
(local csr (require :openssl.x509.csr))
(local x509 (require :openssl.x509))
(local extension (require :openssl.x509.extension))
(local pkey (require :openssl.pkey))
(local bignum (require :openssl.bignum))

;; ncall is the opposite of pcall: "non-protected call"
(macro ncall [f]
  `(case ,f
     ok# ok#
     (nil err#) (error err#)))

(fn string->bignum [bytes]
  (bignum.new
   (string.format
    "0x%03x%03x%03x%03x%03x"
    (string.unpack "I4I4I4I4I4" bytes))))

(fn make-serial []
  ;; 20 bytes, but luaossl expects it as a bignum
  (let [bytes (with-open [f (io.open "/dev/urandom" :r)]
                (f:read 20))]
    (string->bignum bytes)))

(fn make-headers [status attributes]
  (let [h (headers.new)]
    (h:append ":status" (tostring status))
    (each [k v (pairs attributes)]
      (h:append k v))
    h))

(fn send-error [out code text]
  (out:write_headers
   (make-headers code { :content-type "text/plain" })
   false)
  (out:write_chunk text true))

(fn slurp [filename]
  (with-open [f (ncall (io.open filename "r"))] (f:read "*a")))

(fn read-line [filename]
  (with-open [f (ncall (io.open filename "r"))] (f:read "l")))

(fn assoc [tbl k v & more]
  (tset tbl k v)
  (case more
    [k v] (assoc tbl k v)
    _ tbl))

(fn parse-args [args]
  (match args
    ["--ca-certificate" f & rest]
    (assoc (parse-args rest) :ca-certificate (slurp f))
    ["--ca-private-key" f & rest]
    (assoc (parse-args rest) :ca-private-key (slurp f))
    ["--server-certificate" f & rest]
    (assoc (parse-args rest) :server-certificate (slurp f))
    ["--server-private-key" f & rest]
    (assoc (parse-args rest) :server-private-key (slurp f))
    ["--challenge-password" f & rest]
    (assoc (parse-args rest) :challenge-password (read-line f))
    ["--sign-file" f & rest]
    (assoc (parse-args rest) :sign-and-exit (slurp f))
    [bind-address] { : bind-address }
    _ {}))

(local options
       (doto
           (parse-args arg)
         (case
             {:sign-and-exit pathname }
           true
             {: ca-certificate : ca-private-key
              : server-certificate : server-private-key
              : challenge-password : bind-address}
           true
           _
           (assert nil "missing required command line params"))))

(local ca-key (pkey.new options.ca-private-key))
(local ca-crt (x509.new options.ca-certificate))

(fn new-crt [csr]
  (let [crt
        (doto (x509.new)
          (: :setVersion 2)
          (: :setSerial (make-serial))
          (: :setIssuer (ca-crt:getSubject))
          (: :setLifetime (os.time) (+ (* 365 86400) (os.time)))
          (: :setSubject (csr:getSubject))
          (: :setPublicKey (csr:getPublicKey)))]
    (for [i 1 (csr:getRequestedExtensionCount) 1]
      (let [ext (csr:getRequestedExtension i)]
        (crt:addExtension ext)))
    (doto crt
      (: :addExtension (extension.new "basicConstraints" "critical,CA:FALSE"))
      (: :sign ca-key))))

(fn approve-request? [csr]
  (let [challengePassword (csr:getAttribute :challengePassword)]
    (when challengePassword
      (accumulate [found false
                   _ v (ipairs challengePassword)]
        (or found (= v options.challenge-password))))))

(fn handle-sign-csr [out]
  (let [req (csr.new (out:get_body_as_string))]
    (if (approve-request? req)
        (do
          (out:write_headers (make-headers 200 { :content-type "text/plain" }) false)
          (out:write_chunk (: (new-crt req) :toPEM) true))
        (send-error out 400 "missing attributes in CSR"))))

(fn on-stream [sv out]
  (let [hdrs (out:get_headers)
        method (hdrs:get ":method")
        path (or (hdrs:get ":path") "/")]
    (case path
      "/sign"
      (handle-sign-csr out)
      _
      (send-error out 404 "not found"))))

(fn ssl-context []
  (doto (htls.new_server_context)
    (: :setCertificate (x509.new options.server-certificate))
    (: :setPrivateKey (pkey.new options.server-private-key))))

(fn new-server []
  (let [(addr port) (string.match options.bind-address "(.+):(%d+)$")]
    (ncall (server.listen
           {
            :host addr
            :port (tonumber port)
            :onstream on-stream
            :onerror (fn [server ctx op err errno]
                       (print (view { : server : ctx : err : errno })))
            :tls true
            :ctx (ssl-context)
            }))))

(fn run-server []
  (let [s (new-server)]
    (ncall (s:listen))
    (print "server ready")
    (ncall (s:loop))))

(fn sign-text [s]
  (let [crt (new-crt (csr.new s))]
    (print (crt:toPEM))))


(if options.sign-and-exit
    (sign-text options.sign-and-exit)
    (run-server))