From 365bdcd8d9f4a08aaae35fc27722d268f4af9041 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 11 Jul 2019 22:17:09 -0400 Subject: WIP: verify command to verify clear-sign PGP signatures. --- kiki.hs | 19 +++++++++++-- lib/CommandLine.hs | 38 +++++++++++++++++-------- lib/KeyRing/BuildKeyDB.hs | 12 ++++---- lib/Kiki.hs | 69 +++++++++++++++++++++++++++++++++++++++------ lib/Transforms.hs | 71 ++++++++++++++++++++++++----------------------- 5 files changed, 146 insertions(+), 63 deletions(-) diff --git a/kiki.hs b/kiki.hs index cd0f516..b4512f3 100644 --- a/kiki.hs +++ b/kiki.hs @@ -1647,6 +1647,20 @@ kiki "tar" args = do ["-A":_] -> putStrLn "unimplemented." -- import tar file? _ -> kiki "tar" ["--help"] +kiki "verify" args | "--help" `elem` args = do + putStr . unlines $ + [ "kiki verify [--homedir HOMEDIR | --homeless] [[--keyring FILE] ...] FILE" + ] +kiki "verify" argvals = + let opts = [("--homedir",1),("--keyring",1),("--homeless",0)] + in case runArgs (parseInvocation (fancy opts [] "") argvals) + (verifyFile <$> flag "--homeless" + <*> dashdashHomedir + <*> args "--keyring" + <*> 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] @@ -1709,7 +1723,7 @@ ipsecKeyNames (Hostnames _ onames _ _) = do tarT :: ([[String]],Map.Map String [String]) -> IO () tarT (sargs,margs) = do - KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs + KikiResult rt report <- runKeyRing $ minimalOp False $ parseCommonArgs margs case rt of KikiSuccess rt -> do let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs @@ -1720,7 +1734,7 @@ tarT (sargs,margs) = do tarC :: ([[String]],Map.Map String [String]) -> IO () tarC (sargs,margs) = do - KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs + KikiResult rt report <- runKeyRing $ minimalOp False $ parseCommonArgs margs case rt of KikiSuccess rt -> do CTime pubtime <- modificationTime <$> getFileStatus (rtPubring rt) @@ -1813,6 +1827,7 @@ commands = , ( "rename", "Change the usage tag on a specified subkey" ) -- 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." ) ] main :: IO () diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs index ea5d6b8..2676260 100644 --- a/lib/CommandLine.hs +++ b/lib/CommandLine.hs @@ -14,6 +14,8 @@ module CommandLine , fancy , runArgs , arg + , args + , flag , param , params , label @@ -50,11 +52,11 @@ type MergeData = [(Int,Ordering)] data Expr a where -- Prim -- - -- Takes a function from the option arguments and unamed arguments repsectively to - -- a value of type a, usually IO (), and gives you an expression tree. As one - -- traverses down the tree only the 'interesting' option arguments are passed - -- to this function, but all of the unnamed arguments are passed regardless of - -- where we are in the tree. + -- Takes a function from the option arguments and unnamed arguments + -- respectively to a value of type a, usually IO (), and gives you an + -- expression tree. As one traverses down the tree only the 'interesting' + -- option arguments are passed to this function, but all of the unnamed + -- arguments are passed regardless of where we are in the tree. -- Prim :: ([[String]] -> [String] -> a) -> Interval (SuperOrd Int) -> Expr a -- Star @@ -233,17 +235,31 @@ mergeBy comp xs ys = trace (unlines ["xs="++show xs,"ys="++show ys,"mergeData="+ -} +-- | The nth unnamed argument. param :: Int -> Args String param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) [] +-- | All unnamed arguments as a list. +params :: Args [String] +params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) [] + + +-- | The value of named by the given option name. arg :: String -> Args String arg optname = Args (Prim (\opts _ -> concat $ take 1 $ concat $ take 1 opts) - (singleton $ exactly 0)) + (singleton $ exactly 0)) [optname] -params :: Args [String] -params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) [] +-- | All values named by the given option name. +args :: String -> Args [String] +args optname = fromMaybe [] <$> optional + (Args (Prim (\opts _ -> concat $ take 1 opts) + (singleton $ exactly 0)) -- no unnamed arguments + [optname]) -- one named argument +-- | True if the given named option is present. +flag :: String -> Args Bool +flag optname = maybe False (const True) <$> optional (arg optname) label :: String -> Args a -> Args a label _ = id @@ -286,7 +302,7 @@ vanilla flags = ArgsStyle { parseInvocation = parse flags } -- -- * default polyvariadic - Implicit polyvariadic option if no other option is specified. -- -fancy :: [([Char], Int)] -> [[Char]] -> [Char] -> ArgsStyle +fancy :: [(String, Int)] -> [String] -> String -> ArgsStyle fancy sargspsec polyVariadicArgs defaultPoly = ArgsStyle { parseInvocation = parse sargspsec polyVariadicArgs defaultPoly } where @@ -470,8 +486,8 @@ runArgs (os,us) c where os' = sortOn fst os dups = mapMaybe notSingle $ groupBy ((==) `on` fst) (os' :: [(String,[String])]) - where notSingle [x] = Nothing - notSingle ((k,v):xs) = Just (k,v : map snd xs) + where notSingle [x] = Nothing + notSingle ((k,v):xs) = Just (k,v : map snd xs) getbit = Map.fromList $ zip (accepts c) [0..] goods :: [(Int,[String])] (bads,goods) = partitionEithers $ map f os' diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index afee71a..a3df62d 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -186,12 +186,12 @@ buildKeyDB ctx grip0 keyring = do let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk - rt0 = KeyRingRuntime { rtPubring = homepubPath ctx - , rtSecring = homesecPath ctx - , rtGrip = grip - , rtWorkingKey = wk - , rtRingAccess = accs - , rtKeyDB = Map.empty + rt0 = KeyRingRuntime { rtPubring = homepubPath ctx + , rtSecring = homesecPath ctx + , rtGrip = grip + , rtWorkingKey = wk + , rtRingAccess = accs + , rtKeyDB = Map.empty , rtPassphrases = transcode } -- autosigns and deletes diff --git a/lib/Kiki.hs b/lib/Kiki.hs index d6a8b3a..20ab1f2 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -6,6 +6,8 @@ module Kiki , setVerifyFlag ) where +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as ASCIIArmor +import Codec.Encryption.OpenPGP.ASCIIArmor.Types import Control.Applicative import Control.Exception import Control.Monad @@ -95,7 +97,7 @@ ciphers = takeWhile notFallback $ map toEnum $ [0..4]++[7..] refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO () refresh root homepass = do let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) } - KikiResult r report <- runKeyRing $ minimalOp homepass' + KikiResult r report <- runKeyRing $ minimalOp False homepass' let mroot = case root "" of "/" -> Nothing "" -> Nothing @@ -116,8 +118,8 @@ streaminfo = StreamInfo , transforms = [] } -minimalOp :: CommonArgsParsed -> KeyRingOperation -minimalOp cap = op +minimalOp :: Bool -> CommonArgsParsed -> KeyRingOperation +minimalOp isHomeless cap = op where streaminfo = StreamInfo { fill = KF_None , typ = KeyRingFile @@ -127,10 +129,12 @@ minimalOp cap = op , transforms = [] } op = KeyRingOperation - { opFiles = Map.fromList $ - [ ( HomeSec, streaminfo { access = Sec }) - , ( HomePub, streaminfo { access = Pub }) - ] + { opFiles = if isHomeless + then Map.empty + else Map.fromList $ + [ ( HomeSec, streaminfo { access = Sec }) + , ( HomePub, streaminfo { access = Pub }) + ] , opPassphrases = withAgent $ do pfile <- maybeToList (cap_passfd cap) return $ PassphraseSpec Nothing Nothing pfile , opTransforms = [] @@ -501,7 +505,10 @@ refreshCache rt rootdir = do flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do let grip = fingerprint wk - exportOp = passphrases <> pemSecrets <> minimalOp (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) Nothing) + exportOp = passphrases <> pemSecrets + <> minimalOp False + (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) + Nothing) where passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } pemSecrets = mempty { opFiles = Map.fromList @@ -663,7 +670,7 @@ replaceSshServerKeys root cmn = do strm = streaminfo { typ = PEMFile, spill = KF_Match "ssh-server", access = Sec } delssh strm = strm { transforms = DeleteSubkeyByUsage "ssh-server" : transforms strm , fill = KF_All } - KikiResult r report <- runKeyRing $ minimalOp homepass' + KikiResult r report <- runKeyRing $ minimalOp False homepass' case r of KikiSuccess rt -> Kiki.refreshCache rt $ case root "" of "/" -> Nothing @@ -694,3 +701,47 @@ kikiOptions = ( ss, ps ) where ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1),("--cipher",1)] ps = [] + +verifyFile :: Bool -> CommonArgsParsed -> [FilePath] -> FilePath -> IO () +verifyFile isHomeless cap keyrings filename = do + let mop = minimalOp isHomeless cap + KikiResult r report <- runKeyRing mop + { opFiles = opFiles mop + `Map.union` Map.fromList + [ (ArgFile f, strm { access = Pub }) | f <- keyrings ] + } + case r of + KikiSuccess rt -> go rt + err -> hPutStrLn stderr $ errorString err + where + go :: KeyRingRuntime -> IO () + go rt = do + bs <- L.readFile filename + case ASCIIArmor.decodeLazy bs of + Right (ClearSigned hashes txt (Armor ArmorSignature _ sig):_) -> + case parsePackets sig of + Right sigs -> do + let over = DataSignature lit sigs + lit = LiteralDataPacket + { format = error "format" :: Char + , filename = filename + , timestamp = error "timestamp" :: Word32 + , content = bs + } + -- TODO: Remove this take 1 after optimizing 'candidateSignerKeys' + tentativeTake1 xs = take 1 xs + keys = concatMap (candidateSignerKeys (rtKeyDB rt)) $ tentativeTake1 sigs + good = verify (Message keys) over + putStrLn $ "verifyFile: " ++ show (length $ signatures_over good) + rs -> do + hPutStrLn stderr $ show rs + _ -> do + hPutStrLn stderr "Unsupported file format." + + +parsePackets :: L.ByteString -> Either String [Packet] +parsePackets bs = case decodeOrFail bs of + Left (more,off,er) -> Left er + Right (more,off,pkt) -> do + if (more/=L.empty) then parsePackets more >>= \pkts -> Right (pkt : pkts) + else Right [pkt] diff --git a/lib/Transforms.hs b/lib/Transforms.hs index adb7830..8eaa482 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -56,37 +56,34 @@ data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show -- | This is a GPG Identity which includes a master key and all its UIDs and -- subkeys and associated signatures. -data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key - , keySigAndTrusts :: [SigAndTrust] -- sigs on main key - , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids - , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys - } deriving Show +data KeyData = KeyData + { keyMappedPacket :: MappedPacket -- main key + , keySigAndTrusts :: [SigAndTrust] -- sigs on main key + , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids + , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys + } deriving Show type KeyDB = Map.Map KeyKey KeyData data KeyRingRuntime = KeyRingRuntime - { rtPubring :: FilePath - -- ^ Path to the file represented by 'HomePub' - , rtSecring :: FilePath - -- ^ Path to the file represented by 'HomeSec' - , rtGrip :: Maybe String - -- ^ Fingerprint or portion of a fingerprint used - -- to identify the working GnuPG identity used to - -- make signatures. - , rtWorkingKey :: Maybe Packet - -- ^ The master key of the working GnuPG identity. - , rtKeyDB :: KeyDB - -- ^ The common information pool where files spilled - -- their content and from which they received new - -- content. - , rtRingAccess :: Map.Map InputFile Access - -- ^ The 'Access' values used for files of type - -- 'KeyRingFile'. If 'AutoAccess' was specified - -- for a file, this 'Map.Map' will indicate the - -- detected value that was used by the algorithm. - , rtPassphrases :: PacketTranscoder - } + { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' + , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec' + , rtGrip :: Maybe String + -- ^ Fingerprint or portion of a fingerprint used + -- to identify the working GnuPG identity used to + -- make signatures. + , rtWorkingKey :: Maybe Packet -- ^ The master key of the working GnuPG identity. + , rtKeyDB :: KeyDB -- ^ The common information pool where files spilled + -- their content and from which they received new + -- content. + , rtRingAccess :: Map.Map InputFile Access + -- ^ The 'Access' values used for files of type + -- 'KeyRingFile'. If 'AutoAccess' was specified + -- for a file, this 'Map.Map' will indicate the + -- detected value that was used by the algorithm. + , rtPassphrases :: PacketTranscoder + } -- | Roster-entry level actions @@ -140,9 +137,9 @@ data KikiReportAction = type KikiReport = [ (FilePath, KikiReportAction) ] data UserIDRecord = UserIDRecord { - uid_full :: String, - uid_realname :: T.Text, - uid_user :: T.Text, + uid_full :: String, + uid_realname :: T.Text, + uid_user :: T.Text, uid_subdomain :: T.Text, uid_topdomain :: T.Text } @@ -780,6 +777,9 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do +-- TODO: Use fingerprint to narrow candidates. +candidateSignerKeys :: KeyDB -> Packet -> [Packet] +candidateSignerKeys db sig = map keyPacket $ Map.elems db performManipulations :: (PacketDecrypter) @@ -812,8 +812,8 @@ performManipulations doDecrypt rt wk manip = do selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard . (== keykey whosign) . keykey)) vs - keys = map keyPacket $ Map.elems (rtKeyDB rt) - overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) + keys = map keyPacket $ Map.elems (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig + overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig]) vs :: [ ( Packet -- signature , Maybe SignatureOver -- Nothing means non-verified , Packet ) -- key who signed @@ -822,10 +822,11 @@ performManipulations doDecrypt rt wk manip = do x <- maybeToList $ Map.lookup uid (keyUids kd) sig <- map (packet . fst) (fst x) o <- overs sig - k <- keys - let ov = verify (Message [k]) $ o - signatures_over ov - return (sig,Just ov,k) + take 1 $ do -- Stop attempting to verify after the first success. + k <- keys + let ov = verify (Message [k]) $ o + signatures_over ov + return (sig,Just ov,k) additional new_sig = do new_sig <- maybeToList new_sig guard (null $ selfsigs) -- cgit v1.2.3