{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Transforms where import Control.Applicative import Control.Arrow import Control.Monad import Data.Char import Data.Functor import Data.List import Data.Maybe import Data.Ord import Data.OpenPGP import Data.OpenPGP.Util import Data.Word import KeyDB import KeyRing.Types import FunctorToMaybe import GnuPGAgent ( key_nbits ) import PacketTranscoder import TimeUtil import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as S8 import Data.ByteArray.Encoding import qualified Crypto.Hash as Vincent import Data.ByteArray (convert) import Data.ASN1.BinaryEncoding ( DER(..) ) import Data.ASN1.Types (toASN1, ASN1Object, fromASN1, ASN1(Start, End, IntVal), ASN1ConstructionType(Sequence) ) import Data.ASN1.Encoding ( encodeASN1 ) import qualified Data.Text as T ( Text, unpack, pack, strip, reverse, drop, break, dropAround, length ) import Data.Text.Encoding ( encodeUtf8 ) import Data.Bits ((.|.), (.&.), Bits) 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 | SubKeyRenaming String String data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) 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" -- | 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 L.ByteString | DeletedPacket String deriving (Eq,Show) type KikiReport = [ (FilePath, KikiReportAction) ] data UserIDRecord = UserIDRecord { uid_full :: String, uid_realname :: T.Text, uid_user :: T.Text, uid_subdomain :: T.Text, uid_topdomain :: T.Text } deriving Show -- Functions 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 -- | 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 _ = [] -- | 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) 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 } smallpr :: Packet -> [Char] smallpr k = drop 24 $ fingerprint k backsig :: SignatureSubpacket -> Maybe Packet backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing isSubkeySignature :: SignatureOver -> Bool isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False 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)) ] 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 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 [] = [] -} subkeyMappedPacket :: SubKey -> MappedPacket subkeyMappedPacket (SubKey k _ ) = k getBindings :: [Packet] -> ( [([Packet],[SignatureOver])] -- other signatures with key sets -- that were used for the verifications , [(Word8, -- 1-master, 2-subkey, 0-other(see last element of tuple) (Packet, Packet), -- (topkey,subkey) [String], -- usage flags [SignatureSubpacket], -- hashed data [Packet])] -- binding signatures ) getBindings pkts = (sigs,bindings) where (sigs,concat->bindings) = unzip $ do keys <- disjoint_fp (filter isKey pkts) 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 similar 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) 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] keyFlags :: t -> [Packet] -> [SignatureSubpacket] keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 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++")" } | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid -- 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 (usage_tags,flags) of ([],[]) -> "" (_:_,_) -> " "++show usage_tags (_,ts) -> " "++show ts where usage_tags = mapMaybe usage xs flags = mapMaybe (fmap usageString . keyflags) xs xs = hashed_subpackets p showPacket0 :: Show a => a -> [Char] 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 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] 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 keyPacket :: KeyData -> Packet keyPacket (KeyData k _ _ _) = packet k 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 torhash :: Packet -> String torhash key = fromMaybe "" $ derToBase32 <$> derRSA key torUIDFromKey :: Packet -> String torUIDFromKey key = "Anonymous " derToBase32 :: L.ByteString -> String derToBase32 = map toLower . base32 . sha1 where sha1 :: L.ByteString -> S.ByteString sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) base32 = S8.unpack . convertToBase Base32 derRSA :: Packet -> Maybe L.ByteString derRSA rsa = do k <- rsaKeyFromPacket rsa return $ encodeASN1 DER (toASN1 k []) 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 makeSig :: PacketDecrypter -> MappedPacket -> FilePath -> 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 unwrap _ = error "isCreation fail" exp = listToMaybe $ sort $ map unwrap es where unwrap (SignatureExpirationTimePacket x) = x unwrap _ = error "isExpiration fail" 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 -- TODO: Use fingerprint to narrow candidates. candidateSignerKeys :: KeyDB -> Packet -> [Packet] candidateSignerKeys db sig = map keyPacket $ keyData db performManipulations :: (PacketDecrypter) -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) -> IO (KikiCondition (KeyRingRuntime,KikiReport)) performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt r <- transmute perform (manip rt) db return $ r <&> \(db,rs) -> (rt { rtKeyDB = db }, rs) where perform :: (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) perform (kd,report) (InducerSignature uid subpaks) = 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 $ keyData (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig 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 (UidString uid) (keyUids kd) sig <- map (packet . fst) (fst x) o <- overs sig take 1 $ do -- Stop attempting to verify after the first success. 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 (UidString uid) (keyUids kd) }, report ) perform (kd,report) (SubKeyDeletion topk subk) = 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 ]) -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) perform (kd,report) (SubKeyRenaming srctag dsttag) = do flip (maybe $ return NoWorkingKey) wk $ \wk' -> do subkeys' <- traverse (freshenOne wk') (keySubKeys kd) let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport)) succeded (KikiSuccess a) = True succeded _ = False (good,bad) = Map.partition succeded subkeys' uncondition (KikiSuccess a) = a uncondition _ = error "unexpected error" good' = fmap uncondition good if not (Map.null bad) then return $ fmap (error "bad cast") $ head (Map.elems bad) else return $ KikiSuccess ( kd { keySubKeys = fmap fst good' } , report ++ concatMap snd (Map.elems good')) where freshenOne :: MappedPacket -> SubKey -> IO (KikiCondition (SubKey,[(FilePath, KikiReportAction)])) freshenOne wk subkey@(SubKey subkey_p subsigs) = do let (xs',minsig,ys') = findTag [mkUsage srctag] (packet wk) (packet subkey_p) subsigs case minsig of Just (True,sig) -> do let fname = "--rename-subkey" not_deleted p = mkUsage srctag /= p mod sig = sig { hashed_subpackets = filter not_deleted $ hashed_subpackets sig } sig' = first (fmap mod) sig sigr <- makeSig doDecrypt wk fname subkey_p [mkUsage dsttag] (Just sig') try sigr $ \(sig',sigreport) -> do let old = packet (fst sig) report <- return $ fmap (fname,) sigreport ++ [(fname, DeletedPacket (showPacket old)),(fname, YieldSignature)] return $ KikiSuccess $ (SubKey subkey_p $ xs'++[sig']++ys', report) _ -> return $ KikiSuccess (subkey, []) isBracket :: Char -> Bool isBracket '<' = True isBracket '>' = True isBracket _ = False 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 -- | resolveTransform resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops where ops = map (\(UidString u) -> InducerSignature u []) us us = filter torStyle $ Map.keys umap torStyle (UidString 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 4) 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 4) 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 -- TODO: This should warn/fail when there are multiple matches. take 1 $ filter (has_tag tag) $ map (packet . fst) sigs return k -- (4 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform (RenameSubkeys srctag dsttag) rt kd = [SubKeyRenaming srctag dsttag]