From 71048681d402d5f692bf293a2785dc83fb32d384 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 9 May 2020 20:59:11 -0400 Subject: Added sign command to make detached signatures. --- kiki.hs | 16 ++++++++++++++++ lib/KeyDB.hs | 27 +++++++++++++++++++-------- lib/Kiki.hs | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- lib/Transforms.hs | 13 ++++++++----- 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 -- cgit v1.2.3