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.hs | 1316 +------------------------------------------------------- 1 file changed, 6 insertions(+), 1310 deletions(-) (limited to 'lib/KeyRing.hs') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 244f880..69410ad 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -24,7 +24,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} -module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) +module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) where import System.Environment import Control.Monad @@ -123,7 +123,7 @@ import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import GnuPGAgent as Agent -import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, +import KeyRing.BuildKeyDB {- (accBindings, backsig, buildKeyDB, combineTransforms, concatSort, derRSA, derToBase32, filterMatches, findTag, fingerdress, @@ -148,35 +148,13 @@ import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, secretToPublic, seek_key, selectKey0, selectPublicKey, showPacket, sortByHint, - subkeyMappedPacket, torhash, try, - usage, usageFromFilter, - usageString) + subkeyMappedPacket, torhash, + usageFromFilter) -} -import Types +import KeyRing.Types import PacketTranscoder import Transforms --- DER-encoded elliptic curve ids --- nistp256_id = 0x2a8648ce3d030107 -secp256k1_id :: Integer -secp256k1_id = 0x2b8104000a --- "\x2a\x86\x48\xce\x3d\x03\x01\x07" -{- OID Curve description Curve name - ---------------------------------------------------------------- - 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" - 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" - 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" - - Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST - P-521". The hexadecimal representation used in the public and - private key encodings are: - - Curve Name Len Hexadecimal representation of the OID - ---------------------------------------------------------------- - "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 - "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 - "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 --} data HomeDir = HomeDir { homevar :: String @@ -191,37 +169,16 @@ home = HomeDir , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } -spillable :: StreamInfo -> Bool -spillable (spill -> KF_None) = False -spillable _ = True - isMutable :: StreamInfo -> Bool isMutable stream | KF_None <- fill stream = False isMutable _ = True -isring :: FileType -> Bool -isring (KeyRingFile {}) = True -isring _ = False - -isSecretKeyFile :: FileType -> Bool -isSecretKeyFile PEMFile = True -isSecretKeyFile DNSPresentation = True -isSecretKeyFile _ = False - {- pwfile :: FileType -> Maybe InputFile pwfile (KeyRingFile f) = f pwfile _ = Nothing -} -iswallet :: FileType -> Bool -iswallet (WalletFile {}) = True -iswallet _ = False - -usageFromFilter :: MonadPlus m => KeyFilter -> m String -usageFromFilter (KF_Match usage) = return usage -usageFromFilter _ = mzero - filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] @@ -275,76 +232,6 @@ instance ASN1Object PKCS8_RSAPublicKey where fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" -{- -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 - -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" - reportString :: KikiReportAction -> String @@ -369,45 +256,6 @@ x509cert _ = Nothing - -matchSpec :: KeySpec -> KeyData -> Bool -matchSpec (KeyGrip grip) (KeyData p _ _ _) - | matchpr grip (packet p)==grip = True - | otherwise = False - -matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps - where - ps = map (packet .fst) sigs - match p = isSignaturePacket p - && has_tag tag p - && has_issuer key p - has_issuer key p = isJust $ do - issuer <- signature_issuer p - guard $ matchpr issuer key == issuer - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us - where - us = filter (isInfixOf pat) $ Map.keys uids - - - - -data KeySpec = - KeyGrip String -- fp: - | KeyTag Packet String -- fp:????/t: - | KeyUidMatch String -- u: - deriving Show - -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) - getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" @@ -431,25 +279,6 @@ getStr _ = "" -- (Any of the fields may be left empty.) type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec) -parseSingleSpec :: String -> SingleKeySpec -parseSingleSpec "*" = AnyMatch -parseSingleSpec "-" = WorkingKeyMatch -parseSingleSpec "" = EmptyMatch -parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag -parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag -parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag -parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp -parseSingleSpec str - | is40digitHex str = FingerprintMatch str - | otherwise = SubstringMatch Nothing str - -is40digitHex xs = ys == xs && length ys==40 - where - ys = filter ishex xs - ishex c | '0' <= c && c <= '9' = True - | 'A' <= c && c <= 'F' = True - | 'a' <= c && c <= 'f' = True - ishex c = False data SpecError = SpecENone String | SpecEMissMatch String (Maybe MatchingField) MatchingField @@ -574,43 +403,6 @@ wordsBy c xs = let (b,a) = span (/=c) xs in b:wordsBy c (drop 1 a) - --- | Parse a key specification. --- The first argument is a grip for the default working key. -parseSpec :: String -> String -> (KeySpec,Maybe String) -parseSpec wkgrip spec = - if not slashed - then - case prespec of - AnyMatch -> (KeyGrip "", Nothing) - EmptyMatch -> error "Bad key spec." - WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) - SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) - SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) - SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) - FingerprintMatch fp -> (KeyGrip fp, Nothing) - else - case (prespec,postspec) of - (FingerprintMatch fp, SubstringMatch st t) - | st /= Just UserIDField -> (KeyGrip fp, Just t) - (SubstringMatch mt u, _) - | postspec `elem` [AnyMatch,EmptyMatch] - && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) - (SubstringMatch mt u, SubstringMatch st t) - | mt /= Just KeyTypeField - && st /= Just UserIDField -> (KeyUidMatch u, Just t) - (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" - (_,FingerprintMatch fp) -> error "todo: support /fp: spec" - (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" - _ -> error "Bad key spec." - where - (preslash,slashon) = break (=='/') spec - slashed = not $ null $ take 1 slashon - postslash = drop 1 slashon - - prespec = parseSingleSpec preslash - postspec = parseSingleSpec postslash - {- - BUGGY parseSpec grip spec = (topspec,subspec) @@ -653,9 +445,6 @@ parseSpec grip spec = (topspec,subspec) -} -filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] -filterMatches spec ks = filter (matchSpec spec . snd) ks - filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' where @@ -686,9 +475,6 @@ filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db -selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db - selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of @@ -717,15 +503,6 @@ selectPublicKeyAndSigs (spec,mtag) db = guard hastag return $ (kk, packet sub, map (packet . fst) sigs) -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - case ys of - y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 - [] -> Nothing - {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do @@ -742,50 +519,6 @@ selectAll wantPublic (spec,mtag) db = do in search (drop 1 ys) -} -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps - | null bs = (ps, []) - | null qs = - let (as', bs') = seek_key (KeyTag key tag) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps - | null bs = (ps, []) - | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - - -readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString -readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents -readInputFileL ctx inp = do - let fname = resolveInputFile ctx inp - fmap L.concat $ mapM L.readFile fname writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) @@ -829,20 +562,6 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str -getInputFileTime :: InputFileContext -> InputFile -> IO CTime -getInputFileTime ctx (Pipe fdr fdw) = do - mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr - maybe tryw return mt - where - tryw = do - handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?") - $ modificationTime <$> getFdStatus fdw -getInputFileTime ctx (FileDesc fd) = do - handleIO_ (error $ "&"++show fd++": modificaiton time?") $ - modificationTime <$> getFdStatus fd -getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do - handleIO_ (error $ fname++": modificaiton time?") $ - modificationTime <$> getFileStatus fname {- - This may be useful later. Commented for now as it is not used. @@ -855,104 +574,8 @@ doesInputFileExist ctx f = do -} -generateSubkey :: - PacketTranscoder - -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db - -> (GenerateKeyParams, StreamInfo) - -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) -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 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 - -importSecretKey :: - (PacketTranscoder) - -> KikiCondition - (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey transcode db' tup = do - try db' $ \(db',report0) -> do - r <- doImport transcode - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - - -mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext - -> IO - (KikiCondition - ( ( Map.Map [Char8.ByteString] KeyData - , ( [Hosts.Hosts] - , [Hosts.Hosts] - , Hosts.Hosts - , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] - , [SockAddr])) - , [(FilePath,KikiReportAction)])) -mergeHostFiles krd db ctx = do - let hns = files ishosts - ishosts Hosts = True - ishosts _ = False - files istyp = do - (f,stream) <- Map.toList (opFiles krd) - guard (istyp $ typ stream) - return f - readInputFileL' ctx f = - readInputFileL ctx f - `catch` \e -> do when (not $ isDoesNotExistError e) $ do - return () -- todo report problem - return L.empty - hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns - - let gpgnames = map getHostnames $ Map.elems db - os = do - (addr,(ns,_)) <- gpgnames - n <- ns - return (addr,n) - setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os - -- we ensure .onion names are set properly - hostdbs = map setOnions hostdbs0 - outgoing_names = do - (addr,(_,gns)) <- gpgnames - guard . not $ null gns - guard $ all (null . Hosts.namesForAddress addr) hostdbs0 - return addr - -- putStrLn $ "hostdbs = " ++ show hostdbs - - -- 1. let U = union all the host dbs - -- preserving whitespace and comments of the first - let u0 = foldl' Hosts.plus Hosts.empty hostdbs - -- we filter U to be only finger-dresses - u1 = Hosts.filterAddrs (hasFingerDress db) u0 - - -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h - {- - putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" - putStrLn $ "--> " ++ show (nf (head hostdbs)) - putStrLn $ "u0 = {\n" ++ show u0 ++ "}" - putStrLn $ "--> " ++ show (nf u0) - putStrLn $ "u1 = {\n" ++ show u1 ++ "}" - putStrLn $ "--> " ++ show (nf u1) - -} - - -- 2. replace gpg annotations with those in U - -- forM use_db - db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db - - return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) writeHostsFiles :: KeyRingOperation -> InputFileContext @@ -991,197 +614,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do return $ map (first $ resolveForReport $ Just ctx) rs return $ concat rss --- | buildKeyDB --- --- merge all keyrings, PEM files, and wallets into process memory. --- -buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation - -> IO (KikiCondition (({- db -} KeyDB - ,{- grip -} Maybe String - ,{- wk -} Maybe MappedPacket - ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], - {- hostdbs -}[Hosts.Hosts], - {- u1 -}Hosts.Hosts, - {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], - {- outgoing_names -}[SockAddr]) - ,{- accs -} Map.Map InputFile Access - ,{- doDecrypt -} PacketTranscoder - ,{- unspilled -} Map.Map InputFile Message - ) - ,{- report_imports -} [(FilePath,KikiReportAction)])) -buildKeyDB ctx grip0 keyring = do - let files istyp = do - (f,stream) <- Map.toList (opFiles keyring) - guard (istyp $ typ stream) - return f -- resolveInputFile ctx f - ringMap0 = Map.filter (isring . typ) $ opFiles keyring - (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 - where - isgen (Generate _ _) _ = True - isgen _ _ = False - - readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message) - readp f stream = fmap readp0 $ readPacketsFromFile ctx f - where - readp0 ps = (stream { access = acc' }, ps) - where acc' = case access stream of - AutoAccess -> - case ps of - Message ((PublicKeyPacket {}):_) -> Pub - Message ((SecretKeyPacket {}):_) -> Sec - _ -> AutoAccess - acc -> acc - - readw wk n = fmap (n,) (readPacketsFromWallet wk n) - - -- KeyRings (todo: KikiCondition reporting?) - (spilled,mwk,grip,accs,keyqs,unspilled) <- do -#if MIN_VERSION_containers(0,5,0) - ringPackets <- Map.traverseWithKey readp ringMap -#else - ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap -#endif - let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) - - let grip = grip0 `mplus` (fingerprint <$> fstkey) - where - fstkey = do - (_,Message ps) <- Map.lookup HomeSec ringPackets - listToMaybe ps - - -- | spilled - -- ring packets with info available for export - -- | unspilled - -- the rest - (spilled,unspilled) = Map.partition (spillable . fst) ringPackets - - -- | keys - -- process ringPackets, and get a map of fingerprint info to - -- to a packet, remembering it's original file, access. - keys :: Map.Map KeyKey (OriginMapped Query) - mwk :: Maybe MappedPacket - (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) - - transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) - let doDecrypt = transcode (Unencrypted,S2K 100 "") - - let wk = fmap packet mwk - rt0 = KeyRingRuntime { rtPubring = homepubPath ctx - , rtSecring = homesecPath ctx - , rtGrip = grip - , rtWorkingKey = wk - , rtRingAccess = accs - , rtKeyDB = Map.empty - , rtPassphrases = transcode - } - -- autosigns and deletes - transformed0 <- - let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) - trans f (info,ps) = do - let manip = combineTransforms (transforms info) - rt1 = rt0 { rtKeyDB = merge Map.empty f ps } - acc = Just Sec /= Map.lookup f accs - r <- performManipulations doDecrypt rt1 mwk manip - try r $ \(rt2,report) -> do - 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) - in fmap sequenceA $ Map.traverseWithKey trans spilled -#else - 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 - - -- Wallets - 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 ) - -generateInternals :: - PacketTranscoder - -> Maybe MappedPacket - -> Map.Map KeyKey KeyData - -> [(GenerateKeyParams,StreamInfo)] - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -generateInternals transcode mwk db gens = do - case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of - Just kd0 -> do - 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) - Nothing -> return $ KikiSuccess (db,[]) unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do @@ -1190,69 +623,9 @@ unconditionally action = do KikiSuccess x -> return x e -> error $ errorString e -data ParsedCert = ParsedCert - { pcertKey :: Packet - , pcertTimestamp :: UTCTime - , pcertBlob :: L.ByteString - } - deriving (Show,Eq) -data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert - deriving (Show,Eq) - -spemPacket (PEMPacket p) = Just p -spemPacket _ = Nothing - -spemCert (PEMCertificate p) = Just p -spemCert _ = Nothing - -toStrict :: L.ByteString -> S.ByteString -toStrict = foldr1 (<>) . L.toChunks -- No instance for (ASN1Object RSA.PublicKey) -parseCertBlob comp bs = do - asn1 <- either (const Nothing) Just - $ decodeASN1 DER bs - let asn1' = drop 2 asn1 - cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') - let _ = cert :: X509.Certificate - notBefore :: UTCTime -#if MIN_VERSION_x509(1,5,0) - notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano - where (vincentTime,_) = X509.certValidity cert -#else - (notBefore,_) = X509.certValidity cert -#endif - case X509.certPubKey cert of - X509.PubKeyRSA key -> do - let withoutkey = - let ekey = toStrict $ encodeASN1 DER (toASN1 key []) - (pre,post) = S.breakSubstring ekey $ toStrict bs - post' = S.drop (S.length ekey) post - len :: Word16 - len = if S.null post then maxBound - else fromIntegral $ S.length pre - in if len < 4096 - then encode len <> GZip.compress (Char8.fromChunks [pre,post']) - else bs - return - ParsedCert { pcertKey = packetFromPublicRSAKey notBefore - (MPI $ RSA.public_n key) - (MPI $ RSA.public_e key) - , pcertTimestamp = notBefore - , pcertBlob = if comp then withoutkey - else bs - } - _ -> Nothing - -packetFromPublicRSAKey notBefore n e = - PublicKeyPacket { version = 4 - , timestamp = round $ utcTimeToPOSIXSeconds notBefore - , key_algorithm = RSA - , key = [('n',n),('e',e)] - , is_subkey = True - , v3_days_of_validity = Nothing - } decodeBlob cert = if 0 /= (bs `L.index` 0) .&. 0x10 @@ -1267,271 +640,9 @@ decodeBlob cert = bs = pcertBlob cert key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert -extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey -extractRSAKeyFields kvs = do - let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs - n <- lookup "Modulus" kvs' - e <- lookup "PublicExponent" kvs' - d <- lookup "PrivateExponent" kvs' - p <- lookup "Prime1" kvs' -- p - q <- lookup "Prime2" kvs' -- q - dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) - dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) - u <- lookup "Coefficient" kvs' - {- - case (d,p,dmodp1) of - (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () - _ -> error "dmodp fail!" - case (d,q,dmodqminus1) of - (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () - _ -> error "dmodq fail!" - -} - return $ RSAPrivateKey - { rsaN = n - , rsaE = e - , rsaD = d - , rsaP = p - , rsaQ = q - , rsaDmodP1 = dmodp1 - , rsaDmodQminus1 = dmodqminus1 - , 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 -rsaToPGP stamp rsa = SecretKeyPacket - { version = 4 - , timestamp = fromTime stamp -- toEnum (fromEnum stamp) - , key_algorithm = RSA - , key = [ -- public fields... - ('n',rsaN rsa) - ,('e',rsaE rsa) - -- secret fields - ,('d',rsaD rsa) - ,('p',rsaQ rsa) -- Note: p & q swapped - ,('q',rsaP rsa) -- Note: p & q swapped - ,('u',rsaCoefficient rsa) - ] - -- , ecc_curve = def - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - -readSecretDNSFile :: InputFile -> IO Packet -readSecretDNSFile fname = do - let ctx = InputFileContext "" "" - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) - . Char8.break (==':')) - $ Char8.lines input - alg = maybe RSA parseAlg $ lookup "Algorithm" kvs - parseAlg spec = case Char8.words spec of - nstr:_ -> case read (Char8.unpack nstr) :: Int of - 2 -> DH - 3 -> DSA -- SHA1 - 5 -> RSA -- SHA1 - 6 -> DSA -- NSEC3-SHA1 (RFC5155) - 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) - 8 -> RSA -- SHA256 - 10 -> RSA -- SHA512 (RFC5702) - -- 12 -> GOST - 13 -> ECDSA -- P-256 SHA256 (RFC6605) - 14 -> ECDSA -- P-384 SHA384 (RFC6605) - _ -> RSA - case alg of - RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs - - -readSecretPEMFile :: InputFile -> IO [SecretPEMData] -readSecretPEMFile fname = do - -- warn $ fname ++ ": reading ..." - let ctx = InputFileContext "" "" - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input - pkcs1 = fmap (parseRSAPrivateKey . pemBlob) - $ pemParser $ Just "RSA PRIVATE KEY" - cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) - $ pemParser $ Just "CERTIFICATE" - parseRSAPrivateKey dta = do - let e = decodeASN1 DER dta - asn1 <- either (const $ mzero) return e - rsa <- either (const mzero) (return . fst) (fromASN1 asn1) - let _ = rsa :: RSAPrivateKey - return $ PEMPacket $ rsaToPGP stamp rsa - dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta - mergeDate (_,obj) (Left tm) = (fromTime tm,obj) - mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') - where key' = if tm < fromTime (timestamp key) - then key { timestamp = fromTime tm } - else key - mergeDate (tm,_) (Right mb) = (tm,mb) - return $ dta - -doImport - :: PacketTranscoder - -> Map.Map KeyKey KeyData - -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -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 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 (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') - -doImportG - :: PacketTranscoder - -> Map.Map KeyKey KeyData - -> [KeyKey] -- m0, only head is used - -> [SignatureSubpacket] -- tags - -> InputFile - -> Packet - -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -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 transcode kk kd tags fname key - try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) - -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 - - 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 - -- TODO: check for omitted real name field - (sigtrusts,om) <- Map.lookup idstr uids - listToMaybe $ 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 - - 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 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 + isCryptoCoinKey :: Packet -> Bool isCryptoCoinKey p = @@ -2004,18 +1115,6 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) --- | combineTransforms --- remove rundant transforms, and compile the rest to PacketUpdate(s) --- --- eqivalent to: --- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd -combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] -combineTransforms trans rt kd = updates - where - updates = -- kManip operation rt kd ++ - concatMap (\t -> resolveTransform t rt kd) sanitized - sanitized = group (sort trans) >>= take 1 - -- | Load and update key files according to the specified 'KeyRingOperation'. @@ -2160,128 +1259,10 @@ lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif -slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) -slurpWIPKeys stamp "" = ([],[]) -slurpWIPKeys stamp cs = - let (b58,xs) = Char8.span (`elem` base58chars) cs - mb = decode_btc_key stamp (Char8.unpack b58) - in if L.null b58 - then let (ys,xs') = Char8.break (`elem` base58chars) cs - (ks,js) = slurpWIPKeys stamp xs' - in (ks,ys:js) - else let (ks,js) = slurpWIPKeys stamp xs - in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb - - -decode_btc_key :: - Enum timestamp => timestamp -> String -> Maybe (Word8, Message) -decode_btc_key timestamp str = do - (network_id,us) <- base58_decode str - return . (network_id,) $ Message $ do - let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) - {- - xy = secp256k1_G `pmul` d - x = getx xy - y = gety xy - -- y² = x³ + 7 (mod p) - y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) - y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) - -} - secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 - ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 - -- pub = cannonical_eckey x y - -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub - -- address = base58_encode hash - -- pubstr = concatMap (printf "%02x") $ pub - -- _ = pubstr :: String - return $ {- trace (unlines ["pub="++show pubstr - ,"add="++show address - ,"y ="++show y - ,"y' ="++show y' - ,"y''="++show y'']) -} - SecretKeyPacket - { version = 4 - , timestamp = toEnum (fromEnum timestamp) - , key_algorithm = ECDSA - , key = [ -- public fields... - ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) - ,('l',MPI 256) - ,('x',MPI x) - ,('y',MPI y) - -- secret fields - ,('d',MPI d) - ] - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } - - -readPacketsFromWallet :: - Maybe Packet - -> InputFile - -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -readPacketsFromWallet wk fname = do - let ctx = InputFileContext "" "" - 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 $ do - wk <- maybeToList wk - guard (not $ null ks) - let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) - where tag = CryptoCoins.nameFromSecretByte tagbyte - (wk,MarkerPacket,(MarkerPacket,Map.empty)) - :map prep ks - -readPacketsFromFile :: InputFileContext -> InputFile -> IO Message -readPacketsFromFile ctx fname = do - -- warn $ fname ++ ": reading..." - input <- readInputFileL ctx fname -#if MIN_VERSION_binary(0,7,0) - return $ - case decodeOrFail input of - Right (_,_,msg ) -> msg - Left (_,_,_) -> - -- FIXME - -- trace (fname++": read fail") $ - Message [] -#else - return $ decode input -#endif - -merge :: KeyDB -> InputFile -> Message -> KeyDB -merge db inputfile (Message ps) = merge_ db filename qs - where - filename = resolveForReport Nothing inputfile - qs = scanPackets filename ps - scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - scanPackets filename [] = [] - scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps - where - ret p = (p,Map.empty) - doit (top,sub,prev) p = - case p of - _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) - _ | isKey p && is_subkey p -> (top,p,ret p) - _ | isUserID p -> (top,p,ret p) - _ | isTrust p -> (top,sub,updateTrust top sub prev p) - _ -> (top,sub,ret p) - updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public - updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret {- @@ -2292,296 +1273,11 @@ onionName kd = (addr,name) -} -merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] - -> KeyDB -merge_ db filename qs = foldl mergeit db (zip [0..] qs) - where - -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets - mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB - mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db - where - update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty - update (Just kd) = dbInsertPacket kd filename adding - mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p - - whatP (a,_) = concat . take 1 . words . show $ a - - - -mergeKeyData :: KeyData -> KeyData -> KeyData -mergeKeyData (KeyData atop asigs auids asubs) - (KeyData btop bsigs buids bsubs) - = KeyData top sigs uids subs - where - mergeMapped a b = - MappedPacket { packet = packet a - , locations = Map.union (locations a) (locations b) - } - - top = mergeMapped atop btop - - sigs = foldl' (flip mergeSig) asigs bsigs - uids = Map.unionWith mergeUIDSigs auids buids - subs = Map.unionWith mergeSub asubs bsubs - mergeSub :: SubKey -> SubKey -> SubKey - mergeSub (SubKey a as) (SubKey b bs) = - SubKey (mergeMapped a b) - (foldl' (flip mergeSig) as bs) - mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) - -> ([SigAndTrust],OriginMap) - mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) -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) - where - asMapped n p = mappedPacketWithHint filename p n - asSigAndTrust n (p,tm) = (asMapped n p,tm) - - -- 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 - -- later in the file. - -- - -- This is due to the use of statements like - -- (Map.insert filename (origin p n) (locations key)) - -- - update :: Maybe KeyData -> Maybe KeyData - update v | isKey p && not (is_subkey p) - = case v of - Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty - Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p - -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) - sigs - uids - subkeys - _ -> error . concat $ ["Unexpected master key merge error: " - ,show (fingerprint top, fingerprint p)] - update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p - = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) - update (Just (KeyData key sigs uids subkeys)) | isUserID p - = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) - subkeys - update (Just (KeyData key sigs uids subkeys)) - = case sub of - MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys - UserIDPacket {} -> Just $ KeyData key - sigs - (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) - subkeys - _ | isKey sub -> Just $ KeyData key - sigs - uids - (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) - _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) - update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) - - mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey - mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] - mergeSubkey n p (Just (SubKey key sigs)) = Just $ - SubKey (mergeKeyPacket "subs" key $ asMapped n p) - sigs - - mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) - mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) - mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) - mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p - - whatP (a,_) = concat . take 1 . words . show $ a - - - mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m) - mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) - - mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs) - mergeSubSig n sig Nothing = error $ - "Unable to merge subkey signature: "++(words (show sig) >>= take 1) - -mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] -mergeSig sig sigs = - let (xs,ys) = break (isSameSig (first packet sig)) sigs - in if null ys - then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig] - else let y:ys'=ys - in xs ++ (mergeSameSig sig y : ys') - where - isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = - a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } - isSameSig (a,_) (MappedPacket {packet=b},_) = a==b - - mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) - mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) - | isSignaturePacket (packet a) && isSignaturePacket b = - ( m { packet = b { unhashed_subpackets = - union (unhashed_subpackets b) (unhashed_subpackets $ packet a) - } - , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs } - -- TODO: when merging items, we should delete invalidated origins - -- from the orgin map. - , tb `Map.union` ta ) - - mergeSameSig a b = b -- trace ("discarding dup "++show a) b - - -flattenKeys :: Bool -> KeyDB -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - - -data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned - deriving (Eq,Ord,Enum,Show,Read) - -getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet] -getSubkeys ck topk subs tag = do - SubKey k sigs <- Map.elems subs - let subk = packet k - let sigs' = do - -- require tag - torsig <- filter (has_tag tag) $ map (packet . fst) sigs - - -- require parent's signature - when (ck > Unsigned) $ do - sig <- (signatures $ Message [topk,subk,torsig]) - let v = verify (Message [topk]) sig - -- Require parent's signature - guard (not . null $ signatures_over v) - - -- require child's back signature - when (ck == CrossSigned ) $ do - let unhashed = unhashed_subpackets torsig - subsigs = mapMaybe backsig unhashed - -- This should consist only of 0x19 values - -- subtypes = map signature_type subsigs - -- subtyp <- subtypes - -- guard (subtyp == 0x19) - sig' <- signatures . Message $ [topk,subk]++subsigs - let v' = verify (Message [subk]) sig' - -- Require subkey's signature - guard . not . null $ signatures_over v' - return torsig - guard (not $ null sigs') - return subk - --- | --- Returns (ip6 fingerprint address,(onion names,other host names)) --- --- Requires a validly cross-signed tor key for each onion name returned. --- (Signature checks are performed.) -getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) -getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) - where - othernames = do - mp <- flattenAllUids "" True uids - let p = packet mp - guard $ isSignaturePacket p - uh <- unhashed_subpackets p - case uh of - NotationDataPacket True "hostname@" v - -> return $ Char8.pack v - _ -> mzero - - addr = fingerdress topk - -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? - topk = packet topmp - torkeys = getSubkeys CrossSigned topk subs "tor" - - -- subkeyPacket (SubKey k _ ) = k - onames :: [L.ByteString] - onames = map ( (<> ".onion") - . Char8.pack - . take 16 - . torhash ) - torkeys - -hasFingerDress :: KeyDB -> SockAddr -> Bool -hasFingerDress db addr | socketFamily addr/=AF_INET6 = False -hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) - where - (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr - g' = map toUpper g - --- We return into IO in case we want to make a signature here. -setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData -setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = - -- TODO: we are removing the origin from the UID OriginMap, - -- when we should be removing origins from the locations - -- field of the sig's MappedPacket records. - -- Call getHostnames and compare to see if no-op. - if not (pred addr) || names0 == names \\ onions - then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) - , " pred: "++show (pred addr)]) -} - (return kd) - else do - -- We should be sure to remove origins so that the data is written - -- (but only if something changed). - -- Filter all hostnames present in uids - -- Write notations into first uid - {- - trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) - , " file: "++show (map Char8.unpack names) ]) $ do - -} - return $ KeyData topmp topsigs uids1 subs - where - topk = packet topmp - addr = fingerdress topk - names :: [Char8.ByteString] - names = Hosts.namesForAddress addr hosts - (_,(onions,names0)) = getHostnames kd - notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) - isName (NotationDataPacket True "hostname@" _) = True - isName _ = False - uids0 = fmap zapIfHasName uids - fstuid = head $ do - p <- map packet $ flattenAllUids "" True uids - guard $ isUserID p - return $ uidkey p - uids1 = Map.adjust addnames fstuid uids0 - addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin - where - (ss,ts) = splitAt 1 sigs - f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) - else (sig, tm) - where p' = (packet sig) { unhashed_subpackets=uh } - uh = unhashed_subpackets (packet sig) ++ notations - zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin - else (sigs,om) - where - (bs, sigs') = unzip $ map unhash sigs - - unhash (sig,tm) = ( not (null ns) - , ( sig { packet = p', locations = Map.empty } - , tm ) ) - where - psig = packet sig - p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } - else psig - uh = unhashed_subpackets psig - (ns,ps) = partition isName uh - -fingerdress :: Packet -> SockAddr -fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str - where - zero = SockAddrInet 0 0 - addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) - colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs - colons xs = xs - -socketFamily :: SockAddr -> Family -socketFamily (SockAddrInet _ _) = AF_INET -socketFamily (SockAddrInet6 {}) = AF_INET6 -socketFamily (SockAddrUnix _) = AF_UNIX #if ! MIN_VERSION_unix(2,7,0) setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () -- cgit v1.2.3