WIP: verify command to verify clear-sign PGP signatures.

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)