From 0a9b3df4782d26b2bd542d5234545b64b04099b0 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sun, 20 Apr 2014 01:14:51 -0400 Subject: prepare for autosign support & nicer names --- KeyRing.hs | 108 +++++++++++++++++++++++++++++++++++-------------------------- kiki.hs | 2 +- 2 files changed, 63 insertions(+), 47 deletions(-) diff --git a/KeyRing.hs b/KeyRing.hs index b6f16ca..0522fdb 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -96,7 +96,18 @@ data FileType = KeyRingFile (Maybe PassWordFile) | PEMFile UsageTag | WalletFile -- (Maybe UsageTag) -data RefType = ConstRef | MutableRef (Maybe Initializer) +-- | RefType is perhaps not a good name for this... +-- It is sort of like a read/write flag, although +-- semantically, it is indicating the intention of +-- an action and not just the access level of an +-- object. +data RefType = ConstRef + -- ^ merge into database but do not update + | MutableRef (Maybe Initializer) + -- ^ sync into database + -- update dabase and also update file + -- Initializer is a shell command that creates + -- the file; eg, ssh-keygen isMutable (MutableRef {}) = True isMutable _ = False @@ -127,22 +138,15 @@ data KeyRingRuntime = KeyRingRuntime data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a) -data SubKeyKey = SubKeyKey KeyKey | UIDKey String - deriving (Eq,Ord) - -data PacketUpdate = InducerSignature [SignatureSubpacket] +-- | TODO: Packet Update should have deletiong action +-- and any other kind of roster entry level +-- action. +data PacketUpdate = InducerSignature String [SignatureSubpacket] -data KeyRingAddress a = KeyRingAddress - { topkeyAddress :: KeyKey - , subkeyAddress :: SubKeyKey - , keyringAddressed :: a - } - deriving Functor +noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate] +noManip _ _ = [] -noManip :: KeyRingRuntime -> [KeyRingAddress PacketUpdate] -noManip = const [] - -data KeyRingData = KeyRingData +data KeyRingOperation = KeyRingOperation { kFiles :: Map.Map InputFile (RefType,FileType) , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) -- ^ @@ -153,7 +157,7 @@ data KeyRingData = KeyRingData -- Note that subkeys will always be imported if their owner key is -- already in the ring. -- TODO: Even if their signatures are bad? - , kManip :: KeyRingRuntime -> [KeyRingAddress PacketUpdate] + , kManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]--[KeyRingAddress PacketUpdate] , homeSpec :: Maybe String } @@ -173,8 +177,8 @@ filesToLock k secring pubring = do MutableRef {} -> resolveInputFile secring pubring f --- kret :: a -> KeyRingData a --- kret x = KeyRingData Map.empty Nothing (KeyRingAction x) +-- kret :: a -> KeyRingOperation a +-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show @@ -682,7 +686,7 @@ importPEMKey doDecrypt db' tup = do return $ KikiSuccess (db'', report0 ++ report) buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) - -> FilePath -> FilePath -> Maybe String -> KeyRingData + -> FilePath -> FilePath -> Maybe String -> KeyRingOperation -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)])) buildKeyDB doDecrypt secring pubring grip0 keyring = do let @@ -954,7 +958,7 @@ walletImportFormat idbyte k = secret_base58_foo (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) seckey = S.cons idbyte bigendian -writeWalletKeys :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) +writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeWalletKeys krd db wk = do let cs = db `coinKeysOwnedBy` wk -- export wallet keys @@ -1019,7 +1023,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk guard $ matchSpec (KeyGrip fp) elm return $ keyPacket (snd elm) -writeRingKeys :: KeyRingData -> KeyRingRuntime +writeRingKeys :: KeyRingOperation -> KeyRingRuntime {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath @@ -1200,13 +1204,15 @@ doDecrypt unkeysRef pws mp = do (return . KikiSuccess) $ Map.lookup kk unkeys +{- interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" interpretManip kd manip = return kd +-} -runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime) -runKeyRing keyring = do - homedir <- getHomeDir (homeSpec keyring) +runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) +runKeyRing operation = do + homedir <- getHomeDir (homeSpec operation) let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) -- FIXME: try' should probably accept a list of KikiReportActions. -- This would be useful for reporting on disk writes that have already @@ -1216,7 +1222,7 @@ runKeyRing keyring = do Left e -> return $ KikiResult e [] Right wkun -> body wkun try' homedir $ \(homedir,secring,pubring,grip0) -> do - let tolocks = filesToLock keyring secring pubring + let tolocks = filesToLock operation secring pubring lks <- forM tolocks $ \f -> do lk <- dotlock_create f 0 v <- flip (maybe $ return Nothing) lk $ \lk -> do @@ -1231,23 +1237,23 @@ runKeyRing keyring = do else do pws <- - -- TODO: head will throw an exception if a File Descriptor keyring + -- TODO: head will throw an exception if a File Descriptor operation -- file is present. We probably should change OriginMap to use InputFile -- instead of FilePath. Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . snd) (Map.mapKeys (head . resolveInputFile secring pubring) - $ Map.filter (isJust . pwfile . snd) $ kFiles keyring) + $ Map.filter (isJust . pwfile . snd) $ kFiles operation) unkeysRef <- newIORef Map.empty -- merge all keyrings, PEM files, and wallets - bresult <- buildKeyDB (doDecrypt unkeysRef pws) secring pubring grip0 keyring + bresult <- buildKeyDB (doDecrypt unkeysRef pws) secring pubring grip0 operation try' bresult $ \((db,grip,wk),report_imports) -> do nonexistents <- filterM (fmap not . doesFileExist . fst) - $ do (f,t) <- Map.toList (kFiles keyring) + $ do (f,t) <- Map.toList (kFiles operation) f <- resolveInputFile secring pubring f return (f,t) @@ -1314,7 +1320,11 @@ runKeyRing keyring = do try' externals_ret $ \(db,report_externals) -> do - let manips0 = kManip keyring rt + db <- let perform kd (InducerSignature uid subpaks) = error "todo" + in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db + +{- + let manips0 = kManip operation rt manips :: Map.Map KeyKey [KeyRingAddress PacketUpdate] manips = Map.fromList $ do ms <- groupBy ((==EQ) .: comparing topkeyAddress) @@ -1329,11 +1339,12 @@ runKeyRing keyring = do foldM interpretManip kd ms db' <- Traversable.mapM doManips db +-} - r <- writeWalletKeys keyring db wk + r <- writeWalletKeys operation db wk try' r $ \report_wallets -> do - r <- writeRingKeys keyring rt -- db wk secring pubring + r <- writeRingKeys operation rt -- db wk secring pubring try' r $ \report_rings -> do r <- writePEMKeys (doDecrypt unkeysRef pws) db exports @@ -1708,6 +1719,11 @@ type SigAndTrust = ( MappedPacket type KeyKey = [ByteString] data SubKey = SubKey MappedPacket [SigAndTrust] + +-- | This is a roster entry, it's poorly named +-- but we are keeping the name around until +-- we're sure we wont be cutting and pasting +-- code with master any more data KeyData = KeyData MappedPacket -- main key [SigAndTrust] -- sigs on main key (Map.Map String ([SigAndTrust],OriginMap)) -- uids @@ -1938,8 +1954,8 @@ flattenUid fname ispub (str,(sigs,om)) = {- data Kiki a = - SinglePass (KeyRingData -> KeyRingAction a) - | forall b. MultiPass (KeyRingData -> KeyRingAction b) + SinglePass (KeyRingOperation -> KeyRingAction a) + | forall b. MultiPass (KeyRingOperation -> KeyRingAction b) (Kiki (b -> a)) fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b @@ -1960,13 +1976,13 @@ instance Monad Kiki where k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k where (.:) = (.) . (.) -eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a +eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a eval rt (SinglePass f) kd = case f kd of KeyRingAction v -> v RunTimeAction g -> g rt eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd -eval' :: Kiki (KeyRingData -> a) -> Kiki a +eval' :: Kiki (KeyRingOperation -> a) -> Kiki a eval' k@(SinglePass pass) = SinglePass pass' where pass' kd = case pass kd of @@ -1981,9 +1997,9 @@ eval' k@(MultiPass p kk) = MultiPass p kk' {- -fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v})) +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v})) = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } -fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f})) +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f})) = SinglePass $ d { kAction = RunTimeAction f' } where f' rt = g rt (f rt) fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) @@ -1992,10 +2008,10 @@ fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) data Kiki a = - SinglePass { passInfo :: KeyRingData + SinglePass { passInfo :: KeyRingOperation , rtAction :: KeyRingAction a } | forall b. - MultiPass { passInfo :: KeyRingData + MultiPass { passInfo :: KeyRingOperation , passAction :: KeyRingAction b , nextPass :: Kiki (b -> a) } @@ -2093,8 +2109,8 @@ instance Functor Kiki where -} {- -data Kiki a = SinglePass (KeyRingData a) - | forall b. MultiPass (KeyRingData b) (Kiki (b -> a)) +data Kiki a = SinglePass (KeyRingOperation a) + | forall b. MultiPass (KeyRingOperation b) (Kiki (b -> a)) instance Functor Kiki where fmap f (SinglePass d) = SinglePass $ case kAction d of @@ -2103,14 +2119,14 @@ instance Functor Kiki where fmap f (MultiPass p k)= MultiPass p (fmap (f .) k) eval :: KeyRingRuntime -> Kiki a -> a -eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v -eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt +eval rt (SinglePass (KeyRingOperation { kAction = KeyRingAction v})) = v +eval rt (SinglePass (KeyRingOperation { kAction = RunTimeAction f})) = f rt eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p) fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b -fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v})) +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v})) = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } -fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f})) +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f})) = SinglePass $ d { kAction = RunTimeAction f' } where f' rt = g rt (f rt) fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) diff --git a/kiki.hs b/kiki.hs index 2968067..098ed98 100644 --- a/kiki.hs +++ b/kiki.hs @@ -1342,7 +1342,7 @@ main = do return $ \rt kd -> Just () importifauth_f = do Map.lookup "--import-if-authentic" margs return guardAuthentic - kikiOp = KeyRingData + kikiOp = KeyRingOperation { kFiles = Map.fromList $ [ ( HomeSec, (MutableRef Nothing, KeyRingFile passfd) ) , ( HomePub, (MutableRef Nothing, KeyRingFile Nothing) ) -- cgit v1.2.3