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 not-found [out]
  (doto (headers.new)
    (: :append ":status" :404)
    (: :append :content-type :text/plain)
    (out:write_headers false))
  (out:write_chunk "not found" 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")))

(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 handle-sign-csr [out]
  (let [body  (out:get_body_as_string)]
    (doto (headers.new)
      (: :append ":status" :200)
      (: :append :content-type :text/plain)
      (out:write_headers false))
    (let [req (csr.new body)]
      (print :subject (req:getSubject))
      (out:write_chunk (new-crt req) true))))

(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)
      _
      (not-found out))))


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


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