{-# 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 qualified IntMapClass as I 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 C 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, breakOn ) import Data.Text.Encoding ( encodeUtf8 ) import Data.Bits ((.|.), (.&.), Bits) import qualified SSHKey as SSH 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 _ = [] matchingGrip :: Packet -> String -> Bool matchingGrip topk g = matchpr 0 g topk == g -- | 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 $ matchingGrip 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 $ show $ 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 :: I.IMap KeyGrip [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) verifyBindings gmap nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do sigs <- signatures (Message nonkeys) sig <- signatures_over sigs let grip = issuerGrip sig gks = concat [ ks | g <- maybeToList grip , ks <- maybeToList $ I.lookup g gmap ] kmsg = Message $ if null gks then maybe (concat $ I.elems gmap) (const []) grip else gks v = verify kmsg (sigs { signatures_over = [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 <- take 1 $ disjoint_fp (filter isKey pkts) let gmap = buildGripMap keys (bs,sigs) = verifyBindings gmap 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 g <- maybeToList $ smallprGrip i who <- take 1 $ concat $ maybeToList $ I.lookup g gmap 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 = show $ 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 -> Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet sigpackets pgpver typ alg hashed unhashed = return $ signaturePacket pgpver -- version typ -- 0x18 subkey binding sig, or 0x19 back-signature alg SHA256 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") ++ " "++show (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 (version wkun) 0x13 (key_algorithm wkun) subpackets subpackets_unh) where subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] tsign ++ extras subpackets_unh = [IssuerPacket (show $ 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 , SHA384 , SHA512 , SHA224 ] preferredcomp = filterOr ispreferedcomp subs $ PreferredCompressionAlgorithmsPacket [ ZLIB , BZip2 , ZIP ] features = filterOr isfeatures subs defaultFeatures 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 (C.hashlazy x :: C.Digest C.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 = show $ 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 = show $ fingerprint (head parsedkey) back_sig <- pgpSign (Message parsedkey) (SubkeySignature wk (head parsedkey) (sigpackets (version $ head parsedkey) 0x19 (key_algorithm $ head parsedkey) hashed0 [IssuerPacket subgrip])) SHA256 subgrip let iss = IssuerPacket (show $ 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 (version wkun) 0x18 (key_algorithm wkun) hashed0 unhashed0)) SHA256 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'] ) SHA256 (show $ fingerprint wk) newsig <- addOrigin new_sig return $ fmap (,[]) newsig -- TODO: Use fingerprint to narrow candidates. candidateSignerKeys :: KeyDB -> Packet -> [Packet] candidateSignerKeys db sig = case issuerGrip sig of Just g -> concatMap (map packet . associatedKeys . snd) $ lookupByGrip g db _ -> map keyPacket $ keyData db issuerGrip :: Packet -> Maybe KeyGrip issuerGrip sig = do IssuerPacket hexfp <- find isIssuer (hashed_subpackets sig ++ unhashed_subpackets sig) smallprGrip hexfp isIssuer :: SignatureSubpacket -> Bool isIssuer (IssuerPacket _) = True isIssuer _ = False 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 SHA256 (show $ 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 (topdomain, subdomain) = case T.breakOn ".ssh-rsa.cryptonomic.net" hostname of (s,".ssh-rsa.cryptonomic.net") -> ("ssh-rsa.cryptonomic.net", s) _ -> (T.reverse *** T.reverse . T.drop 1) $ T.break (=='.') . T.reverse $ hostname selfAuthenticated :: OriginMapped Packet -> KeyData -> UidString -> Bool selfAuthenticated k kd (UidString str) = and [ uid_realname parsed `elem` ["","Anonymous"] , uid_user parsed == "root" , ( uid_topdomain parsed == "onion" && fmap match torSubdom == Just True ) || ( uid_topdomain parsed == "ssh-rsa.cryptonomic.net" && fmap match sshSubdom == Just True ) ] where parsed = parseUID str match = (==subdom) . take (fromIntegral len) len = T.length (uid_subdomain parsed) subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] subdom = Char8.unpack subdom0 keys = map packet $ flattenTop "" True kd torSubdom = fst <$> lookup (packet k) torbindings torbindings = getTorKeys keys sshSubdom = fst <$> lookup (packet k) hostbindings hostbindings = getHostKeys keys getTorKeys :: [Packet] -> [(Packet, (String, Packet))] getTorKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("tor" `elem` us) let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub return (top,(torhash,sub)) getHostKeys :: [Packet] -> [(Packet, (String, Packet))] getHostKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("ssh-host" `elem` us) RSAKey (MPI n) (MPI e) <- maybeToList $ rsaKeyFromPacket sub let blob = SSH.sshrsa e n sha1 = C.hashlazy blob :: C.Digest C.SHA1 subdomain = convertToBase Base16 sha1 return (top,(S8.unpack subdomain,sub)) groupBindings :: [Packet] -> [[(Word8, (Packet, Packet), [String], [SignatureSubpacket], [Packet])]] groupBindings (accBindings . snd . getBindings -> bindings) = gs where 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) -- | 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 (selfAuthenticated k kd) $ Map.keys umap -- (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 == show (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]