Added sign command to make detached signatures.

4 files changed, 91 insertions, 16 deletions

diff --git a/kiki.hs b/kiki.hs
index 1138b7a..fe9a979 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1636,6 +1636,21 @@ kiki "verify" argvals =
         Left er  -> hPutStrLn stderr $ usageErrorMessage er
         Right io -> io
 
+kiki "sign" args | "--help" `elem` args = do
+    putStr . unlines $
+        [ "kiki sign [--homedir HOMEDIR | --homeless] [[--keyring FILE] ...] --with-key KEYID FILE"
+        ]
+kiki "sign" argvals =
+    let opts = [("--homedir",1),("--keyring",1),("--homeless",0),("--with-key",1)]
+    in case runArgs (parseInvocation (fancy opts [] "") argvals)
+                    (signFile <$> flag "--homeless"
+                                <*> dashdashHomedir
+                                <*> args "--keyring"
+                                <*> arg "--with-key"
+                                <*> param 0) of
+        Left er  -> hPutStrLn stderr $ usageErrorMessage er
+        Right io -> io
+
 kiki cmd args = hPutStrLn stderr $ "I don't know how to "++cmd++"."
 
 sshkeyname :: Packet -> [FilePath]
@@ -1684,6 +1699,7 @@ commands =
  --    also repairs signature and adds missing cross-certification.
  , ( "tar", "import or export system key files in tar format" )
  , ( "verify", "Check a clear-sign pgp signature." )
+ , ( "sign", "Create a detached signature for a given file.")
  ]
 
 main :: IO ()
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
index fd0a9ce..fc20b91 100644
--- a/lib/KeyDB.hs
+++ b/lib/KeyDB.hs
@@ -4,7 +4,7 @@ module KeyDB
     , SigAndTrust
     , SubKey(..)
     , KeyData(..)
-    , KeyDB
+    , KeyDB(..)
     , KeyGrip(..)
     , emptyKeyDB
     , keyData
@@ -68,6 +68,7 @@ data KeyData = KeyData
 
 
 newtype KeyGrip = KeyInt Int
+ deriving Eq
 
 fingerprintGrip :: Fingerprint -> KeyGrip
 fingerprintGrip (Fingerprint bs) =
@@ -109,10 +110,20 @@ kkData db = Map.toList (byKeyKey db)
 lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData
 lookupKeyData kk db = Map.lookup kk (byKeyKey db)
 
-lookupByGrip :: KeyGrip -> KeyDB -> [KeyData]
-lookupByGrip k db = mapMaybe (`Map.lookup` byKeyKey db)
-                    $ concat . maybeToList
-                    $ I.lookup k (byGrip db)
+lookupByGrip :: KeyGrip -> KeyDB -> [(MappedPacket,KeyData)]
+lookupByGrip k db = do
+    kk <- concat $ maybeToList $ I.lookup k (byGrip db)
+    case Map.lookup kk (byKeyKey db) of
+        Just kd | fingerprintGrip (fingerprint (packet $ keyMappedPacket kd)) == k -> [(keyMappedPacket kd, kd)]
+                | otherwise -> do
+                    sub <- associatedKeys kd
+                    guard (mpGrip sub == k)
+                    [ (sub, kd) ]
+        Nothing -> do
+            kd <- Map.elems (byKeyKey db)
+            sub <- associatedKeys kd
+            guard (mpGrip sub == k)
+            [ (sub, kd) ]
 
 transmute :: (Monad m, Monad kiki, Traversable kiki) =>
        ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
@@ -137,14 +148,14 @@ associatedKeys kd = keyMappedPacket kd : [ k | SubKey k _ <- Map.elems (keySubKe
 alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
 alterKeyDB update kk db = db
     { byKeyKey = Map.alter update kk (byKeyKey db)
-    , byGrip = case Map.lookup kk (byKeyKey db) of
+    , byGrip = {- case Map.lookup kk (byKeyKey db) of
         Just _  -> byGrip db
-        Nothing -> case update Nothing of
+        Nothing -> -} case update Nothing of
             Just kd -> let go g m = I.alter (\case Nothing  -> Just [kk]
                                                    Just kks -> Just $ mergeL [kk] kks)
                                             g
                                             m
-                        in foldr go (byGrip db) $ map mpGrip $ associatedKeys kd
+                        in foldr go (byGrip db) $ map mpGrip $ filter (isKey . packet) $ associatedKeys kd
             Nothing -> byGrip db
     }
 
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 9513b0f..f89aad2 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ViewPatterns      #-}
 module Kiki
     ( module Kiki
     , setVerifyFlag
@@ -48,9 +49,11 @@ import qualified SSHKey                     as SSH
 import           CommandLine
 import           DotLock
 import           GnuPGAgent                 (Query (..))
+import qualified IntMapClass as I
 import           KeyRing hiding (pemFromPacket)
 import           KeyDB
 import           KeyRing.BuildKeyDB (gpgipv6addr, Hostnames, allNames)
+import           TimeUtil
 
 withAgent :: [PassphraseSpec] -> [PassphraseSpec]
 withAgent [] = [PassphraseAgent]
@@ -763,6 +766,48 @@ verifyFile isHomeless cap keyrings filename = do
             _ -> do
                 hPutStrLn stderr "Unsupported file format."
 
+signFile :: Bool -> CommonArgsParsed -> [FilePath] -> String -> FilePath -> IO ()
+signFile isHomeless cap keyrings keyid filename = do
+    let mop = minimalOp isHomeless cap
+    KikiResult r report <- runKeyRing mop
+                                { opFiles = opFiles mop
+                                    `Map.union` Map.fromList
+                                        [ (ArgFile f, strm { access = Sec }) | f <- keyrings ]
+                                }
+    case r of
+        KikiSuccess rt -> go rt
+        err            -> hPutStrLn stderr $ errorString err
+ where
+    go :: KeyRingRuntime -> IO ()
+    go rt = do
+        tm <- modificationTime <$> getFileStatus filename
+        bs <- L.readFile filename
+        let hashed = [] -- TODO: FingerprintPacket
+            unhashed = [IssuerPacket keyid]
+            lit = LiteralDataPacket
+                    { format = 'b' -- b:binary, t:text, u:utf8
+                    , filename  = filename
+                    , timestamp = fromTime tm -- seconds since Jan 1, 1970 UTC
+                    , content = bs
+                    }
+            hash = SHA512
+            matchkey fp mp = matchpr fp (packet mp) == fp
+        case smallprGrip keyid of
+            Nothing -> hPutStrLn stderr "Bad keygrip."
+            Just grip -> do
+                let keydata = lookupByGrip grip (rtKeyDB rt)
+                case keydata of
+                    [] -> hPutStrLn stderr "No matching key."
+                    (k,_):_ -> rtPassphrases rt (Unencrypted,S2K 100 "") k >>= \case
+                        KikiSuccess un -> do
+                            mb <- pgpSign (Message [un]) (DataSignature lit []) hash keyid
+                            case mb of
+                                Nothing -> hPutStrLn stderr "Failed to make signature."
+                                Just o -> do
+                                    putStrLn $ "Using "++show (fingerprint un)++" to write " <> filename <> ".sig"
+                                    let sigs = map (\sig -> sig { unhashed_subpackets = unhashed }) (signatures_over o)
+                                    L.writeFile (filename <> ".sig") $ L.concat $ map encode sigs
+                        err -> hPutStrLn stderr $ errorString err
 
 parsePackets :: L.ByteString -> Either String [Packet]
 parsePackets bs = case decodeOrFail bs of
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 6250dea..118b494 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -340,13 +340,13 @@ accBindings bs = as
 
 sigpackets ::
   Monad m =>
-  Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
-sigpackets typ hashed unhashed = return $
+  Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
+sigpackets typ alg hashed unhashed = return $
     signaturePacket
         4 -- version
         typ -- 0x18 subkey binding sig, or 0x19 back-signature
-        RSA
-        SHA1
+        alg
+        SHA256
         hashed
         unhashed
         0 -- Word16 -- Left 16 bits of the signed hash value
@@ -409,6 +409,7 @@ makeInducerSig topk wkun uid extras
     = CertificationSignature (secretToPublic topk)
                              uid
                              (sigpackets 0x13
+                                         (key_algorithm wkun)
                                          subpackets
                                          subpackets_unh)
    where
@@ -578,6 +579,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
                         (SubkeySignature wk
                                          (head parsedkey)
                                          (sigpackets 0x19
+                                                     (key_algorithm $ head parsedkey)
                                                      hashed0
                                                      [IssuerPacket subgrip]))
                         SHA256
@@ -590,6 +592,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
                        (SubkeySignature wk
                                         (head parsedkey)
                                         (sigpackets 0x18
+                                                   (key_algorithm wkun)
                                                    hashed0
                                                    unhashed0))
                       SHA256
@@ -636,7 +639,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
 candidateSignerKeys :: KeyDB -> Packet -> [Packet]
 candidateSignerKeys db sig =
     case issuerGrip sig of
-        Just g -> concatMap (map packet . associatedKeys) $ lookupByGrip g db
+        Just g -> concatMap (map packet . associatedKeys . snd) $ lookupByGrip g db
         _      -> map keyPacket $ keyData db
 
 issuerGrip :: Packet -> Maybe KeyGrip