From 8da740316c13f4c789c8d3fee4f68a1894599a2d Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 20 Apr 2014 15:18:07 -0400 Subject: performManipulations returns KeyRingRuntime rather than just the KeyDB --- KeyRing.hs | 112 +++++++++++++++++++++++++++++-------------------------------- 1 file changed, 54 insertions(+), 58 deletions(-) (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs index b0e24de..5149da4 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -99,7 +99,7 @@ data FileType = KeyRingFile (Maybe PassWordFile) -- | 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 +-- an action and not just the access level of an -- object. data RefType = ConstRef -- ^ merge into database but do not update @@ -149,7 +149,7 @@ noManip _ _ = [] data KeyRingOperation = KeyRingOperation { kFiles :: Map.Map InputFile (RefType,FileType) , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) - -- ^ + -- ^ -- Indicates what pgp master keys get written to which keyring files. -- Just True = import public key -- Just False = import secret key @@ -488,7 +488,7 @@ keyFlags0 wkun uidsigs = concat isfeatures _ = False -matchSpec (KeyGrip grip) (_,KeyData p _ _ _) +matchSpec (KeyGrip grip) (_,KeyData p _ _ _) | matchpr grip (packet p)==grip = True | otherwise = False @@ -608,7 +608,7 @@ selectAll wantPublic (spec,mtag) db = do y <- take 1 ys case mtag of Nothing -> return (y,Nothing) - Just tag -> + Just tag -> let search ys1 = do let zs = snd $ seek_key (KeyTag y tag) ys1 z <- take 1 zs @@ -664,12 +664,12 @@ cachedContents secring pubring fd = do trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs get ref fd = do - pw <- readIORef ref + pw <- readIORef ref flip (flip maybe return) pw $ do pw <- fmap trimCR $ getContents fd writeIORef ref (Just pw) return pw - + getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents getContents inp = do let fname = resolveInputFile secring pubring inp @@ -677,7 +677,7 @@ cachedContents secring pubring fd = do importPEMKey doDecrypt db' tup = do try db' $ \(db',report0) -> do - r <- doImport doDecrypt + r <- doImport doDecrypt db' tup try r $ \(db'',report) -> do @@ -688,7 +688,7 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket) ,[(FilePath,KikiReportAction)])) buildKeyDB doDecrypt secring pubring grip0 keyring = do - let + let files isring = do (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) @@ -701,7 +701,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do - r <- doImportG doDecrypt + r <- doImportG doDecrypt db' (fmap keykey $ maybeToList wk) tag @@ -715,7 +715,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do ms <- mapM readp (files isring) let grip = grip0 `mplus` (fingerprint <$> fstkey) where - fstkey = listToMaybe $ mapMaybe isSecringKey ms + fstkey = listToMaybe $ mapMaybe isSecringKey ms where isSecringKey (fn,Message ps) | fn==secring = listToMaybe ps isSecringKey _ = Nothing @@ -774,7 +774,7 @@ readKeyFromFile False "PEM" fname = do -- warn $ fname ++ ": reading ..." -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. - timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ + timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let dta = extractPEM "RSA PRIVATE KEY" input @@ -855,7 +855,7 @@ doImportG doDecrypt db m0 tag fname key = do ( (False,) . addOrigin ) (Map.lookup subkk subs) where - addOrigin (SubKey mp sigs) = + addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) @@ -892,7 +892,7 @@ doImportG doDecrypt db m0 tag fname key = do $ \sig -> do let om = Map.singleton fname (origin sig (-1)) trust = Map.empty - return $ KikiSuccess + return $ KikiSuccess ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} , trust)],om) uids , [] ) @@ -990,7 +990,7 @@ ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f showPacket :: Packet -> String -showPacket p | isKey p = (if is_subkey p +showPacket p | isKey p = (if is_subkey p then showPacket0 p else ifSecret p "----Secret-----" "----Public-----") ++ " "++show (key_algorithm p)++" "++fingerprint p @@ -1059,7 +1059,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = do let (towrites,report) = (\f -> foldl f ([],[]) s) $ \(ws,report) ((f,mutable),(new_packets,x)) -> if mutable - then + then let rs = flip map new_packets $ \c -> (f, NewPacket $ showPacket (packet c)) in (ws++[(f,x)],report++rs) @@ -1090,7 +1090,7 @@ subkeysForExport subspec (KeyData key _ _ subkeys) = do doSearch key tag (SubKey sub_mp sigtrusts) = let (_,v,_) = findTag tag (packet key) - (packet sub_mp) + (packet sub_mp) sigtrusts in fmap fst v==Just True @@ -1119,11 +1119,11 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do -- Ideally, it would be better to compute (inverse q) mod p -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg -- (package constructive-algebra) - coefficient <- lookup 'u' $ key pkt + coefficient <- lookup 'u' $ key pkt let dmodp1 = MPI $ d `mod` (p - 1) dmodqminus1 = MPI $ d `mod` (q - 1) - return $ RSAPrivateKey + return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = MPI d @@ -1222,8 +1222,8 @@ performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyRingOperation -> KeyRingRuntime - -> Maybe MappedPacket - -> IO (KikiCondition (KeyDB,[(FilePath,KikiReportAction)])) + -> Maybe MappedPacket + -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) performManipulations doDecrypt operation rt wk = do let db = rtKeyDB rt db <- let perform kd (InducerSignature uid subpaks) = do @@ -1241,8 +1241,8 @@ performManipulations doDecrypt operation rt wk = do , om `Map.union` snd x ) om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid toMappedPacket om p = (mappedPacket "" p) {locations=om} - selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard - . (== keykey whosign) + 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]) @@ -1250,21 +1250,21 @@ performManipulations doDecrypt operation rt wk = do , Maybe SignatureOver -- Nothing means non-verified , Packet ) -- key who signed ] - vs = do + vs = do x <- maybeToList $ Map.lookup uid (rentryUids 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) + o <- overs sig + 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) signatures_over new_sig return kd { rentryUids = Map.adjust f uid (rentryUids kd) } in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db - return $ KikiSuccess (db,[]) + return $ KikiSuccess (rt { rtKeyDB = db },[]) initializeMissingPEMFiles :: @@ -1278,7 +1278,7 @@ initializeMissingPEMFiles :: , Maybe Initializer)]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation secring pubring grip decrypt db = do - nonexistents <- + nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (kFiles operation) f <- resolveInputFile secring pubring f @@ -1306,7 +1306,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do ifnotnull (x:xs) f g = f x ifnotnull _ f g = g - + ifnotnull ambiguous ambiguity $ do -- create nonexistent files via external commands @@ -1378,6 +1378,7 @@ runKeyRing operation = do secring pubring grip decrypt db + try' externals_ret $ \((db,exports),report_externals) -> do let rt = KeyRingRuntime { rtPubring = pubring @@ -1387,24 +1388,19 @@ runKeyRing operation = do , rtKeyDB = db } - try' externals_ret $ \((db,exports),report_externals) -> do - - - - r <- performManipulations decrypt + r <- performManipulations decrypt operation rt wk - try' r $ \(db,report_manips) -> do - rt <- return $ rt { rtKeyDB = db } + try' r $ \(rt,report_manips) -> do - r <- writeWalletKeys operation db (fmap packet wk) + r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do r <- writeRingKeys operation rt -- db wk secring pubring try' r $ \report_rings -> do - r <- writePEMKeys decrypt db exports + r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do return $ KikiResult (KikiSuccess rt) @@ -1452,7 +1448,7 @@ getHomeDir protohome = do let homegnupg = (++('/':(appdir home))) <$> homed let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val - + -- TODO: rename this to getGrip getWorkingKey homedir = do let o = Nothing @@ -1516,10 +1512,10 @@ slurpWIPKeys stamp "" = ([],[]) slurpWIPKeys stamp cs = let (b58,xs) = Char8.span (\x -> elem x base58chars) cs mb = decode_btc_key stamp (Char8.unpack b58) - in if L.null b58 + in if L.null b58 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs (ks,js) = slurpWIPKeys stamp xs' - in (ks,ys:js) + in (ks,ys:js) else let (ks,js) = slurpWIPKeys stamp xs in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb @@ -1548,7 +1544,7 @@ decode_btc_key timestamp str = do ,"y ="++show y ,"y' ="++show y' ,"y''="++show y'']) -} - SecretKeyPacket + SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = ECDSA @@ -1579,12 +1575,12 @@ rsaKeyFromPacket p@(SecretKeyPacket {}) = do rsaKeyFromPacket _ = Nothing -readPacketsFromWallet :: +readPacketsFromWallet :: Maybe Packet - -> FilePath + -> FilePath -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] readPacketsFromWallet wk fname = do - timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ + timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let (ks,_) = slurpWIPKeys timestamp input @@ -1673,7 +1669,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do let grip = fingerprint wk addOrigin new_sig = do flip (maybe $ return FailedToMakeSignature) - (new_sig >>= listToMaybe . signatures_over) + (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do let mp' = mappedPacket fname new_sig return $ KikiSuccess (mp', Map.empty) @@ -1797,7 +1793,7 @@ origin p n = OriginFlags ispub n SecretKeyPacket {} -> False _ -> True -mappedPacket filename p = MappedPacket +mappedPacket filename p = MappedPacket { packet = p , usage_tag = Nothing , locations = Map.singleton filename (origin p (-1)) @@ -1860,10 +1856,10 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) where -- NOTE: -- if a keyring file has both a public key packet and a secret key packet - -- for the same key, then only one of them will survive, which ever is + -- for the same key, then only one of them will survive, which ever is -- later in the file. - -- - -- This is due to the use of statements like + -- + -- This is due to the use of statements like -- (Map.insert filename (origin p n) (locations key)) -- update v | isKey p && not (is_subkey p) @@ -1961,7 +1957,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) "Unable to merge subkey signature: "++(words (show sig) >>= take 1) unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] -unsig fname isPublic (sig,trustmap) = +unsig fname isPublic (sig,trustmap) = [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) where f n _ = n==fname -- && trace ("fname=n="++show n) True @@ -1990,7 +1986,7 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] flattenTop fname ispub (KeyData key sigs uids subkeys) = - unk ispub key : + unk ispub key : ( flattenAllUids fname ispub uids ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) @@ -2006,11 +2002,11 @@ flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = +flattenUid fname ispub (str,(sigs,om)) = (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - + {- data Kiki a = SinglePass (KeyRingOperation -> KeyRingAction a) @@ -2031,14 +2027,14 @@ instance Functor Kiki where fmap f k = fmapWithRT (const f) k instance Monad Kiki where return x = SinglePass (const $ KeyRingAction x) - + k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k where (.:) = (.) . (.) eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a eval rt (SinglePass f) kd = case f kd of KeyRingAction v -> v - RunTimeAction g -> g rt + RunTimeAction g -> g rt eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd eval' :: Kiki (KeyRingOperation -> a) -> Kiki a -- cgit v1.2.3