Add support for signatures

src/Main.hs

@@ -18,6 +18,7 @@ import Sysctl (_SO_MAX_CONN)
 import qualified Control.Monad                        as Monad
 import qualified Control.Monad.Except                 as Except
 import qualified Data.ByteString                      as ByteString
+import qualified Data.ByteString.Char8                as ByteString.Char8
 import qualified Data.ByteString.Builder              as Builder
 import qualified Data.ByteString.Lazy                 as ByteString.Lazy
 import qualified Data.Vector                          as Vector
@@ -32,9 +33,16 @@ import qualified Nix
 import qualified Options
 import qualified Options.Applicative                  as Options
 import qualified System.BSD.Sysctl                    as Sysctl
+import qualified System.Environment                   as Environment
 
-makeApplication :: Integer -> ByteString -> Application
-makeApplication priority storeDirectory request respond = do
+data ApplicationOptions = ApplicationOptions
+    { priority       :: Integer
+    , storeDirectory :: ByteString
+    , secretKey      :: Maybe ByteString
+    }
+
+makeApplication :: ApplicationOptions -> Application
+makeApplication ApplicationOptions{..} request respond = do
     let stripStore = ByteString.stripPrefix (storeDirectory <> "/")
 
     let done = Except.throwError
@@ -76,7 +84,7 @@ makeApplication priority storeDirectory request respond = do
                     Just storePath -> do
                         return storePath
 
-                PathInfo{..} <- liftIO (Nix.queryPathInfo storePath)
+                pathInfo@PathInfo{..} <- liftIO (Nix.queryPathInfo storePath)
 
                 narHash2 <- case ByteString.stripPrefix "sha256:" narHash of
                     Nothing -> do
@@ -115,6 +123,23 @@ makeApplication priority storeDirectory request respond = do
                         Nothing ->
                             return mempty
 
+                fingerprint <- case Nix.fingerprintPath storePath pathInfo of
+                    Nothing -> internalError "invalid NAR hash"
+                    Just builder -> do
+                        return (ByteString.Lazy.toStrict (Builder.toLazyByteString builder))
+
+                signatures <- case secretKey of
+                    Just key -> do
+                        signature <- liftIO (Nix.signString key fingerprint)
+
+                        return (Vector.singleton signature)
+
+                    Nothing -> do
+                        return sigs
+
+                let buildSignature signature =
+                        "Sig: " <> Builder.byteString signature <> "\n"
+
                 let builder =
                             "StorePath: "
                         <>  Builder.byteString storePath
@@ -129,6 +154,7 @@ makeApplication priority storeDirectory request respond = do
                         <>  "\n"
                         <>  referencesBuilder
                         <>  deriverBuilder
+                        <>  foldMap buildSignature signatures
 
                 let size =
                         ( ByteString.Lazy.toStrict
@@ -197,6 +223,9 @@ toSocket path = do
 
     return socket
 
+readSecretKey :: FilePath -> IO ByteString
+readSecretKey = fmap ByteString.Char8.strip . ByteString.readFile
+
 main :: IO ()
 main = do
     options@Options{ priority, verbosity } <- do
@@ -204,13 +233,17 @@ main = do
 
     storeDirectory <- Nix.getStoreDir
 
+    secretKeyFile <- Environment.lookupEnv "NIX_SECRET_KEY_FILE"
+
+    secretKey <- traverse readSecretKey secretKeyFile
+
     let logger =
             case verbosity of
                 Quiet   -> id
                 Normal  -> RequestLogger.logStdout
                 Verbose -> RequestLogger.logStdoutDev
 
-    let application = logger (makeApplication priority storeDirectory)
+    let application = logger (makeApplication ApplicationOptions{..})
 
     case options of
         Options{ ssl = Disabled, socket = TCP{ host, port } } -> do

src/Nix.hsc

@@ -1,23 +1,30 @@
 {-# LANGUAGE BlockArguments           #-}
 {-# LANGUAGE DuplicateRecordFields    #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MultiWayIf               #-}
 {-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE TypeApplications         #-}
 
 module Nix where
 
+import Control.Applicative (empty)
 import Control.Monad.Managed (Managed)
 import Data.ByteString (ByteString)
+import Data.ByteString.Builder (Builder)
 import Data.Vector (Vector)
 import Data.Word (Word64)
 import Foreign (Ptr, Storable(..))
 import Foreign.C (CChar, CLong, CSize, CString)
 
-import qualified Control.Exception     as Exception
-import qualified Control.Monad.Managed as Managed
-import qualified Data.ByteString       as ByteString
-import qualified Data.Vector           as Vector
-import qualified Data.Vector.Storable  as Vector.Storable
+import qualified Control.Exception       as Exception
+import qualified Control.Monad.Managed   as Managed
+import qualified Data.ByteString         as ByteString
+import qualified Data.ByteString.Base16  as Base16
+import qualified Data.ByteString.Base32  as Base32
+import qualified Data.ByteString.Builder as Builder
+import qualified Data.Vector             as Vector
+import qualified Data.Vector.Storable    as Vector.Storable
 import qualified Foreign
 
 #include "nix.hh"
@@ -208,4 +215,48 @@ queryPathInfo storePath = do
                 cPathInfo <- peek output
                 fromCPathInfo cPathInfo
 
+fingerprintPath :: ByteString -> PathInfo -> Maybe Builder
+fingerprintPath storePath PathInfo{ narHash, narSize, references } = do
+    suffix <- ByteString.stripPrefix "sha256:" narHash
 
+    base32Suffix <- if
+        | ByteString.length suffix == 64
+        , Right digest <- Base16.decodeBase16 suffix ->
+            return (Base32.encodeBase32' digest)
+        | ByteString.length suffix == 52 ->
+            return suffix
+        | otherwise ->
+            empty
+
+    return
+        (   "1;"
+        <>  Builder.byteString storePath
+        <>  ";sha256:"
+        <>  Builder.byteString base32Suffix
+        <>  ";"
+        <>  Builder.word64Dec narSize
+        <>  ";"
+        <>  referencesBuilder
+        )
+  where
+    referencesBuilder =
+        case Vector.uncons references of
+            Nothing ->
+                mempty
+            Just (r0, rs) ->
+                    Builder.byteString r0
+                <>  foldMap (\r -> "," <> Builder.byteString r) rs
+
+foreign import ccall "signString" signString_
+    :: CString -> CString -> Ptr String_ -> IO ()
+
+signString :: ByteString -> ByteString -> IO ByteString
+signString secretKey fingerprint =
+    ByteString.useAsCString secretKey \cSecretKey ->
+        ByteString.useAsCString fingerprint \cFingerprint ->
+            Foreign.alloca \output -> do
+                let open = signString_ cSecretKey cFingerprint output
+                let close = freeString output
+                Exception.bracket_ open close do
+                    string_ <- peek output
+                    fromString_ string_