From bc0458ee540da677a04eeddf9b4e0fe8a8991e93 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 1 Jul 2019 02:37:20 -0400 Subject: Attempted to merge 0bc53f99cfd70f3a18802604d7ef3174d004db4c. I left lib/Kiki.hs out for later. --- lib/KeyRing/BuildKeyDB.hs | 1402 ++++++++++----------------------------------- lib/KeyRing/Types.hs | 394 +++++++++++++ 2 files changed, 691 insertions(+), 1105 deletions(-) create mode 100644 lib/KeyRing/Types.hs (limited to 'lib/KeyRing') diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 1c2a5aa..6de217b 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -2,13 +2,21 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing.BuildKeyDB where -import qualified Codec.Binary.Base32 as Base32 -import qualified Codec.Binary.Base64 as Base64 + +#if defined(VERSION_memory) +import Data.ByteArray.Encoding +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString as S +#elif defined(VERSION_dataenc) +import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base64 as Base64 +#endif import Control.Applicative (liftA2) import Control.Arrow (first, second) import Control.Exception (catch) @@ -17,7 +25,9 @@ import ControlMaybe (handleIO_) import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1, encodeASN1) -import Data.ASN1.Types (fromASN1, toASN1) +import Data.ASN1.Types (ASN1 (BitString, End, IntVal, Null, OID, Start), + ASN1ConstructionType (Sequence), ASN1Object, + fromASN1, toASN1) import Data.Binary import Data.Bits ((.&.), (.|.)) import Data.Bits (Bits) @@ -101,6 +111,9 @@ import ScanningParser import TimeUtil import KeyRing.Types +import Transforms +import PacketTranscoder +import GnuPGAgent -- | buildKeyDB -- @@ -116,16 +129,15 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access - ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) + ,{- doDecrypt -} PacketTranscoder ,{- unspilled -} Map.Map InputFile Message ) ,{- report_imports -} [(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do - let - files istyp = do + let files istyp = do (f,stream) <- Map.toList (opFiles keyring) guard (istyp $ typ stream) - resolveInputFile ctx f + return f -- resolveInputFile ctx f ringMap0 = Map.filter (isring . typ) $ opFiles keyring (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 @@ -145,10 +157,10 @@ buildKeyDB ctx grip0 keyring = do _ -> AutoAccess acc -> acc - readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) + readw wk n = fmap (n,) (readPacketsFromWallet wk n) -- KeyRings (todo: KikiCondition reporting?) - (spilled,mwk,grip,accs,keys,unspilled) <- do + (spilled,mwk,grip,accs,keyqs,unspilled) <- do #if MIN_VERSION_containers(0,5,0) ringPackets <- Map.traverseWithKey readp ringMap #else @@ -164,39 +176,25 @@ buildKeyDB ctx grip0 keyring = do -- | spilled -- ring packets with info available for export - -- | unspilled + -- | unspilled -- the rest (spilled,unspilled) = Map.partition (spillable . fst) ringPackets -- | keys - -- process ringPackets, and get a map of fingerprint info to + -- process ringPackets, and get a map of fingerprint info to -- to a packet, remembering it's original file, access. - keys :: Map.Map KeyKey MappedPacket - keys = Map.foldl slurpkeys Map.empty - $ Map.mapWithKey filterSecrets ringPackets - where - filterSecrets f (_,Message ps) = - filter (isSecretKey . packet) - $ zipWith (mappedPacketWithHint fname) ps [1..] - where fname = resolveForReport (Just ctx) f - slurpkeys m ps = m `Map.union` Map.fromList ps' - where ps' = zip (map (keykey . packet) ps) ps - -- | mwk - -- first master key matching the provided grip - -- (the m is for "MappedPacket", wk for working key) + keys :: Map.Map KeyKey (OriginMapped Query) mwk :: Maybe MappedPacket - mwk = listToMaybe $ do - fp <- maybeToList grip - let matchfp mp = not (is_subkey p) && matchpr fp p == fp - where p = packet mp - Map.elems $ Map.filter matchfp keys + (mwk, keys) = keyQueries grip ringPackets + -- | accs -- file access(Sec | Pub) lookup table accs :: Map.Map InputFile Access accs = fmap (access . fst) ringPackets return (spilled,mwk,grip,accs,keys,fmap snd unspilled) - doDecrypt <- makeMemoizingDecrypter keyring ctx keys + transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) + let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx @@ -205,10 +203,10 @@ buildKeyDB ctx grip0 keyring = do , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty - , rtPassphrases = doDecrypt + , rtPassphrases = transcode } -- autosigns and deletes - transformed0 <- do + transformed0 <- let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) trans f (info,ps) = do let manip = combineTransforms (transforms info) @@ -216,87 +214,84 @@ buildKeyDB ctx grip0 keyring = do acc = Just Sec /= Map.lookup f accs r <- performManipulations doDecrypt rt1 mwk manip try r $ \(rt2,report) -> do - return $ KikiSuccess (report,rtKeyDB rt2) + return $ KikiSuccess (report,rtKeyDB rt2) + -- XXX: Unspilled keys are not obtainable from rtKeyDB. + -- If the working key is marked non spillable, then how + -- would we look up it's UID and such? #if MIN_VERSION_containers(0,5,0) - fmap sequenceA $ Map.traverseWithKey trans spilled + in fmap sequenceA $ Map.traverseWithKey trans spilled #else - fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled + in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled #endif try transformed0 $ \transformed -> do - let -- | db_rings - all keyrings combined into one - db_rings :: Map.Map KeyKey KeyData - db_rings = Map.foldlWithKey' mergeIt Map.empty transformed - where - mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans - -- | reportTrans - -- events, indexed by file - reportTrans :: [(FilePath, KikiReportAction)] - reportTrans = concat $ Map.elems $ fmap fst transformed + let -- | db_rings - all keyrings combined into one + db_rings :: Map.Map KeyKey KeyData + db_rings = Map.foldlWithKey' mergeIt Map.empty transformed + where + mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans + -- | reportTrans + -- events, indexed by file + reportTrans :: [(FilePath, KikiReportAction)] + reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets - let importWalletKey wk db' (top,fname,sub,tag) = do - try db' $ \(db',report0) -> do - r <- doImportG doDecrypt - db' - (fmap keykey $ maybeToList wk) - [mkUsage tag] - fname - sub - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - wms <- mapM (readw wk) (files iswallet) - let wallet_keys = do - maybeToList wk - (fname,xs) <- wms - (_,sub,(_,m)) <- xs - (tag,top) <- Map.toList m - return (top,fname,sub,tag) - db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys - try db $ \(db,reportWallets) -> do - - -- PEM files - let pems = do - (n,stream) <- Map.toList $ opFiles keyring - grip <- maybeToList grip - n <- resolveInputFile ctx n - guard $ spillable stream && isSecretKeyFile (typ stream) - let us = mapMaybe usageFromFilter [fill stream,spill stream] - usage <- take 1 us - guard $ all (==usage) $ drop 1 us - -- TODO: KikiCondition reporting for spill/fill usage mismatch? - -- TODO: parseSpec3 - let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList db) - cmd = initializer stream - return (n,subspec,ms,stream, cmd) - - imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems - db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports - try db $ \(db,reportPEMs) -> do - - -- generate keys - let gens = mapMaybe g $ Map.toList genMap - where g (Generate _ params,v) = Just (params,v) - g _ = Nothing - - db <- generateInternals doDecrypt mwk db gens - try db $ \(db,reportGens) -> do - - r <- mergeHostFiles keyring db ctx - try r $ \((db,hs),reportHosts) -> do - - return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) - , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) - - -resolveInputFile :: InputFileContext -> InputFile -> [FilePath] -resolveInputFile ctx = resolve - where - resolve HomeSec = return (homesecPath ctx) - resolve HomePub = return (homepubPath ctx) - resolve (ArgFile f) = return f - resolve _ = [] + let importWalletKey wk db' (top,fname,sub,tag) = do + try db' $ \(db',report0) -> do + r <- doImportG transcode + db' + (fmap keykey $ maybeToList wk) + [mkUsage tag] + fname + sub + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + + wms <- mapM (readw wk) (files iswallet) + let wallet_keys = do + maybeToList wk + (fname,xs) <- wms + (_,sub,(_,m)) <- xs + (tag,top) <- Map.toList m + return (top,fname,sub,tag) + + db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys + try db $ \(db,reportWallets) -> do + + -- PEM files + let pems = do + (n,stream) <- Map.toList $ opFiles keyring + grip <- maybeToList grip + guard $ spillable stream && isSecretKeyFile (typ stream) + let us = mapMaybe usageFromFilter [fill stream,spill stream] + usage <- take 1 us + guard $ all (==usage) $ drop 1 us + -- TODO: KikiCondition reporting for spill/fill usage mismatch? + -- TODO: parseSpec3 + let (topspec,subspec) = parseSpec grip usage + ms = map fst $ filterMatches topspec (Map.toList db) + cmd = initializer stream + return (n,subspec,ms,stream, cmd) + + imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n + _ -> return True) + pems + db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports + try db $ \(db,reportPEMs) -> do + + -- generate keys + let gens = mapMaybe g $ Map.toList genMap + where g (Generate _ params,v) = Just (params,v) + g _ = Nothing + + db <- generateInternals transcode mwk db gens + try db $ \(db,reportGens) -> do + + r <- mergeHostFiles keyring db ctx + try r $ \((db,hs),reportHosts) -> do + + return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled) + , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) + isring :: FileType -> Bool isring (KeyRingFile {}) = True @@ -327,11 +322,12 @@ readPacketsFromWallet wk fname = do timestamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let (ks,_) = slurpWIPKeys timestamp input + {- unless (null ks) $ do -- decrypt wk -- create sigs -- return key/sig pairs - return () + return () -} return $ do wk <- maybeToList wk guard (not $ null ks) @@ -344,120 +340,11 @@ spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True -isSecretKey :: Packet -> Bool -isSecretKey (SecretKeyPacket {}) = True -isSecretKey _ = False - -mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket -mappedPacketWithHint filename p hint = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p hint) - } - -resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath -resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) - where str = case (fdr,fdw) of - (0,1) -> "-" - _ -> "&pipe" ++ show (fdr,fdw) -resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) - where str = "&" ++ show fd -resolveForReport mctx f = concat $ resolveInputFile ctx f - where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx - -keykey :: Packet -> KeyKey -keykey key = - -- Note: The key's timestamp is normally included in it's fingerprint. - -- This is undesirable for kiki because it causes the same - -- key to be imported multiple times and show as apparently - -- distinct keys with different fingerprints. - -- Thus, we will remove the timestamp. - fingerprint_material (key {timestamp=0}) -- TODO: smaller key? - --- matchpr computes the fingerprint of the given key truncated to --- be the same lenght as the given fingerprint for comparison. --- --- matchpr fp = Data.List.Extra.takeEnd (length fp) --- -matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp - -makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext - -> Map.Map KeyKey MappedPacket - -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation ctx keys = - if null chains then do - -- (*) Notice we do not pass ctx to resolveForReport. - -- This is because the merge function does not currently use a context - -- and the pws map keys must match the MappedPacket locations. - -- TODO: Perhaps these should both be of type InputFile rather than - -- FilePath? - -- pws :: Map.Map FilePath (IO S.ByteString) - {- - pws <- - Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) - (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above - $ Map.filter (isJust . pwfile . typ) $ opFiles operation) - -} - let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" - pws2 <- - Traversable.mapM (cachedContents prompt ctx) - $ Map.fromList $ mapMaybe - (\spec -> (,passSpecPassFile spec) `fmap` do - guard $ isNothing $ passSpecKeySpec spec - passSpecRingFile spec) - passspecs - defpw <- do - Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) - $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) - && isNothing (passSpecKeySpec sp)) - $ opPassphrases operation - unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) - return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw - else let PassphraseMemoizer f = head chains - in return f - where - (chains,passspecs) = partition isChain $ opPassphrases operation - where isChain (PassphraseMemoizer {}) = True - isChain _ = False - doDecrypt :: IORef (Map.Map KeyKey Packet) - -> Map.Map FilePath (IO S.ByteString) - -> Maybe (IO S.ByteString) - -> MappedPacket - -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw mp0 = do - unkeys <- readIORef unkeysRef - let mp = fromMaybe mp0 $ do - k <- Map.lookup kk keys - return $ mergeKeyPacket "decrypt" mp0 k - wk = packet mp0 - kk = keykey wk - fs = Map.keys $ locations mp - - decryptIt [] = return BadPassphrase - decryptIt (getpw:getpws) = do - -- TODO: This function should use mergeKeyPacket to - -- combine the packet with it's unspilled version before - -- attempting to decrypt it. - pw <- getpw - let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) - case symmetric_algorithm wkun of - Unencrypted -> do - writeIORef unkeysRef (Map.insert kk wkun unkeys) - return $ KikiSuccess wkun - _ -> decryptIt getpws - - getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw - - case symmetric_algorithm wk of - Unencrypted -> return (KikiSuccess wk) - _ -> maybe (decryptIt getpws) - (return . KikiSuccess) - $ Map.lookup kk unkeys -- | combineTransforms --- remove rundant transforms, and compile the rest to PacketUpdate(s) +-- remove redundant transforms, and compile the rest to PacketUpdate(s) -- --- eqivalent to: +-- equivalent to: -- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] combineTransforms trans rt kd = updates @@ -490,108 +377,6 @@ merge db inputfile (Message ps) = merge_ db filename qs updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret -performManipulations :: - (MappedPacket -> IO (KikiCondition Packet)) - -> KeyRingRuntime - -> Maybe MappedPacket - -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) - -> 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 db - try (sequenceA r) $ \db -> do - return $ - KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db) - where - perform - :: KikiCondition (KeyData, KikiReport) - -> PacketUpdate - -> IO (KikiCondition (KeyData, KikiReport)) - perform kd (InducerSignature uid subpaks) = do - try kd $ \(kd, report) -> do - flip (maybe $ return NoWorkingKey) wk $ \wk' -> do - wkun' <- doDecrypt wk' - try wkun' $ \wkun -> do - let flgs = - if keykey (keyPacket kd) == keykey wkun - then keyFlags0 - (keyPacket kd) - (map (\(x, _, _) -> x) selfsigs) - else [] - sigOver = - makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $ - flgs ++ subpaks - 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) . keykey)) - vs - keys = map keyPacket $ Map.elems (rtKeyDB rt) - overs sig = - signatures $ - Message (keys ++ [keyPacket kd, UserIDPacket uid, sig]) - vs - :: [(Packet -- signature - , Maybe SignatureOver -- Nothing means non-verified - , Packet -- key who signed - )] - vs = 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) - additional new_sig = do - new_sig <- maybeToList new_sig - guard (null $ selfsigs) - signatures_over new_sig - sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) - let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap) - f x = - ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++ - fst x - , om `Map.union` snd x) - -- 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 - let kk = keykey $ packet $ keyMappedPacket kd - kd' - | kk /= topk = kd - | otherwise = - kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd} - pred k _ = k /= subk - ps = - concat $ - maybeToList $ do - SubKey mp sigs <- Map.lookup subk (keySubKeys kd) - return $ - packet mp : - concatMap (\(p, ts) -> packet p : Map.elems ts) sigs - ctx = InputFileContext (rtSecring rt) (rtPubring rt) - rings = [HomeSec, HomePub] >>= resolveInputFile ctx - return $ - KikiSuccess - ( kd' - , report ++ - [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps]) - -try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) -try x body = - case functorToEither x of - Left e -> return e - Right x -> body x mergeKeyData :: KeyData -> KeyData -> KeyData mergeKeyData (KeyData atop asigs auids asubs) @@ -620,40 +405,19 @@ mergeKeyData (KeyData atop asigs auids asubs) mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) doImportG - :: (MappedPacket -> IO (KikiCondition Packet)) + :: PacketTranscoder -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags - -> FilePath + -> InputFile -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImportG doDecrypt db m0 tags fname key = do +doImportG transcode db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db - kdr <- insertSubkey doDecrypt kk kd tags fname key + kdr <- insertSubkey transcode kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) -mkUsage :: String -> SignatureSubpacket -mkUsage tag - | Just flags <- lookup tag specials = - KeyFlagsPacket - { certify_keys = fromEnum flags .&. 0x1 /= 0 - , sign_data = fromEnum flags .&. 0x2 /= 0 - , encrypt_communication = fromEnum flags .&. 0x4 /= 0 - , encrypt_storage = fromEnum flags .&. 0x8 /= 0 - , split_key = False - , authentication = False - , group_key = False - } - where - flagsets = [Special .. VouchSignEncrypt] - specials = map (\f -> (usageString f, f)) flagsets - -mkUsage tag = NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = tag - } iswallet :: FileType -> Bool iswallet (WalletFile {}) = True @@ -749,32 +513,32 @@ filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks importSecretKey :: - (MappedPacket -> IO (KikiCondition Packet)) + (PacketTranscoder) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) + -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey doDecrypt db' tup = do +importSecretKey transcode db' tup = do try db' $ \(db',report0) -> do - r <- doImport doDecrypt - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) + r <- doImport transcode + db' + tup + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) generateInternals :: - (MappedPacket -> IO (KikiCondition Packet)) + PacketTranscoder -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -generateInternals doDecrypt mwk db gens = do +generateInternals transcode mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do - kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens + kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens try kd $ \(kd,reportGens) -> do - let kk = keykey $ packet $ fromJust mwk - return $ KikiSuccess (Map.insert kk kd db,reportGens) + let kk = keykey $ packet $ fromJust mwk + return $ KikiSuccess (Map.insert kk kd db,reportGens) Nothing -> return $ KikiSuccess (db,[]) mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext @@ -875,89 +639,6 @@ slurpWIPKeys stamp cs = else let (ks,js) = slurpWIPKeys stamp xs in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb -origin :: Packet -> Int -> OriginFlags -origin p n = OriginFlags ispub n - where - ispub = case p of - SecretKeyPacket {} -> False - _ -> True - -cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) -cachedContents maybePrompt ctx fd = do - ref <- newIORef Nothing - return $ get maybePrompt ref fd - where - trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs - - get maybePrompt ref fd = do - pw <- readIORef ref - flip (flip maybe return) pw $ do - if fd == FileDesc 0 then case maybePrompt of - Just prompt -> S.hPutStr stderr prompt - Nothing -> return () - else return () - pw <- fmap trimCR $ readInputFileS ctx fd - writeIORef ref (Just pw) - return pw - -mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket -mergeKeyPacket what key p = - key { packet = minimumBy (keyCompare what) [packet key,packet p] - , locations = Map.union (locations key) (locations p) - } - --- | resolveTransform -resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops - where - ops = map (\u -> InducerSignature u []) us - us = filter torStyle $ Map.keys umap - torStyle str = and [ uid_topdomain parsed == "onion" - , uid_realname parsed `elem` ["","Anonymous"] - , uid_user parsed == "root" - , fmap (match . fst) (lookup (packet k) torbindings) - == Just True ] - where parsed = parseUID str - match = (==subdom) . take (fromIntegral len) - subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] - subdom = Char8.unpack subdom0 - len = T.length (uid_subdomain parsed) - torbindings = getTorKeys (map packet $ flattenTop "" True kd) - getTorKeys pub = do - xs <- groupBindings pub - (_,(top,sub),us,_,_) <- xs - guard ("tor" `elem` us) - let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub - return (top,(torhash,sub)) - - groupBindings pub = gs - where (_,bindings) = getBindings pub - bindings' = accBindings bindings - code (c,(m,s),_,_,_) = (fingerprint_material m,-c) - ownerkey (_,(a,_),_,_,_) = a - sameMaster (ownerkey->a) (ownerkey->b) - = fingerprint_material a==fingerprint_material b - gs = groupBy sameMaster (sortBy (comparing code) bindings') - - --- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk - where - topk = keykey $ packet k -- key to master of key to be deleted - subk = do - (k,sub) <- Map.toList submap - guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) - return k - --- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk - where - topk = keykey $ packet k -- key to master of key to be deleted - subk = do - (k,SubKey p sigs) <- Map.toList submap - take 1 $ filter (has_tag tag) $ map (packet . fst) sigs - return k - merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) @@ -972,140 +653,38 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) whatP (a,_) = concat . take 1 . words . show $ a -isKey :: Packet -> Bool -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isTrust :: Packet -> Bool -isTrust (TrustPacket {}) = True -isTrust _ = False -keyPacket :: KeyData -> Packet -keyPacket (KeyData k _ _ _) = packet k - -keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] -keyFlags0 wkun uidsigs = concat - [ keyflags - , preferredsym - , preferredhash - , preferredcomp - , features ] - - where - subs = concatMap hashed_subpackets uidsigs - keyflags = filterOr isflags subs $ - KeyFlagsPacket { certify_keys = True - , sign_data = True - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = False - , group_key = False - } - preferredsym = filterOr ispreferedsym subs $ - PreferredSymmetricAlgorithmsPacket - [ AES256 - , AES192 - , AES128 - , CAST5 - , TripleDES - ] - preferredhash = filterOr ispreferedhash subs $ - PreferredHashAlgorithmsPacket - [ SHA256 - , SHA1 - , SHA384 - , SHA512 - , SHA224 - ] - preferredcomp = filterOr ispreferedcomp subs $ - PreferredCompressionAlgorithmsPacket - [ ZLIB - , BZip2 - , ZIP - ] - features = filterOr isfeatures subs $ - FeaturesPacket { supports_mdc = True - } - - filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs - - isflags (KeyFlagsPacket {}) = True - isflags _ = False - ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True - ispreferedsym _ = False - ispreferedhash (PreferredHashAlgorithmsPacket {}) = True - ispreferedhash _ = False - ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True - ispreferedcomp _ = False - isfeatures (FeaturesPacket {}) = True - isfeatures _ = False - -makeInducerSig - :: Packet - -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver --- torsig g topk wkun uid timestamp extras = todo -makeInducerSig topk wkun uid extras - = CertificationSignature (secretToPublic topk) - uid - (sigpackets 0x13 - subpackets - subpackets_unh) - where - subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] - tsign - ++ extras - subpackets_unh = [IssuerPacket (fingerprint wkun)] - tsign = if keykey wkun == keykey topk - then [] -- tsign doesnt make sense for self-signatures - else [ TrustSignaturePacket 1 120 - , RegularExpressionPacket regex] - -- <[^>]+[@.]asdf\.nowhere>$ - regex = "<[^>]+[@.]"++hostname++">$" - -- regex = username ++ "@" ++ hostname - -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String - hostname = subdomain' pu ++ "\\." ++ topdomain' pu - pu = parseUID uidstr where UserIDPacket uidstr = uid - subdomain' = escape . T.unpack . uid_subdomain - topdomain' = escape . T.unpack . uid_topdomain - escape s = concatMap echar s - where - echar '|' = "\\|" - echar '*' = "\\*" - echar '+' = "\\+" - echar '?' = "\\?" - echar '.' = "\\." - echar '^' = "\\^" - echar '$' = "\\$" - echar '\\' = "\\\\" - echar '[' = "\\[" - echar ']' = "\\]" - echar c = [c] - -insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) -insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do - let subkk = keykey key - (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) - []) - ( (False,) . addOrigin ) - (Map.lookup subkk subs) - where - addOrigin (SubKey mp sigs) = +-- insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) +insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do + let topcipher = symmetric_algorithm $ packet top + tops2k = s2k $ packet top + doDecrypt = transcode (Unencrypted,S2K 100 "") + fname = resolveForReport Nothing inputfile + subkk = keykey key0 + istor = do + guard ("tor" `elem` mapMaybe usage tags) + return $ torUIDFromKey key0 + addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs - subs' = Map.insert subkk subkey subs - istor = do - guard ("tor" `elem` mapMaybe usage tags) - return $ "Anonymous " + subkey_result <- do + case Map.lookup subkk subs of + Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing) + Nothing -> do + wkun' <- doDecrypt top + try wkun' $ \wkun -> do + key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 + try key' $ \key -> do + return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key)) + + + try subkey_result $ \(is_new,subkey,decrypted) -> do + + let subs' = Map.insert subkk subkey subs uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do let has_torid = do @@ -1115,72 +694,58 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) signatures_over $ verify (Message [packet top]) s flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do - wkun <- doDecrypt top - - try wkun $ \wkun -> do - - let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) - uid = UserIDPacket idstr - -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags - tor_ov = makeInducerSig (packet top) wkun uid keyflags - sig_ov <- pgpSign (Message [wkun]) - tor_ov - SHA1 - (fingerprint wkun) - flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) - (sig_ov >>= listToMaybe . signatures_over) - $ \sig -> do - let om = Map.singleton fname (origin sig (-1)) - trust = Map.empty - return $ KikiSuccess - ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} - , trust)],om) uids - , [] ) + + let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids) + uid = UserIDPacket idstr + -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags + tor_ov = makeInducerSig (packet top) (packet top) uid keyflags + wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted + try wkun' $ \wkun -> do + sig_ov <- pgpSign (Message [wkun]) + tor_ov + SHA1 + (fingerprint wkun) + flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) + (sig_ov >>= listToMaybe . signatures_over) + $ \sig -> do + let om = Map.singleton fname (origin sig (-1)) + trust = Map.empty + return $ KikiSuccess + ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} + , trust)],om) uids + , [] ) try uids' $ \(uids',report) -> do - let SubKey subkey_p subsigs = subkey - wk = packet top - (xs',minsig,ys') = findTag tags wk key subsigs - doInsert mbsig = do - -- NEW SUBKEY BINDING SIGNATURE - sig' <- makeSig doDecrypt top fname subkey_p tags mbsig - try sig' $ \(sig',report) -> do - report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] - let subs' = Map.insert subkk - (SubKey subkey_p $ xs'++[sig']++ys') - subs - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - - report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) - else id - s = show (fmap fst minsig,fingerprint key) - in return (f report) - - case minsig of - Nothing -> doInsert Nothing -- we need to create a new sig - Just (True,sig) -> -- we can deduce is_new == False - -- we may need to add a tor id - return $ KikiSuccess ( KeyData top topsigs uids' subs' - , report ) - Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag - -mappedPacket :: FilePath -> Packet -> MappedPacket -mappedPacket filename p = MappedPacket - { packet = p - , locations = Map.singleton filename (origin p (-1)) - } - -showPacket :: Packet -> String -showPacket p | isKey p = (if is_subkey p - then showPacket0 p - else ifSecret p "----Secret-----" "----Public-----") - ++ " "++show (key_algorithm p)++" "++fingerprint p - | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) - | otherwise = showPacket0 p -showPacket0 :: Show a => a -> [Char] -showPacket0 p = concat . take 1 $ words (show p) + let SubKey subkey_p subsigs = subkey + wk = packet top + (xs',minsig,ys') = findTag tags wk key0 subsigs + doInsert mbsig = do + -- NEW SUBKEY BINDING SIGNATURE + -- XXX: Here I assume that key0 is the unencrypted version + -- of subkey_p. TODO: Check this assumption. + sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig + try sig' $ \(sig',report) -> do + report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] + let subs' = Map.insert subkk + (SubKey subkey_p $ xs'++[sig']++ys') + subs + return $ KikiSuccess ( KeyData top topsigs uids' subs' + , report ) + + report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) + else id + s = show (fmap fst minsig,fingerprint key0) + in return (f report) + + case minsig of + Nothing -> doInsert Nothing -- we need to create a new sig + Just (True,sig) -> -- we can deduce is_new == False + -- we may need to add a tor id + return $ KikiSuccess ( KeyData top topsigs uids' subs' + , report ) + Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag + mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] mergeSig sig sigs = @@ -1207,26 +772,6 @@ mergeSig sig sigs = mergeSameSig a b = b -- trace ("discarding dup "++show a) b -usageString :: PGPKeyFlags -> String -usageString flgs = - case flgs of - Special -> "special" - Vouch -> "vouch" -- signkey - Sign -> "sign" - VouchSign -> "vouch-sign" - Communication -> "communication" - VouchCommunication -> "vouch-communication" - SignCommunication -> "sign-communication" - VouchSignCommunication -> "vouch-sign-communication" - Storage -> "storage" - VouchStorage -> "vouch-storage" - SignStorage -> "sign-storage" - VouchSignStorage -> "vouch-sign-storage" - Encrypt -> "encrypt" - VouchEncrypt -> "vouch-encrypt" - SignEncrypt -> "sign-encrypt" - VouchSignEncrypt -> "vouch-sign-encrypt" - parseSingleSpec :: String -> SingleKeySpec parseSingleSpec "*" = AnyMatch parseSingleSpec "-" = WorkingKeyMatch @@ -1270,66 +815,66 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us us = filter (isInfixOf pat) $ Map.keys uids doImport - :: (MappedPacket -> IO (KikiCondition Packet)) + :: PacketTranscoder -> Map.Map KeyKey KeyData - -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) + -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do +doImport transcode db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do - (certs,keys) <- case typ of - PEMFile -> do - ps <- readSecretPEMFile (ArgFile fname) - let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) - = partition (isJust . spemCert) ps - return (certs,keys) - DNSPresentation -> do - p <- readSecretDNSFile (ArgFile fname) - return ([],[p]) - -- TODO Probably we need to move to a new design where signature - -- packets are merged into the database in one phase with null - -- signatures, and then the signatures are made in the next phase. - -- This would let us merge annotations (like certificates) from - -- seperate files. - foldM (importKey tag certs) (KikiSuccess (db,[])) keys + (certs,keys) <- case typ of + PEMFile -> do + ps <- readSecretPEMFile fname + let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) + = partition (isJust . spemCert) ps + return (certs,keys) + DNSPresentation -> do + p <- readSecretDNSFile fname + return ([],[p]) + -- TODO Probably we need to move to a new design where signature + -- packets are merged into the database in one phase with null + -- signatures, and then the signatures are made in the next phase. + -- This would let us merge annotations (like certificates) from + -- seperate files. + foldM (importKey tag certs) (KikiSuccess (db,[])) keys where importKey tag certs prior key = do try prior $ \(db,report) -> do - let (m0,tailms) = splitAt 1 ms - if (not (null tailms) || null m0) - then return $ AmbiguousKeySpec fname - else do - let kk = keykey key - cs = filter (\c -> kk==keykey (pcertKey c)) certs - blobs = map mkCertNotation $ nub $ map pcertBlob cs - mkCertNotation bs = NotationDataPacket - { human_readable = False - , notation_name = "x509cert@" - , notation_value = Char8.unpack bs } - datedKey = key { timestamp = fromTime $ minimum dates } - dates = fromTime (timestamp key) : map pcertTimestamp certs - r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey - try r $ \(db',report') -> do - return $ KikiSuccess (db',report++report') + let (m0,tailms) = splitAt 1 ms + if (not (null tailms) || null m0) + then return $ AmbiguousKeySpec (resolveForReport Nothing fname) + else do + let kk = keykey key + cs = filter (\c -> kk==keykey (pcertKey c)) certs + blobs = map mkCertNotation $ nub $ map pcertBlob cs + mkCertNotation bs = NotationDataPacket + { human_readable = False + , notation_name = "x509cert@" + , notation_value = Char8.unpack bs } + datedKey = key { timestamp = fromTime $ minimum dates } + dates = fromTime (timestamp key) : map pcertTimestamp certs + r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey + try r $ \(db',report') -> do + return $ KikiSuccess (db',report++report') generateSubkey :: - (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ + PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) -generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do +generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do try kd' $ \(kd,report0) -> do - let subs = do - SubKey p sigs <- Map.elems $ keySubKeys kd - filter (has_tag tag) $ map (packet . fst) sigs - if null subs - then do - newkey <- generateKey genparam - kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey - try kdr $ \(newkd,report) -> do - return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) - else do - return $ KikiSuccess (kd,report0) + let subs = do + SubKey p sigs <- Map.elems $ keySubKeys kd + filter (has_tag tag) $ map (packet . fst) sigs + if null subs + then do + newkey <- generateKey genparam + kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey + try kdr $ \(newkd,report) -> do + return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) + else do + return $ KikiSuccess (kd,report0) generateSubkey _ kd _ = return kd -- | @@ -1496,12 +1041,6 @@ secp256k1_id = 0x2b8104000a "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 -} -readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString -readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx inp = do - let fname = resolveInputFile ctx inp - fmap S.concat $ mapM S.readFile fname keyCompare :: String -> Packet -> Packet -> Ordering keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT @@ -1514,101 +1053,6 @@ keyCompare what a b = error $ unlines ["Unable to merge "++what++":" , PP.ppShow b ] -parseUID :: String -> UserIDRecord -parseUID str = UserIDRecord { - uid_full = str, - uid_realname = realname, - uid_user = user, - uid_subdomain = subdomain, - uid_topdomain = topdomain - } - where - text = T.pack str - (T.strip-> realname, T.dropAround isBracket-> email) - = T.break (=='<') text - (user, T.drop 1-> hostname) = T.break (=='@') email - ( T.reverse -> topdomain, - T.reverse . T.drop 1 -> subdomain) - = T.break (=='.') . T.reverse $ hostname - -flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] -flattenTop fname ispub (KeyData key sigs uids subkeys) = - unk ispub key : - ( flattenAllUids fname ispub uids - ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) - -derToBase32 :: ByteString -> String -#if !defined(VERSION_cryptonite) -derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy -#else -derToBase32 = map toLower . Base32.encode . S.unpack . sha1 - where - sha1 :: L.ByteString -> S.ByteString - sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) -#endif - -derRSA :: Packet -> Maybe ByteString -derRSA rsa = do - k <- rsaKeyFromPacket rsa - return $ encodeASN1 DER (toASN1 k []) - -getBindings :: - [Packet] - -> - ( [([Packet],[SignatureOver])] -- other signatures with key sets - -- that were used for the verifications - , [(Word8, - (Packet, Packet), -- (topkey,subkey) - [String], -- usage flags - [SignatureSubpacket], -- hashed data - [Packet])] -- binding signatures - ) -getBindings pkts = (sigs,bindings) - where - (sigs,concat->bindings) = unzip $ do - let (keys,_) = partition isKey pkts - keys <- disjoint_fp keys - let (bs,sigs) = verifyBindings keys pkts - return . ((keys,sigs),) $ do - b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs - i <- map signature_issuer (signatures_over b) - i <- maybeToList i - who <- maybeToList $ find_key fingerprint (Message keys) i - let (code,claimants) = - case () of - _ | who == topkey b -> (1,[]) - _ | who == subkey b -> (2,[]) - _ -> (0,[who]) - let hashed = signatures_over b >>= hashed_subpackets - kind = guard (code==1) >> hashed >>= maybeToList . usage - return (code,(topkey b,subkey b), kind, hashed,claimants) - --- Returned data is simmilar to getBindings but the Word8 codes --- are ORed together. -accBindings :: - Bits t => - [(t, (Packet, Packet), [a], [a1], [a2])] - -> [(t, (Packet, Packet), [a], [a1], [a2])] -accBindings bs = as - where - gs = groupBy samePair . sortBy (comparing bindingPair) $ bs - as = map (foldl1 combine) gs - bindingPair (_,p,_,_,_) = pub2 p - where - pub2 (a,b) = (pub a, pub b) - pub a = fingerprint_material a - samePair a b = bindingPair a == bindingPair b - combine (ac,p,akind,ahashed,aclaimaints) - (bc,_,bkind,bhashed,bclaimaints) - = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) - -subkeyMappedPacket :: SubKey -> MappedPacket -subkeyMappedPacket (SubKey k _ ) = k - -has_tag :: String -> Packet -> Bool -has_tag tag p = isSignaturePacket p - && or [ tag `elem` mapMaybe usage (hashed_subpackets p) - , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) @@ -1689,200 +1133,55 @@ secretToPublic pkt@(SecretKeyPacket {}) = } secretToPublic pkt = pkt -sigpackets :: - Monad m => - Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet -sigpackets typ hashed unhashed = return $ - signaturePacket - 4 -- version - typ -- 0x18 subkey binding sig, or 0x19 back-signature - RSA - SHA1 - hashed - unhashed - 0 -- Word16 -- Left 16 bits of the signed hash value - [] -- [MPI] - -usage :: SignatureSubpacket -> Maybe String -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - -torhash :: Packet -> String -torhash key = fromMaybe "" $ derToBase32 <$> derRSA key - -keyFlags :: t -> [Packet] -> [SignatureSubpacket] -keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) - -flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] -flattenAllUids fname ispub uids = - concatSort fname head (flattenUid fname ispub) (Map.assocs uids) - --- | Given list of subpackets, a master key, one of its subkeys and a --- list of signatures on that subkey, yields: --- --- * preceding list of signatures --- --- * The most recent valid signature made by the master key along with a --- flag that indicates whether or not all of the supplied subpackets occur in --- it or, if no valid signature from the working key is present, Nothing. --- --- * following list of signatures --- -findTag :: - [SignatureSubpacket] - -> Packet - -> Packet - -> [(MappedPacket, b)] - -> ([(MappedPacket, b)], - Maybe (Bool, (MappedPacket, b)), - [(MappedPacket, b)]) -findTag tag topk subkey subsigs = (xs',minsig,ys') - where - vs = map (\sig -> - (sig, do - sig <- Just (packet . fst $ sig) - guard (isSignaturePacket sig) - guard $ flip isSuffixOf - (fingerprint topk) - . fromMaybe "%bad%" - . signature_issuer - $ sig - listToMaybe $ - map (signature_time . verify (Message [topk])) - (signatures $ Message [topk,subkey,sig]))) - subsigs - (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs - xs' = map fst xs - ys' = map fst $ if isNothing minsig then ys else drop 1 ys - minsig = do - (sig,ov) <- listToMaybe ys - ov - let hshed = hashed_subpackets $ packet $ fst sig - return ( null $ tag \\ hshed, sig) - -makeSig :: - (MappedPacket -> IO (KikiCondition Packet)) - -> MappedPacket - -> [Char] - -> MappedPacket - -> [SignatureSubpacket] - -> Maybe (MappedPacket, Map.Map k a) - -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) -makeSig doDecrypt top fname subkey_p tags mbsig = do - let wk = packet top - wkun <- doDecrypt top - try wkun $ \wkun -> do - let grip = fingerprint wk - addOrigin new_sig = - flip - (maybe $ return FailedToMakeSignature) - (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do - let mp' = mappedPacket fname new_sig - return $ KikiSuccess (mp', Map.empty) - parsedkey = [packet subkey_p] - hashed0 - | any isFlagsPacket tags = tags - | otherwise = - KeyFlagsPacket - { certify_keys = False - , sign_data = False - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = True - , group_key = False - } : - tags - -- implicitly added: - -- , SignatureCreationTimePacket (fromIntegral timestamp) - isFlagsPacket (KeyFlagsPacket {}) = True - isFlagsPacket _ = False - subgrip = fingerprint (head parsedkey) - back_sig <- - pgpSign - (Message parsedkey) - (SubkeySignature - wk - (head parsedkey) - (sigpackets 0x19 hashed0 [IssuerPacket subgrip])) - (if key_algorithm (head parsedkey) == ECDSA - then SHA256 - else SHA1) - subgrip - let iss = IssuerPacket (fingerprint wk) - cons_iss back_sig = - iss : map EmbeddedSignaturePacket (signatures_over back_sig) - unhashed0 = maybe [iss] cons_iss back_sig - new_sig <- - pgpSign - (Message [wkun]) - (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0)) - SHA1 - grip - let newSig = do - r <- addOrigin new_sig - return $ fmap (, []) r - flip (maybe newSig) mbsig $ \(mp, trustmap) -> do - let sig = packet mp - isCreation (SignatureCreationTimePacket {}) = True - isCreation _ = False - isExpiration (SignatureExpirationTimePacket {}) = True - isExpiration _ = False - (cs, ps) = partition isCreation (hashed_subpackets sig) - (es, qs) = partition isExpiration ps - stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs - where - unwrap (SignatureCreationTimePacket x) = x - exp = listToMaybe $ sort $ map unwrap es - where - unwrap (SignatureExpirationTimePacket x) = x - expires = liftA2 (+) stamp exp - timestamp <- now - if fmap ((< timestamp) . fromIntegral) expires == Just True - then return $ - KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature]) - else do - let times = - (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ - maybeToList $ do - e <- expires - return $ - SignatureExpirationTimePacket (e - fromIntegral timestamp) - sig' = sig {hashed_subpackets = times ++ (qs `union` tags)} - new_sig <- - pgpSign - (Message [wkun]) - (SubkeySignature wk (packet subkey_p) [sig']) - SHA1 - (fingerprint wk) - newsig <- addOrigin new_sig - return $ fmap (, []) newsig ifSecret :: Packet -> t -> t -> t ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f -uidkey :: Packet -> String -uidkey (UserIDPacket str) = str - -keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags -keyflags flgs@(KeyFlagsPacket {}) = - Just . toEnum $ - ( bit 0x1 certify_keys - .|. bit 0x2 sign_data - .|. bit 0x4 encrypt_communication - .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags - -- other flags: - -- split_key - -- authentication (ssh-client) - -- group_key - where - bit v f = if f flgs then v else 0 -keyflags _ = Nothing +instance ASN1Object RSAPrivateKey where + toASN1 rsa@(RSAPrivateKey {}) + = \xs -> Start Sequence + : IntVal 0 + : mpiVal rsaN + : mpiVal rsaE + : mpiVal rsaD + : mpiVal rsaP + : mpiVal rsaQ + : mpiVal rsaDmodP1 + : mpiVal rsaDmodQminus1 + : mpiVal rsaCoefficient + : End Sequence + : xs + where mpiVal f = IntVal x where MPI x = f rsa + + fromASN1 ( Start Sequence + : IntVal _ -- version + : IntVal n + : IntVal e + : IntVal d + : IntVal p + : IntVal q + : IntVal dmodp1 + : IntVal dmodqminus1 + : IntVal coefficient + : ys) = + Right ( privkey, tail $ dropWhile notend ys) + where + notend (End Sequence) = False + notend _ = True + privkey = RSAPrivateKey + { rsaN = MPI n + , rsaE = MPI e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = MPI dmodp1 + , rsaDmodQminus1 = MPI dmodqminus1 + , rsaCoefficient = MPI coefficient + } + fromASN1 _ = + Left "fromASN1: RSAPrivateKey: unexpected format" + readSecretPEMFile :: InputFile -> IO [SecretPEMData] readSecretPEMFile fname = do @@ -1912,6 +1211,7 @@ readSecretPEMFile fname = do mergeDate (tm,_) (Right mb) = (tm,mb) return $ dta + readSecretDNSFile :: InputFile -> IO Packet readSecretDNSFile fname = do let ctx = InputFileContext "" "" @@ -1992,97 +1292,6 @@ socketFamily (SockAddrUnix _) = AF_UNIX selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db -isBracket :: Char -> Bool -isBracket '<' = True -isBracket '>' = True -isBracket _ = False - -unk :: Bool -> MappedPacket -> MappedPacket -unk isPublic = if isPublic then toPacket secretToPublic else id - where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} - -concatSort :: - FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] -concatSort fname getp f = concat . sortByHint fname getp . map f - -flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] -flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs - -rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey -rsaKeyFromPacket p | isKey p = do - n <- lookup 'n' $ key p - e <- lookup 'e' $ key p - return $ RSAKey n e - -rsaKeyFromPacket _ = Nothing - -disjoint_fp :: [Packet] -> [[Packet]] -disjoint_fp ks = {- concatMap group2 $ -} transpose grouped - where - grouped = groupBy samepr . sortBy (comparing smallpr) $ ks - samepr a b = smallpr a == smallpr b - - {- - -- useful for testing - group2 :: [a] -> [[a]] - group2 (x:y:ys) = [x,y]:group2 ys - group2 [x] = [[x]] - group2 [] = [] - -} - -verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) -verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) - where - verified = do - sig <- signatures (Message nonkeys) - let v = verify (Message keys) sig - guard (not . null $ signatures_over v) - return v - (top,othersigs) = partition isSubkeySignature verified - embedded = do - sub <- top - let sigover = signatures_over sub - unhashed = sigover >>= unhashed_subpackets - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - -- trace ("subtypes = "++show subtypes) (return ()) - -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) - sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) - let v = verify (Message [subkey sub]) sig - guard (not . null $ signatures_over v) - return v - -flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = - (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - --- | Get the time stamp of a signature. --- --- Warning: This function checks unhashed_subpackets if no timestamp occurs in --- the hashed section. TODO: change this? --- -signature_time :: SignatureOver -> Word32 -signature_time ov = case (if null cs then ds else cs) of - [] -> minBound - xs -> maximum xs - where - ps = signatures_over ov - ss = filter isSignaturePacket ps - cs = concatMap (concatMap creationTime . hashed_subpackets) ss - ds = concatMap (concatMap creationTime . unhashed_subpackets) ss - creationTime (SignatureCreationTimePacket t) = [t] - creationTime _ = [] - -splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) -splitAtMinBy comp xs = minimumBy comp' xxs - where - xxs = zip (inits xs) (tails xs) - comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) - compM (Just a) (Just b) = comp a b - compM Nothing mb = GT - compM _ _ = LT - parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert parseCertBlob comp bs = do asn1 <- either (const Nothing) Just @@ -2171,15 +1380,18 @@ extractRSAKeyFields kvs = do , rsaCoefficient = u } where parseField blob = MPI <$> m +#if defined(VERSION_memory) + where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob) + bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs + where + nlen = S.length bs +#elif defined(VERSION_dataenc) where m = bigendian <$> Base64.decode (Char8.unpack blob) - bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = length bs +#endif -backsig :: SignatureSubpacket -> Maybe Packet -backsig (EmbeddedSignaturePacket s) = Just s -backsig _ = Nothing selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectKey0 wantPublic (spec,mtag) db = do @@ -2190,27 +1402,7 @@ selectKey0 wantPublic (spec,mtag) db = do y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 [] -> Nothing -sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] -sortByHint fname f = sortBy (comparing gethint) - where - gethint = maybe defnum originalNum . Map.lookup fname . locations . f - defnum = -1 - -unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] -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 - asMapped n p = let m = mappedPacket fname p - in m { locations = fmap (\x->x {originalNum=n}) (locations m) } - -smallpr :: Packet -> [Char] -smallpr k = drop 24 $ fingerprint k - -isSubkeySignature :: SignatureOver -> Bool -isSubkeySignature (SubkeySignature {}) = True -isSubkeySignature _ = False - +-- TODO: Data.ByteString.Lazy now exports this. toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs new file mode 100644 index 0000000..2383140 --- /dev/null +++ b/lib/KeyRing/Types.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE DeriveFunctor #-} +module KeyRing.Types where + +import Data.Char (isLower,toLower) +import Data.List (groupBy) +import Data.Map as Map (Map) +import qualified Data.Map as Map +import Data.OpenPGP +import Data.OpenPGP.Util +import Data.Time.Clock +import FunctorToMaybe +import qualified Data.ByteString.Lazy as L +import qualified System.Posix.Types as Posix + +-- | This type describes an idempotent transformation (merge or import) on a +-- set of GnuPG keyrings and other key files. +data KeyRingOperation = KeyRingOperation + { opFiles :: Map InputFile StreamInfo + -- ^ Indicates files to be read or updated. + , opPassphrases :: [PassphraseSpec] + -- ^ Indicates files or file descriptors where passphrases can be found. + , opTransforms :: [Transform] + -- ^ Transformations to be performed on the key pool after all files have + -- been read and before any have been written. + , opHome :: Maybe FilePath + -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' + -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted + -- and if that is not set, it falls back to $HOME/.gnupg. + } + deriving (Eq,Show) + +data InputFile = HomeSec + -- ^ A file named secring.gpg located in the home directory. + -- See 'opHome'. + | HomePub + -- ^ A file named pubring.gpg located in the home directory. + -- See 'opHome'. + | ArgFile FilePath + -- ^ Contents will be read or written from the specified path. + | FileDesc Posix.Fd + -- ^ Contents will be read or written from the specified file + -- descriptor. + | Pipe Posix.Fd Posix.Fd + -- ^ Contents will be read from the first descriptor and updated + -- content will be writen to the second. Note: Don't use Pipe + -- for 'Wallet' files. (TODO: Wallet support) + | Generate Int GenerateKeyParams + -- ^ New key packets will be generated if there is no + -- matching content already in the key pool. The integer is + -- a unique id number so that multiple generations can be + -- inserted into 'opFiles' + deriving (Eq,Ord,Show) + +-- | This type describes how 'runKeyRing' will treat a file. +data StreamInfo = StreamInfo + { access :: Access + -- ^ Indicates whether the file is allowed to contain secret information. + , typ :: FileType + -- ^ Indicates the format and content type of the file. + , fill :: KeyFilter + -- ^ This filter controls what packets will be inserted into a file. + , spill :: KeyFilter + -- + -- ^ Use this to indicate whether or not a file's contents should be + -- available for updating other files. Note that although its type is + -- 'KeyFilter', it is usually interpretted as a boolean flag. Details + -- depend on 'typ' and are as follows: + -- + -- 'KeyRingFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * otherwise - The file's contents will be shared. + -- + -- 'PEMFile': + -- + -- * 'KF_None' - The file's contents will not be shared. + -- + -- * 'KF_Match' - The file's key will be shared with the specified owner + -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be + -- equal to this value; changing the usage or owner of a key is not + -- supported via the fill/spill mechanism. + -- + -- * otherwise - Unspecified. Do not use. + -- + -- 'WalletFile': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + -- 'Hosts': + -- + -- * The 'spill' setting is ignored and the file's contents are shared. + -- (TODO) + -- + , initializer :: Initializer + -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set, + -- then it is interpretted as a shell command that may be used to create + -- the key if it does not exist. + , transforms :: [Transform] + -- ^ Per-file transformations that occur before the contents of a file are + -- spilled into the common pool. + } + deriving (Eq,Show) + + +-- | This type is used to indicate where to obtain passphrases. +data PassphraseSpec = PassphraseSpec + { passSpecRingFile :: Maybe FilePath + -- ^ If not Nothing, the passphrase is to be used for packets + -- from this file. + , passSpecKeySpec :: Maybe String + -- ^ Non-Nothing value reserved for future use. + -- (TODO: Use this to implement per-key passphrase associations). + , passSpecPassFile :: InputFile + -- ^ The passphrase will be read from this file or file descriptor. + } + -- | Use this to carry pasphrases from a previous run. + | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } + | PassphraseAgent + +instance Show PassphraseSpec where + show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) + show (PassphraseMemoizer _) = "PassphraseMemoizer" +instance Eq PassphraseSpec where + PassphraseSpec a b c == PassphraseSpec d e f + = and [a==d,b==e,c==f] + _ == _ + = False + +-- Ord instance for PassphraseSpec generally orders by generality with the most +-- general being greatest and the least general being least. The one exception +-- is the 'PassphraseMemoizer' which is considered least of all even though it +-- is very general. This is so an existing memoizer will be tried first, and +-- if there is none, one will be created that tries the others in order of +-- increasing generality. Key-specialization is considered less general than +-- file-specialization. +instance Ord PassphraseSpec where + compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ + compare PassphraseAgent PassphraseAgent = EQ + compare (PassphraseMemoizer _) _ = LT + compare (PassphraseSpec a b c) (PassphraseSpec d e f) + | fmap (const ()) a == fmap (const ()) d + && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f) + compare (PassphraseSpec (Just _) (Just _) _) _ = LT + compare (PassphraseSpec Nothing (Just _) _) _ = LT + compare (PassphraseSpec (Just _) _ _) _ = LT + compare PassphraseAgent _ = GT + +data Transform = + Autosign + -- ^ This operation will make signatures for any tor-style UID + -- that matches a tor subkey and thus can be authenticated without + -- requring the judgement of a human user. + -- + -- A tor-style UID is one of the following form: + -- + -- > Anonymous + | DeleteSubkeyByFingerprint String + -- ^ Delete the subkey specified by the given fingerprint and any + -- associated signatures on that key. + | DeleteSubkeyByUsage String + -- ^ Delete the subkey specified by the given usage tag and any + -- associated signatures on that key. + | RenameSubkeys String String + -- ^ Replace all subkey signatures matching the first usage tag with + -- fresh signatures that match the second usage tag. + deriving (Eq,Ord,Show) + +-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected +-- to contain secret or public PGP key packets. Note that it is not supported +-- to mix both in the same file and that the secret key packets include all of +-- the information contained in their corresponding public key packets. +data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. + -- (see 'rtRingAccess') + | Sec -- ^ secret information + | Pub -- ^ public information + deriving (Eq,Ord,Show) + +data FileType = KeyRingFile + | PEMFile + | WalletFile + | DNSPresentation + | Hosts + | SshFile + deriving (Eq,Ord,Enum,Show) + +-- type UsageTag = String +data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String + deriving (Eq,Ord,Show) + + + +type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) +type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) + +-- | Note that the documentation here is intended for when this value is +-- assigned to 'fill'. For other usage, see 'spill'. +data KeyFilter = KF_None -- ^ No keys will be imported. + | KF_Match String -- ^ Only the key that matches the spec will be imported. + | KF_Subkeys -- ^ Subkeys will be imported if their owner key is + -- already in the ring. TODO: Even if their signatures + -- are bad? + | KF_Authentic -- ^ Keys are imported if they belong to an authenticated + -- identity (signed or self-authenticating). + | KF_All -- ^ All keys will be imported. + deriving (Eq,Ord,Show) + +-- | The position and acces a packet had before the operation +data OriginFlags = OriginFlags + { originallyPublic :: Bool + -- ^ false if SecretKeyPacket + , originalNum :: Int + -- ^ packets are numbered, starting from 1.. + } deriving Show + +type OriginMap = Map FilePath OriginFlags + +type MappedPacket = OriginMapped Packet +data OriginMapped a = MappedPacket + { packet :: a + , locations :: OriginMap + } deriving Show +instance Functor OriginMapped where + fmap f (MappedPacket x ls) = MappedPacket (f x) ls + +origin :: Packet -> Int -> OriginFlags +origin p n = OriginFlags ispub n + where + ispub = case p of + SecretKeyPacket {} -> False + _ -> True + +mappedPacket :: FilePath -> Packet -> MappedPacket +mappedPacket filename p = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p (-1)) + } + +mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket +mappedPacketWithHint filename p hint = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p hint) + } + + +-- | This type is used to indicate success or failure +-- and in the case of success, return the computed object. +-- The 'FunctorToMaybe' class is implemented to facilitate +-- branching on failture. +data KikiCondition a = KikiSuccess a + | FailedToLock [FilePath] + | BadPassphrase + | FailedToMakeSignature + | CantFindHome + | AmbiguousKeySpec FilePath + | CannotImportMasterKey + | NoWorkingKey + | AgentConnectionFailure + | OperationCanceled + deriving ( Functor, Show ) + +instance FunctorToMaybe KikiCondition where + functorToMaybe (KikiSuccess a) = Just a + functorToMaybe _ = Nothing + +instance Applicative KikiCondition where + pure a = KikiSuccess a + f <*> a = + case functorToEither f of + Right f -> case functorToEither a of + Right a -> pure (f a) + Left err -> err + Left err -> err + +uncamel :: String -> String +uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args + where + (.:) = fmap . fmap + ( firstWord , + otherWords ) = splitAt 1 ws + ws = camel >>= groupBy (\_ c -> isLower c) + ( camel, args) = splitAt 1 $ words str + +errorString :: KikiCondition a -> String +errorString (KikiSuccess {}) = "success" +errorString e = uncamel . show $ fmap (const ()) e + + + +data InputFileContext = InputFileContext + { homesecPath :: FilePath + , homepubPath :: FilePath + } + + +-- | The 'KeyKey'-type is used to store the information of a key +-- which is used for finger-printing and as a lookup key into +-- maps. This type may be changed to an actual fingerprint in +-- in the future. +type KeyKey = [L.ByteString] + +keykey :: Packet -> KeyKey +keykey key = + -- Note: The key's timestamp is normally included in it's fingerprint. + -- This is undesirable for kiki because it causes the same + -- key to be imported multiple times and show as apparently + -- distinct keys with different fingerprints. + -- Thus, we will remove the timestamp. + fingerprint_material (key {timestamp=0}) -- TODO: smaller key? + +isKey :: Packet -> Bool +isKey (PublicKeyPacket {}) = True +isKey (SecretKeyPacket {}) = True +isKey _ = False + +isSecretKey :: Packet -> Bool +isSecretKey (SecretKeyPacket {}) = True +isSecretKey _ = False + + +isUserID :: Packet -> Bool +isUserID (UserIDPacket {}) = True +isUserID _ = False + +isTrust :: Packet -> Bool +isTrust (TrustPacket {}) = True +isTrust _ = False + +-- matchpr computes the fingerprint of the given key truncated to +-- be the same lenght as the given fingerprint for comparison. +-- +-- matchpr fp = Data.List.Extra.takeEnd (length fp) +-- +matchpr :: String -> Packet -> String +matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp + + + + +data KeySpec = + KeyGrip String -- fp: + | KeyTag Packet String -- fp:????/t: + | KeyUidMatch String -- u: + deriving Show + +{- +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL + } +-} +data RSAPrivateKey = RSAPrivateKey + { rsaN :: MPI + , rsaE :: MPI + , rsaD :: MPI + , rsaP :: MPI + , rsaQ :: MPI + , rsaDmodP1 :: MPI + , rsaDmodQminus1 :: MPI + , rsaCoefficient :: MPI + } + deriving Show + +data ParsedCert = ParsedCert + { pcertKey :: Packet + , pcertTimestamp :: UTCTime + , pcertBlob :: L.ByteString + } + deriving (Show,Eq) + +data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned + deriving (Eq,Ord,Enum,Show,Read) + +data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert + deriving (Show,Eq) + +data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum) + +data SingleKeySpec = FingerprintMatch String + | SubstringMatch (Maybe MatchingField) String + | EmptyMatch + | AnyMatch + | WorkingKeyMatch + deriving (Show,Eq,Ord) + -- cgit v1.2.3