2024-09-25 09:20:14 +00:00
|
|
|
(local { : view} (require :fennel))
|
|
|
|
|
|
|
|
(local server (require :http.server))
|
|
|
|
(local headers (require :http.headers))
|
2024-09-27 18:47:11 +00:00
|
|
|
(local htls (require :http.tls))
|
|
|
|
(local ctx (require :openssl.ssl.context))
|
2024-09-25 09:20:14 +00:00
|
|
|
(local csr (require :openssl.x509.csr))
|
|
|
|
(local x509 (require :openssl.x509))
|
2024-10-04 22:05:48 +00:00
|
|
|
(local extension (require :openssl.x509.extension))
|
2024-09-25 09:20:14 +00:00
|
|
|
(local pkey (require :openssl.pkey))
|
2024-09-25 11:00:40 +00:00
|
|
|
(local bignum (require :openssl.bignum))
|
|
|
|
|
2024-09-26 21:11:37 +00:00
|
|
|
;; ncall is the opposite of pcall: "non-protected call"
|
|
|
|
(macro ncall [f]
|
|
|
|
`(case ,f
|
|
|
|
ok# ok#
|
|
|
|
(nil err#) (error err#)))
|
|
|
|
|
2024-09-25 11:00:40 +00:00
|
|
|
(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)))
|
|
|
|
|
2024-09-25 11:26:34 +00:00
|
|
|
(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
|
2024-09-25 20:31:04 +00:00
|
|
|
(make-headers code { :content-type "text/plain" })
|
2024-09-25 11:26:34 +00:00
|
|
|
false)
|
|
|
|
(out:write_chunk text true))
|
2024-09-25 09:20:14 +00:00
|
|
|
|
|
|
|
(fn slurp [filename]
|
2024-09-26 21:11:37 +00:00
|
|
|
(with-open [f (ncall (io.open filename "r"))] (f:read "*a")))
|
2024-09-25 09:20:14 +00:00
|
|
|
|
2024-09-26 21:05:13 +00:00
|
|
|
(fn read-line [filename]
|
2024-09-26 21:11:37 +00:00
|
|
|
(with-open [f (ncall (io.open filename "r"))] (f:read "l")))
|
2024-09-26 21:05:13 +00:00
|
|
|
|
|
|
|
(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
|
2024-09-27 18:47:11 +00:00
|
|
|
["--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))
|
2024-09-26 21:05:13 +00:00
|
|
|
["--challenge-password" f & rest]
|
|
|
|
(assoc (parse-args rest) :challenge-password (read-line f))
|
2024-10-04 22:07:48 +00:00
|
|
|
["--sign-file" f & rest]
|
|
|
|
(assoc (parse-args rest) :sign-and-exit (slurp f))
|
2024-09-26 21:06:06 +00:00
|
|
|
[bind-address] { : bind-address }
|
2024-09-26 21:05:13 +00:00
|
|
|
_ {}))
|
|
|
|
|
|
|
|
(local options
|
|
|
|
(doto
|
|
|
|
(parse-args arg)
|
|
|
|
(case
|
2024-10-04 22:07:48 +00:00
|
|
|
{:sign-and-exit pathname }
|
|
|
|
true
|
2024-09-27 18:47:11 +00:00
|
|
|
{: ca-certificate : ca-private-key
|
|
|
|
: server-certificate : server-private-key
|
|
|
|
: challenge-password : bind-address}
|
2024-09-26 21:05:13 +00:00
|
|
|
true
|
|
|
|
_
|
|
|
|
(assert nil "missing required command line params"))))
|
|
|
|
|
2024-09-27 18:47:11 +00:00
|
|
|
(local ca-key (pkey.new options.ca-private-key))
|
|
|
|
(local ca-crt (x509.new options.ca-certificate))
|
2024-09-25 09:20:14 +00:00
|
|
|
|
|
|
|
(fn new-crt [csr]
|
|
|
|
(let [crt
|
|
|
|
(doto (x509.new)
|
2024-10-04 22:08:19 +00:00
|
|
|
(: :setVersion 3)
|
2024-09-25 11:00:40 +00:00
|
|
|
(: :setSerial (make-serial))
|
2024-09-25 09:20:14 +00:00
|
|
|
(: :setIssuer (ca-crt:getSubject))
|
|
|
|
(: :setLifetime (os.time) (+ (* 365 86400) (os.time)))
|
|
|
|
(: :setSubject (csr:getSubject))
|
2024-10-04 17:14:48 +00:00
|
|
|
(: :setPublicKey (csr:getPublicKey)))]
|
|
|
|
(for [i 1 (csr:getRequestedExtensionCount) 1]
|
|
|
|
(let [ext (csr:getRequestedExtension i)]
|
|
|
|
(crt:addExtension ext)))
|
2024-10-04 22:05:48 +00:00
|
|
|
(doto crt
|
|
|
|
(: :addExtension (extension.new "basicConstraints" "critical,CA:FALSE"))
|
|
|
|
(: :sign ca-key))))
|
2024-09-25 09:20:14 +00:00
|
|
|
|
2024-09-26 21:14:45 +00:00
|
|
|
(fn approve-request? [csr]
|
2024-10-01 23:26:21 +00:00
|
|
|
(let [challengePassword (csr:getAttribute :challengePassword)]
|
2024-09-29 09:19:07 +00:00
|
|
|
(when challengePassword
|
|
|
|
(accumulate [found false
|
|
|
|
_ v (ipairs challengePassword)]
|
|
|
|
(or found (= v options.challenge-password))))))
|
2024-09-25 20:14:13 +00:00
|
|
|
|
2024-09-25 09:20:14 +00:00
|
|
|
(fn handle-sign-csr [out]
|
2024-09-25 20:14:13 +00:00
|
|
|
(let [req (csr.new (out:get_body_as_string))]
|
2024-09-26 21:14:45 +00:00
|
|
|
(if (approve-request? req)
|
2024-09-25 20:14:13 +00:00
|
|
|
(do
|
|
|
|
(out:write_headers (make-headers 200 { :content-type "text/plain" }) false)
|
2024-10-04 17:14:48 +00:00
|
|
|
(out:write_chunk (: (new-crt req) :toPEM) true))
|
2024-09-25 20:14:13 +00:00
|
|
|
(send-error out 400 "missing attributes in CSR"))))
|
|
|
|
|
2024-09-25 09:20:14 +00:00
|
|
|
(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)
|
|
|
|
_
|
2024-09-26 20:34:37 +00:00
|
|
|
(send-error out 404 "not found"))))
|
2024-09-25 09:20:14 +00:00
|
|
|
|
2024-09-27 18:47:11 +00:00
|
|
|
(fn ssl-context []
|
|
|
|
(doto (htls.new_server_context)
|
|
|
|
(: :setCertificate (x509.new options.server-certificate))
|
|
|
|
(: :setPrivateKey (pkey.new options.server-private-key))))
|
|
|
|
|
2024-09-25 09:20:14 +00:00
|
|
|
(fn new-server []
|
2024-09-26 21:06:06 +00:00
|
|
|
(let [(addr port) (string.match options.bind-address "(.+):(%d+)$")]
|
2024-09-26 21:14:45 +00:00
|
|
|
(ncall (server.listen
|
2024-09-26 21:06:06 +00:00
|
|
|
{
|
|
|
|
:host addr
|
|
|
|
:port (tonumber port)
|
|
|
|
:onstream on-stream
|
2024-09-27 18:47:31 +00:00
|
|
|
:onerror (fn [server ctx op err errno]
|
|
|
|
(print (view { : server : ctx : err : errno })))
|
2024-09-27 18:47:11 +00:00
|
|
|
:tls true
|
|
|
|
:ctx (ssl-context)
|
2024-09-26 21:14:45 +00:00
|
|
|
}))))
|
2024-09-26 21:06:06 +00:00
|
|
|
|
2024-10-04 22:07:48 +00:00
|
|
|
(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))
|