From f3c14cb7693bab7a4dee8dae390088feee5a92b0 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 29 Apr 2014 19:10:01 -0400 Subject: combined secring/pubring paths into an InputFileContext structure. --- KeyRing.hs | 105 ++++++++++++++++++++++++++++++++----------------------------- 1 file changed, 56 insertions(+), 49 deletions(-) (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs index d057cd4..85f2944 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -247,22 +247,22 @@ data KeyRingOperation = KeyRingOperation , homeSpec :: Maybe String } -resolveInputFile :: FilePath -> FilePath -> InputFile -> [FilePath] -resolveInputFile secring pubring = resolve +resolveInputFile :: InputFileContext -> InputFile -> [FilePath] +resolveInputFile ctx = resolve where - resolve HomeSec = return secring - resolve HomePub = return pubring + resolve HomeSec = return (homesecPath ctx) + resolve HomePub = return (homepubPath ctx) resolve (ArgFile f) = return f resolve _ = [] filesToLock :: - KeyRingOperation -> FilePath -> FilePath -> [FilePath] -filesToLock k secring pubring = do + KeyRingOperation -> InputFileContext -> [FilePath] +filesToLock k ctx = do (f,stream) <- Map.toList (kFiles k) case fill stream of KF_None -> [] - _ -> resolveInputFile secring pubring f + _ -> resolveInputFile ctx f -- kret :: a -> KeyRingOperation a @@ -828,9 +828,20 @@ seek_key (KeyUidMatch pat) ps uidStr _ = "" +data InputFileContext = InputFileContext + { homesecPath :: FilePath + , homepubPath :: FilePath + } + + +readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString +readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents +readInputFileS ctx inp = do + let fname = resolveInputFile ctx inp + fmap S.concat $ mapM S.readFile fname -cachedContents :: FilePath -> FilePath -> InputFile -> IO (IO S.ByteString) -cachedContents secring pubring fd = do +cachedContents :: InputFileContext -> InputFile -> IO (IO S.ByteString) +cachedContents ctx fd = do ref <- newIORef Nothing return $ get ref fd where @@ -839,15 +850,10 @@ cachedContents secring pubring fd = do get ref fd = do pw <- readIORef ref flip (flip maybe return) pw $ do - pw <- fmap trimCR $ getContents fd + pw <- fmap trimCR $ readInputFileS ctx fd writeIORef ref (Just pw) return pw - getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents - getContents inp = do - let fname = resolveInputFile secring pubring inp - fmap S.concat $ mapM S.readFile fname - importPEMKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition @@ -863,9 +869,7 @@ importPEMKey doDecrypt db' tup = do return $ KikiSuccess (db'', report0 ++ report) -mergeHostFiles :: KeyRingOperation -> KeyDB - -> FilePath - -> FilePath +mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext -> IO (KikiCondition ( ( Map.Map [Char8.ByteString] KeyData @@ -875,14 +879,14 @@ mergeHostFiles :: KeyRingOperation -> KeyDB , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] , [SockAddr])) , [(FilePath,KikiReportAction)])) -mergeHostFiles krd db secring pubring = do +mergeHostFiles krd db ctx = do let hns = files ishosts ishosts Hosts = True ishosts _ = False files istyp = do (f,stream) <- Map.toList (kFiles krd) guard (istyp $ typ stream) - resolveInputFile secring pubring f + resolveInputFile ctx f hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns @@ -924,16 +928,14 @@ mergeHostFiles krd db secring pubring = do return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) writeHostsFiles - :: KeyRingOperation - -> [Char] - -> [Char] + :: KeyRingOperation -> InputFileContext -> ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, (t1, [Char8.ByteString]))], [SockAddr]) -> IO [(FilePath, KikiReportAction)] -writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do +writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do let hns = files isMutableHosts isMutableHosts (fill -> KF_None) = False isMutableHosts (typ -> Hosts) = True @@ -941,7 +943,7 @@ writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names files istyp = do (f,stream) <- Map.toList (kFiles krd) guard (istyp stream) - resolveInputFile secring pubring f + resolveInputFile ctx f -- 3. add hostnames from gpg for addresses not in U let u = foldl' f u1 ans @@ -964,7 +966,7 @@ writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) - -> FilePath -> FilePath -> Maybe String -> KeyRingOperation + -> InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiCondition ((KeyDB ,Maybe String ,Maybe MappedPacket @@ -976,17 +978,17 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) ,Map.Map FilePath Access ) ,[(FilePath,KikiReportAction)])) -buildKeyDB doDecrypt secring pubring grip0 keyring = do +buildKeyDB doDecrypt ctx grip0 keyring = do let files isring = do (f,stream) <- Map.toList (kFiles keyring) guard (isring $ typ stream) - resolveInputFile secring pubring f + resolveInputFile ctx f filesAccs isring = do (f,stream) <- Map.toList (kFiles keyring) guard (isring $ typ stream) - n <- resolveInputFile secring pubring f + n <- resolveInputFile ctx f return (n, access stream) readp (n,acc) = fmap readp0 $ readPacketsFromFile n @@ -1020,8 +1022,8 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do where fstkey = listToMaybe $ mapMaybe isSecringKey ms where isSecringKey ((fn,_),Message ps) - | fn==secring = listToMaybe ps - isSecringKey _ = Nothing + | fn==homesecPath ctx = listToMaybe ps + isSecringKey _ = Nothing db_rings = foldl' (\db ((fname,_),ps) -> merge db fname ps) Map.empty ms wk = listToMaybe $ do @@ -1049,7 +1051,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do let pems = do (n,stream) <- Map.toList $ kFiles keyring grip <- maybeToList grip - n <- resolveInputFile secring pubring n + n <- resolveInputFile ctx n guard $ spillable stream && ispem (typ stream) let us = mapMaybe usageFromFilter [fill stream,spill stream] usage <- take 1 us @@ -1063,7 +1065,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do - r <- mergeHostFiles keyring db secring pubring + r <- mergeHostFiles keyring db ctx try r $ \((db,hs),reportHosts) -> do return $ KikiSuccess ( (db, grip, mwk, hs, accs), reportWallets ++ reportPEMs ) @@ -1289,7 +1291,7 @@ writeWalletKeys krd db wk = do files pred = do (f,stream) <- Map.toList (kFiles krd) guard (pred stream) - resolveInputFile "" "" f + resolveInputFile (InputFileContext "" "") f let writeWallet report n = do let cs' = do (nw,mp) <- cs @@ -1370,11 +1372,12 @@ writeRingKeys krd rt {- db wk secring pubring -} = do db = rtKeyDB rt secring = rtSecring rt pubring = rtPubring rt + ctx = InputFileContext secring pubring let s = do (f,f0,stream) <- do (f0,stream) <- Map.toList (kFiles krd) guard (isring $ typ stream) - f <- resolveInputFile secring pubring f0 + f <- resolveInputFile ctx f0 return (f,f0,stream) let x = do let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool @@ -1533,15 +1536,15 @@ writePEMKeys doDecrypt db exports = do try pun $ \pun -> do return $ KikiSuccess (fname,pun) -makeMemoizingDecrypter :: KeyRingOperation -> FilePath -> FilePath +makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation secring pubring = do +makeMemoizingDecrypter operation ctx = do pws <- -- 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 . typ) - (Map.mapKeys (head . resolveInputFile secring pubring) + Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) + (Map.mapKeys (head . resolveInputFile ctx) $ Map.filter (isJust . pwfile . typ) $ kFiles operation) unkeysRef <- newIORef Map.empty return $ doDecrypt unkeysRef pws @@ -1630,7 +1633,7 @@ performManipulations doDecrypt operation rt wk = do initializeMissingPEMFiles :: KeyRingOperation - -> FilePath -> FilePath -> Maybe String + -> InputFileContext -> Maybe String -> (MappedPacket -> IO (KikiCondition Packet)) -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath @@ -1638,11 +1641,11 @@ initializeMissingPEMFiles :: , [MappedPacket] , Maybe Initializer)]) , [(FilePath,KikiReportAction)])) -initializeMissingPEMFiles operation secring pubring grip decrypt db = do +initializeMissingPEMFiles operation ctx grip decrypt db = do nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (kFiles operation) - f <- resolveInputFile secring pubring f + f <- resolveInputFile ctx f return (f,t) let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do @@ -1715,7 +1718,10 @@ runKeyRing operation = do Left e -> return $ KikiResult e [] Right wkun -> body wkun try' homedir $ \(homedir,secring,pubring,grip0) -> do - let tolocks = filesToLock operation secring pubring + let ctx = InputFileContext secring pubring + tolocks = filesToLock operation ctx + secring <- return Nothing + pubring <- return Nothing lks <- forM tolocks $ \f -> do lk <- dotlock_create f 0 v <- flip (maybe $ return Nothing) lk $ \lk -> do @@ -1732,21 +1738,22 @@ runKeyRing operation = do -- memoizing decrypter -- TODO: Unspilled keyrings should be usable for decrypting -- and signing. - decrypt <- makeMemoizingDecrypter operation secring pubring + decrypt <- makeMemoizingDecrypter operation ctx -- merge all keyrings, PEM files, and wallets - bresult <- buildKeyDB decrypt secring pubring grip0 operation + bresult <- buildKeyDB decrypt ctx grip0 operation try' bresult $ \((db,grip,wk,hs,accs),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation - secring pubring grip + ctx + grip decrypt db try' externals_ret $ \((db,exports),report_externals) -> do let rt = KeyRingRuntime - { rtPubring = pubring - , rtSecring = secring + { rtPubring = homepubPath ctx + , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db @@ -1768,7 +1775,7 @@ runKeyRing operation = do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do - import_hosts <- writeHostsFiles operation secring pubring hs + import_hosts <- writeHostsFiles operation ctx hs return $ KikiResult (KikiSuccess rt) $ concat [ report_imports -- cgit v1.2.3