certifix

main.fnl (5189B)

---

 (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 3)
           (: :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)))
     ;; https://www.golinuxcloud.com/add-x509-extensions-to-certificate-openssl/
     (when (not (crt:getExtension "extendedKeyUsage"))
       (crt:addExtension (extension.new "extendedKeyUsage" "clientAuth")))
     (doto crt
       (: :addExtension (extension.new "basicConstraints" "critical,CA:FALSE"))
       (: :addExtension (extension.new "keyUsage" "digitalSignature,nonRepudiation,keyEncipherment,dataEncipherment")) ;; all of these?
       (: :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"))
     (out:shutdown)))
 
 (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))