certifix/main.fnl

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

(fn read-line [filename]
  (with-open [f (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
    ["--certificate" f & rest]
    (assoc (parse-args rest) :certificate (slurp f))
    ["--private-key" f & rest]
    (assoc (parse-args rest) :private-key (slurp f))
    ["--challenge-password" f & rest]
    (assoc (parse-args rest) :challenge-password (read-line f))
    [bind-address] { : bind-address }
    _ {}))

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

(local ca-key (pkey.new options.private-key))
(local ca-crt (x509.new options.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))
          (: :sign ca-key))]
    (crt:toPEM)))

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


(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") "/")]
    (case path
      "/sign"
      (handle-sign-csr out)
      _
      (send-error out 404 "not found"))))

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

(fn new-server []
  (let [(addr port) (string.match options.bind-address "(.+):(%d+)$")]
    (case (server.listen
           {
            :host addr
            :port (tonumber port)
            :onstream on-stream
            })
      f (doto f (print))
      (nil e) (error e))))

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