clevis-decrypt-tang in fennel

needs a lot of tidying up, but works on my test file

pkgs/default.nix

@@ -118,6 +118,7 @@ in {
   serviceFns = callPackage ./service-fns { };
   swconfig = callPackage ./swconfig { };
   systemconfig = callPackage ./systemconfig { };
+  tangc = callPackage ./tangc { };
   tufted = callPackage ./tufted { };
   uevent-watch = callPackage ./uevent-watch { };
   usb-modeswitch = callPackage ./usb-modeswitch { };

pkgs/tangc/default.nix

@@ -0,0 +1,41 @@
+{
+  fetchurl,
+  writeFennel,
+  fennel,
+  fennelrepl,
+  runCommand,
+  jose,
+  lua,
+  anoia,
+  lualinux,
+  fetch-freebsd,
+  openssl,
+  rxi-json,
+  makeWrapper,
+  stdenv
+}:
+let name = "tangc";
+in stdenv.mkDerivation {
+  inherit name;
+  src = ./.;
+
+  buildInputs = [fetch-freebsd rxi-json openssl lua jose];
+  nativeBuildInputs = [ makeWrapper ];
+
+  buildPhase = "";
+  installPhase = ''
+    mkdir -p $out/bin
+    cp -p ${writeFennel name {
+      packages = [
+        fetch-freebsd
+        rxi-json
+        fennel
+        anoia
+        lualinux
+        jose
+      ] ;
+      mainFunction = "run";
+    } ./tangc.fnl } $out/bin/${name}
+    wrapProgram $out/bin/${name} --set JOSE_BIN ${jose}/bin/jose
+  '';
+}

pkgs/tangc/tangc.fnl

@@ -0,0 +1,168 @@
+(local json (require :json))
+(local http (require :fetch))
+(local { : view : join } (require :fennel))
+(local { : split : base64  : %%} (require :anoia))
+(local ll (require :lualinux))
+
+(fn popen2 [pname argv envp]
+  (case (ll.pipe2)
+    (cin-s cin-d)
+    (match (ll.pipe2)
+      (cout-s cout-d)
+      (let [(pid err) (ll.fork)]
+        (if (not pid) (error (.. "error: " err))
+            (= pid 0)
+            (do
+              (ll.close cin-d)
+              (ll.close cout-s)
+              (ll.dup2 cin-s 0)
+              (ll.dup2 cout-d 1)
+              (ll.dup2 cout-d 2)
+              (ll.execve pname argv envp)
+              (error "execve failed"))
+            (> pid 0)
+            (do
+              (ll.close cin-s)
+              (ll.close cout-d)))
+        (values pid cin-d cout-s))
+      (nil err) (error (.. "popen pipe out: " err)))
+    (nil err) (error (.. "popen pipe in: " err))))
+
+(local CLEVIS_DEFAULT_THP_LEN 43)        ;  Length of SHA-256 thumbprint.
+(local thumbprint-algs ["S256" "S1"])
+
+(fn exited [pid]
+  (match (ll.waitpid pid)
+    (0 status) false
+    (pid status) (rshift (band status 0xff00) 8)
+    (nil errno) (error (.. "waitpid: " errno))))
+
+(fn min [a b] (if (< a b) a b))
+
+(fn trace [s] (print :TRACE s) s)
+
+(fn write-all [fd str]
+  (let [written (ll.write fd str)]
+    (if (< written (# str))
+        (write-all fd (string.sub str (+ written 1) -1)))))
+
+
+(fn jose [params inputstr]
+  (let [env (ll.environ)
+        (pid in out) (popen2 (os.getenv "JOSE_BIN") params env)]
+    ;(print "exec " (os.getenv "JOSE_BIN") (view params))
+    ;(print "writing")
+    (when inputstr (write-all in inputstr))
+    ;(print :written)
+    (ll.close in)
+    (let [output
+          (accumulate [o ""
+                       buf #(match (ll.read out) "" nil s s)]
+            (.. o buf))]
+      (values (exited pid) output))))
+
+(fn has-key? [keys kid alg]
+  (let [jkeys (json.encode keys)
+        (exitcode srv) (jose
+                        ["jose" "jwk" "thp" "-i-"
+                         "-f" kid
+                         "-a" alg]
+                        jkeys)]
+    (if (= exitcode 0)
+        (json.decode srv)
+        nil)))
+
+(fn jwk-generate [crv]
+  (let [(exitcode eph)
+        (jose ["jose" "jwk" "gen"
+               "-i" (%% "{\"alg\":\"ECMR\",\"crv\":%q}" crv)]
+              "")]
+    (if (= exitcode 0)
+        (json.decode eph)
+        (error (.. "Error generating ephemeral key: "  exitcode  "/"   eph) ))))
+
+(fn jwk-pub [response]
+  (let [(exitcode pub)
+        (jose ["jose" "jwk" "pub" "-i-"]
+               (json.encode response))]
+    (if (= exitcode 0)
+        (json.decode pub)
+        (error (.. "Error pub "  exitcode  "/"   pub) ))))
+
+(fn jwk-exc-noi [clt eph]
+  (let [payload (.. (json.encode clt) " " (json.encode eph))
+        (exitcode xfr)
+        (jose ["jose" "jwk" "exc"
+               "-l-" "-r-"]
+              payload)]
+    (if (= exitcode 0)
+        (json.decode xfr)
+        (error (.. "Error calling jwk exc: " exitcode " / " xfr  )))))
+
+(fn jwk-exc [clt eph]
+  (let [payload (.. (json.encode clt) " " (json.encode eph))
+        (exitcode xfr)
+        (jose ["jose" "jwk" "exc"
+               "-i"   "{\"alg\":\"ECMR\"}"
+               "-l-" "-r-"]
+              payload)]
+    (if (= exitcode 0)
+        (json.decode xfr)
+        (error (.. "Error calling jwk exc: " exitcode " / " xfr  )))))
+
+(fn jwe-dec [jwk ph undigested]
+  (let [payload (.. (json.encode jwk) ph undigested)
+        ; _ (print :payload  payload)
+        (exitcode plaintext)
+        (jose ["jose" "jwe" "dec" "-k-" "-i-"]
+              payload)]
+    (if (= exitcode 0)
+        plaintext
+        (error (.. "Error calling jwe dec: " exitcode " / " plaintext )))))
+
+(fn parse-jwe [jwe]
+  (assert (= jwe.clevis.pin "tang") "invalid clevis.pin")
+  (assert jwe.clevis.tang.adv "no advertised keys")
+  (assert (>= (# jwe.kid) CLEVIS_DEFAULT_THP_LEN)
+          "tang using a deprecated hash for the JWK thumbprints")
+  (let [srv (accumulate [ret nil
+                         _ alg (ipairs thumbprint-algs)
+                         &until ret]
+              (or ret (has-key? jwe.clevis.tang.adv jwe.kid alg)))]
+    {
+     :kid jwe.kid
+     :clt (assert jwe.epk)
+     :crv (assert jwe.epk.crv "Unable to determine EPK's curve!")
+     :url (assert jwe.clevis.tang.url "no tang url")
+     :srv (assert srv
+                  "JWE header validation of 'clevis.tang.adv' failed: key thumbprint does not match")
+   }))
+
+(fn http-post [url body]
+  (json.decode
+   (http.request "POST" url
+                 "" 0
+                 "application/x-www-form-urlencoded"
+                 body)))
+
+
+(fn run []
+  (let [b64 (base64 :url)
+        raw (: (io.input) :read "*a")
+        dot (string.find raw "." 1 true)
+        ph (string.sub raw 1 dot)
+        undigested (string.sub raw (+ 1 dot) -1)
+        jwe (json.decode (b64:decode ph))
+        { : srv : crv : clt : kid : url} (parse-jwe jwe)
+        eph (jwk-generate crv)
+        xfr (jwk-exc clt eph)
+        response (http-post (.. url "/rec/" kid) (json.encode xfr))]
+
+    (assert (and (= response.kty "EC") (= response.crv crv))
+            "Received invalid server reply!")
+    (let [tmp (jwk-exc eph srv)
+          rep (jwk-pub response)
+          jwk (jwk-exc-noi rep tmp)]
+      (print (jwe-dec jwk ph undigested)))))
+
+{ : run }