From cc6775a52107f5425d668a4831f475d05dc113b5 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 13 Jul 2019 17:27:54 -0400 Subject: WIP: encapsulation of KeyDB. --- kiki.cabal | 3 ++- kiki.hs | 1 + lib/KeyDB.hs | 58 +++++++++++++++++++++++++++++++++++++++++++++++ lib/KeyRing.hs | 1 + lib/KeyRing/BuildKeyDB.hs | 1 + lib/KeyRing/Types.hs | 13 ++++++++--- lib/Kiki.hs | 1 + lib/Transforms.hs | 47 +++++++++----------------------------- 8 files changed, 85 insertions(+), 40 deletions(-) create mode 100644 lib/KeyDB.hs diff --git a/kiki.cabal b/kiki.cabal index da5e0c7..dc3e1fd 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -75,7 +75,8 @@ library FunctorToMaybe, GnuPGAgent, ByteStringUtil, - IntMapClass + IntMapClass, + KeyDB other-modules: TimeUtil, ControlMaybe, Compat, diff --git a/kiki.hs b/kiki.hs index 762825f..2379e74 100644 --- a/kiki.hs +++ b/kiki.hs @@ -58,6 +58,7 @@ import qualified SSHKey as SSH import qualified DNSKey as DNS import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) import Kiki +import KeyDB import Network.Socket (SockAddr) import FunctorToMaybe diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs new file mode 100644 index 0000000..f5a4357 --- /dev/null +++ b/lib/KeyDB.hs @@ -0,0 +1,58 @@ +module KeyDB + {- + ( TrustMap + , SigAndTrust + , SubKey(..) + , KeyData(..) + , KeyDB + , emptyKeyDB + , keyData + , transmute + ) -} where + +import Control.Monad +import Data.Functor +import qualified Data.Map.Strict as Map +import Data.OpenPGP + +import FunctorToMaybe +import KeyRing.Types + +type TrustMap = Map.Map FilePath Packet +type SigAndTrust = ( MappedPacket + , TrustMap ) -- trust packets +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 KeyDB = KeyDB + { byKeyKey :: Map.Map KeyKey KeyData + } deriving Show + +emptyKeyDB :: KeyDB +emptyKeyDB = KeyDB { byKeyKey = Map.empty } + +keyData :: KeyDB -> [KeyData] +keyData db = Map.elems (byKeyKey db) + + +transmute :: (Monad m, Monad kiki, Traversable kiki) => + ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter + -> (KeyData -> [opcode]) -- ^ instructions + -> KeyDB -- ^ initial state + -> m (kiki (KeyDB, [info])) +transmute perform update db = do + let performAll kd = foldM (\kkd op -> join <$> mapM (`perform` op) kkd) + (pure (kd,[])) + (update kd) + r <- sequenceA <$> mapM performAll (byKeyKey db) + return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } + , concatMap snd $ Map.elems bkk ) diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 3b9afd7..1d52dd1 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -89,6 +89,7 @@ import KeyRing.BuildKeyDB (Hostnames(..), usageFromFilter) import KeyRing.Types +import KeyDB import PacketTranscoder import Transforms diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 943578f..8af8198 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -72,6 +72,7 @@ import ScanningParser import TimeUtil import KeyRing.Types +import KeyDB import Transforms import PacketTranscoder import GnuPGAgent diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs index 0797dab..3c1f0a5 100644 --- a/lib/KeyRing/Types.hs +++ b/lib/KeyRing/Types.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} module KeyRing.Types where import Data.Char (isLower,toLower) +import Data.Functor import Data.List (groupBy,find) import Data.Map as Map (Map) import qualified Data.Map as Map @@ -272,7 +274,7 @@ data KikiCondition a = KikiSuccess a | NoWorkingKey | AgentConnectionFailure | OperationCanceled - deriving ( Functor, Show ) + deriving ( Functor, Foldable, Traversable, Show ) instance FunctorToMaybe KikiCondition where functorToMaybe (KikiSuccess a) = Just a @@ -287,6 +289,11 @@ instance Applicative KikiCondition where Left err -> err Left err -> err +instance Monad KikiCondition where + return = pure + KikiSuccess a >>= f = f a + kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f") + uncamel :: String -> String uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args where diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 579640a..e5c4eb4 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -48,6 +48,7 @@ import CommandLine import DotLock import GnuPGAgent (Query (..)) import KeyRing hiding (pemFromPacket) +import KeyDB withAgent :: [PassphraseSpec] -> [PassphraseSpec] withAgent [] = [PassphraseAgent] diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 3e13b1a..0a3a9a6 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -9,12 +9,14 @@ import Control.Applicative import Control.Arrow import Control.Monad import Data.Char +import Data.Functor import Data.List import Data.Maybe import Data.Ord import Data.OpenPGP import Data.OpenPGP.Util import Data.Word +import KeyDB import KeyRing.Types import FunctorToMaybe import GnuPGAgent ( key_nbits ) @@ -38,27 +40,6 @@ import qualified Data.Text as T ( Text, unpack, pack, import Data.Text.Encoding ( encodeUtf8 ) import Data.Bits ((.|.), (.&.), Bits) -type TrustMap = Map.Map FilePath Packet -type SigAndTrust = ( MappedPacket - , TrustMap ) -- trust packets -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 KeyDB = KeyDB - { byKeyKey :: Map.Map KeyKey KeyData - } deriving Show - -emptyKeyDB :: KeyDB -emptyKeyDB = KeyDB { byKeyKey = Map.empty } - data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' @@ -765,7 +746,7 @@ 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 (byKeyKey db) +candidateSignerKeys db sig = map keyPacket $ keyData db performManipulations :: (PacketDecrypter) @@ -775,18 +756,14 @@ performManipulations :: -> IO (KikiCondition (KeyRingRuntime,KikiReport)) performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt - performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd - r <- Traversable.mapM performAll (byKeyKey db) - try (sequenceA r) $ \db -> do - return $ KikiSuccess ( rt { rtKeyDB = (rtKeyDB rt) { byKeyKey = fmap fst db } } - , concatMap snd $ Map.elems db) + r <- transmute perform (manip rt) db + return $ r <&> \(db,rs) -> (rt { rtKeyDB = db }, rs) where - perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) - perform kd (InducerSignature uid subpaks) = do - try kd $ \(kd,report) -> do + perform :: (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) + perform (kd,report) (InducerSignature uid subpaks) = do flip (maybe $ return NoWorkingKey) wk $ \wk' -> do wkun' <- doDecrypt wk' - try wkun' $ \wkun -> do + try wkun' $ \wkun -> do let flgs = if keykey (keyPacket kd) == keykey wkun then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) else [] @@ -799,7 +776,7 @@ 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 (byKeyKey $ rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig + keys = map keyPacket $ keyData (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 @@ -825,8 +802,7 @@ performManipulations doDecrypt rt wk manip = do -- XXX: Shouldn't this signature generation show up in the KikiReport ? return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) - perform kd (SubKeyDeletion topk subk) = do - try kd $ \(kd,report) -> do + perform (kd,report) (SubKeyDeletion topk subk) = do let kk = keykey $ packet $ keyMappedPacket kd kd' | kk /= topk = kd | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } @@ -839,8 +815,7 @@ performManipulations doDecrypt rt wk manip = do return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) - perform kd (SubKeyRenaming srctag dsttag) = do - try kd $ \(kd,report) -> do + perform (kd,report) (SubKeyRenaming srctag dsttag) = do flip (maybe $ return NoWorkingKey) wk $ \wk' -> do subkeys' <- traverse (freshenOne wk') (keySubKeys kd) let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport)) -- cgit v1.2.3