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

(local server (require :http.server))
(local headers (require :http.headers))
(local ssl (require :openssl))
(local csr (require :openssl.x509.csr))
(local x509 (require :openssl.x509))
(local pkey (require :openssl.pkey))
(local bignum (require :openssl.bignum))

(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 (io.open filename "r")] (f:read "*a")))

(local ca-key (pkey.new (slurp "ca.key")))
(local ca-crt (x509.new (slurp "ca.crt")))
(local psk (with-open [f (io.open "psk" "r")] (f:read "l")))

(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))
          (: :sign ca-key))]
    (crt:toPEM)))

(fn approved-request? [csr]
  (let [attr (csr:getAttributes)]
    (accumulate [found false
                 _ v (ipairs (. attr "challengePassword"))]
      (or found (= v psk)))))


(fn handle-sign-csr [out]
  (let [req (csr.new (out:get_body_as_string))]
    (if (approved-request? req)
        (do
          (out:write_headers (make-headers 200 { :content-type "text/plain" }) false)
          (out:write_chunk (new-crt req) 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") "/")]
    (print :path path)
    (case path
      "/sign"
      (handle-sign-csr out)
      _
      (send-error out 404 "not found"))))


(fn new-server []
  (server.listen
            {
             :host :localhost
             :port 8201
             :onstream on-stream
             }))


(doto (new-server)
  (: :listen)
  (print "server ready")
  (: :loop))