From fae3728a6b7e8ee13ed009e7c9cf3918eb4b89d7 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 30 Aug 2016 21:01:56 -0400 Subject: Factored Transforms out of goliath KeyRing module. --- lib/KeyRing.hs | 663 +-------------------------------------------------------- 1 file changed, 1 insertion(+), 662 deletions(-) (limited to 'lib/KeyRing.hs') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 5953f12..bb32a2e 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -216,6 +216,7 @@ import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import GnuPGAgent as Agent import Types import PacketTranscoder +import Transforms -- DER-encoded elliptic curve ids -- nistp256_id = 0x2a8648ce3d030107 @@ -284,33 +285,6 @@ usageFromFilter (KF_Match usage) = return usage usageFromFilter _ = mzero -data KeyRingRuntime = KeyRingRuntime - { rtPubring :: FilePath - -- ^ Path to the file represented by 'HomePub' - , rtSecring :: FilePath - -- ^ Path to the file represented by 'HomeSec' - , rtGrip :: Maybe String - -- ^ Fingerprint or portion of a fingerprint used - -- to identify the working GnuPG identity used to - -- make signatures. - , rtWorkingKey :: Maybe Packet - -- ^ The master key of the working GnuPG identity. - , rtKeyDB :: KeyDB - -- ^ The common information pool where files spilled - -- their content and from which they received new - -- content. - , rtRingAccess :: Map.Map InputFile Access - -- ^ The 'Access' values used for files of type - -- 'KeyRingFile'. If 'AutoAccess' was specified - -- for a file, this 'Map.Map' will indicate the - -- detected value that was used by the algorithm. - , rtPassphrases :: PacketTranscoder - } - --- | Roster-entry level actions -data PacketUpdate = InducerSignature String [SignatureSubpacket] - | SubKeyDeletion KeyKey KeyKey - filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] filesToLock k ctx = do @@ -323,26 +297,11 @@ filesToLock k ctx = do -- kret :: a -> KeyRingOperation a -- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) -data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey pkcs8 (RSAKey n e) = RSAKey8 n e -instance ASN1Object RSAPublicKey where - -- PKCS #1 RSA Public Key - toASN1 (RSAKey (MPI n) (MPI e)) - = \xs -> Start Sequence - : IntVal n - : IntVal e - : End Sequence - : xs - fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) = - Right (RSAKey (MPI n) (MPI e), xs) - - fromASN1 _ = - Left "fromASN1: RSAPublicKey: unexpected format" - instance ASN1Object PKCS8_RSAPublicKey where -- PKCS #8 Public key data @@ -450,32 +409,6 @@ instance ASN1Object RSAPrivateKey where --- | This type is used to describe events triggered by 'runKeyRing'. In --- addition to normal feedback (e.g. 'NewPacket'), it also may indicate --- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a --- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with --- many inputs and outputs, an operation may be partially (or even mostly) --- successful even when I/O failures occured. In this situation, the files may --- not have all the information they were intended to store, but they will be --- in a valid format for GnuPG or kiki to operate on in the future. -data KikiReportAction = - NewPacket String - | MissingPacket String - | ExportedSubkey - | GeneratedSubkeyFile - | NewWalletKey String - | YieldSignature - | YieldSecretKeyPacket String - | UnableToUpdateExpiredSignature - | WarnFailedToMakeSignature - | FailedExternal Int - | ExternallyGeneratedFile - | UnableToExport KeyAlgorithm String - | FailedFileWrite - | HostsDiff ByteString - | DeletedPacket String - deriving (Eq,Show) - uncamel :: String -> String uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args where @@ -501,23 +434,6 @@ data KikiResult a = KikiResult -- along with the files that triggered them. } -type KikiReport = [ (FilePath, KikiReportAction) ] - -keyPacket :: KeyData -> Packet -keyPacket (KeyData k _ _ _) = packet k - -subkeyMappedPacket :: SubKey -> MappedPacket -subkeyMappedPacket (SubKey k _ ) = k - - -usage :: SignatureSubpacket -> Maybe String -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - x509cert :: SignatureSubpacket -> Maybe Char8.ByteString x509cert (NotationDataPacket { human_readable = False @@ -526,167 +442,7 @@ x509cert (NotationDataPacket }) = Just (Char8.pack u) x509cert _ = Nothing -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] - - -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 - - -data PGPKeyFlags = - Special - | Vouch -- 0001 C -- Signkey - | Sign -- 0010 S - | VouchSign -- 0011 - | Communication -- 0100 E - | VouchCommunication -- 0101 - | SignCommunication -- 0110 - | VouchSignCommunication -- 0111 - | Storage -- 1000 E - | VouchStorage -- 1001 - | SignStorage -- 1010 - | VouchSignStorage -- 1011 - | Encrypt -- 1100 E - | VouchEncrypt -- 1101 - | SignEncrypt -- 1110 - | VouchSignEncrypt -- 1111 - deriving (Eq,Show,Read,Enum) - - -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" - - - - -keyFlags :: t -> [Packet] -> [SignatureSubpacket] -keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) - -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 matchSpec :: KeySpec -> KeyData -> Bool @@ -710,36 +466,6 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us where us = filter (isInfixOf pat) $ Map.keys uids -data UserIDRecord = UserIDRecord { - uid_full :: String, - uid_realname :: T.Text, - uid_user :: T.Text, - uid_subdomain :: T.Text, - uid_topdomain :: T.Text -} - deriving Show - -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 -isBracket :: Char -> Bool -isBracket '<' = True -isBracket '>' = True -isBracket _ = False - @@ -1532,32 +1258,6 @@ generateInternals transcode mwk db gens = do return $ KikiSuccess (Map.insert kk kd db,reportGens) Nothing -> return $ KikiSuccess (db,[]) -torhash :: Packet -> String -torhash key = fromMaybe "" $ derToBase32 <$> derRSA key - -torUIDFromKey :: Packet -> String -torUIDFromKey key = "Anonymous " - -derToBase32 :: ByteString -> String -derToBase32 = map toLower . base32 . sha1 - where - sha1 :: L.ByteString -> S.ByteString -#if !defined(VERSION_cryptonite) - sha1 = SHA1.hashlazy -#else - sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) -#endif -#if defined(VERSION_memory) - base32 = S8.unpack . convertToBase Base32 -#elif defined(VERSION_dataenc) - base32 = Base32.encode . S.unpack -#endif - -derRSA :: Packet -> Maybe ByteString -derRSA rsa = do - k <- rsaKeyFromPacket rsa - return $ encodeASN1 DER (toASN1 k []) - unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do r <- action @@ -1565,13 +1265,6 @@ unconditionally action = do KikiSuccess x -> return x e -> error $ errorString e -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 - - data ParsedCert = ParsedCert { pcertKey :: Packet , pcertTimestamp :: UTCTime @@ -1982,42 +1675,6 @@ writeWalletKeys krd db wk = do report <- foldM writeWallet [] (files isMutableWallet) return $ KikiSuccess report -ifSecret :: Packet -> t -> t -> t -ifSecret (SecretKeyPacket {}) t f = t -ifSecret _ t f = f - -showPacket :: Packet -> String -showPacket p | isKey p = (if is_subkey p - then showPacket0 p - else ifSecret p "---Secret" "---Public") - ++ " "++fingerprint p - ++ " "++show (key_algorithm p) - ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } - | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) - -- | isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p) - | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p - | otherwise = showPacket0 p - where - sigusage p = - case take 1 (tagStrings p) of - [] -> "" - tag:_ -> " "++show tag -- "("++tag++")" - where - tagStrings p = usage_tags ++ flags - where - usage_tags = mapMaybe usage xs - flags = mapMaybe (fmap usageString . keyflags) xs - xs = hashed_subpackets p - - -showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) - where - dropSuffix :: String -> String -> String - dropSuffix _ [] = "" - dropSuffix suff (x:xs) | (x:xs)==suff = "" - | otherwise = x:dropSuffix suff xs - - -- | returns Just True so as to indicate that -- the public portions of keys will be imported importPublic :: Maybe Bool @@ -2312,75 +1969,6 @@ writePEMKeys doDecrypt db exports = do try pun $ \pun -> do return $ KikiSuccess (fname,stream,pun) -performManipulations :: - (PacketDecrypter) - -> 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 ]) - initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext @@ -2503,150 +2091,7 @@ combineTransforms trans rt kd = updates concatMap (\t -> resolveTransform t rt kd) sanitized sanitized = group (sort trans) >>= take 1 -isSubkeySignature (SubkeySignature {}) = True -isSubkeySignature _ = False - --- 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) - - - -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 - -smallpr k = drop 24 $ fingerprint k - -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 [] = [] - -} - -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) - --- | 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 -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) @@ -2790,36 +2235,6 @@ lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif -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] - -secretToPublic :: Packet -> Packet -secretToPublic pkt@(SecretKeyPacket {}) = - PublicKeyPacket { version = version pkt - , timestamp = timestamp pkt - , key_algorithm = key_algorithm pkt - -- , ecc_curve = ecc_curve pkt - , key = let seckey = key pkt - pubs = public_key_fields (key_algorithm pkt) - in filter (\(k,v) -> k `elem` pubs) seckey - , is_subkey = is_subkey pkt - , v3_days_of_validity = Nothing - } -secretToPublic pkt = pkt - - - slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) slurpWIPKeys stamp "" = ([],[]) slurpWIPKeys stamp cs = @@ -2878,14 +2293,6 @@ decode_btc_key timestamp str = do , is_subkey = True } -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 - readPacketsFromWallet :: Maybe Packet @@ -3111,26 +2518,6 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do newsig <- addOrigin new_sig return $ fmap (,[]) newsig - -type TrustMap = Map.Map FilePath Packet -type SigAndTrust = ( MappedPacket - , TrustMap ) -- trust packets - -data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show - --- | This is a GPG Identity which includes a master key and all its UIDs and --- subkeys and associated signatures. -data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key - , keySigAndTrusts :: [SigAndTrust] -- sigs on main key - , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids - , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys - } deriving Show - -type KeyDB = Map.Map KeyKey KeyData - -uidkey :: Packet -> String -uidkey (UserIDPacket str) = str - merge :: KeyDB -> InputFile -> Message -> KeyDB merge db inputfile (Message ps) = merge_ db filename qs where @@ -3298,24 +2685,6 @@ mergeSig sig sigs = mergeSameSig a b = b -- trace ("discarding dup "++show a) b -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) } - -concatSort :: - FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] -concatSort fname getp f = concat . sortByHint fname getp . map f - -sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] -sortByHint fname f = sortBy (comparing gethint) - where - gethint = maybe defnum originalNum . Map.lookup fname . locations . f - defnum = -1 - flattenKeys :: Bool -> KeyDB -> Message flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) where @@ -3329,27 +2698,6 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl isSecret _ = False -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)) - -flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] -flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs - -unk :: Bool -> MappedPacket -> MappedPacket -unk isPublic = if isPublic then toPacket secretToPublic else id - where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} - -flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] -flattenAllUids fname ispub uids = - concatSort fname head (flattenUid fname ispub) (Map.assocs uids) - -flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] -flattenUid fname ispub (str,(sigs,om)) = - (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs - data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned deriving (Eq,Ord,Enum,Show,Read) @@ -3384,11 +2732,6 @@ getSubkeys ck topk subs tag = do guard (not $ null sigs') return subk -has_tag tag p = isSignaturePacket p - && or [ tag `elem` mapMaybe usage (hashed_subpackets p) - , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] - - -- | -- Returns (ip6 fingerprint address,(onion names,other host names)) -- @@ -3494,10 +2837,6 @@ fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs colons xs = xs -backsig :: SignatureSubpacket -> Maybe Packet -backsig (EmbeddedSignaturePacket s) = Just s -backsig _ = Nothing - socketFamily :: SockAddr -> Family socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 {}) = AF_INET6 -- cgit v1.2.3