path: root/lib/Transforms.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Transforms where

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Ord
import Data.OpenPGP
import Data.OpenPGP.Util
import Data.Word (Word8)
import Types
import FunctorToMaybe
import GnuPGAgent ( key_nbits )
import PacketTranscoder
import qualified Data.Traversable as Traversable
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
#if defined(VERSION_memory)
import qualified Data.ByteString.Char8 as S8
import Data.ByteArray.Encoding
#elif defined(VERSION_dataenc)
import qualified Codec.Binary.Base32 as Base32
import qualified Codec.Binary.Base64 as Base64
#endif
#if !defined(VERSION_cryptonite)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Types.PubKey.ECC as ECC
#else
import qualified Crypto.Hash as Vincent
import Data.ByteArray (convert)
import qualified Crypto.PubKey.ECC.Types as ECC
#endif
import Data.ASN1.BinaryEncoding ( DER(..) )
import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
       , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
import qualified Data.Text as T ( Text, unpack, pack,
        strip, reverse, drop, break, dropAround, length )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Bits              ( (.|.), (.&.), Bits, shiftR )

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



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

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

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)



-- Functions

unk :: Bool -> MappedPacket -> MappedPacket
unk isPublic = if isPublic then toPacket secretToPublic else id
                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}


unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
unsig fname isPublic (sig,trustmap) =
    sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
  where
    f n _ = n==fname -- && trace ("fname=n="++show n) True
    asMapped n p = let m = mappedPacket fname p
                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }

smallpr k = drop 24 $ fingerprint k

backsig :: SignatureSubpacket -> Maybe Packet
backsig (EmbeddedSignaturePacket s) = Just s
backsig _                           = Nothing


isSubkeySignature (SubkeySignature {}) = True
isSubkeySignature _                    = False


has_tag tag p = isSignaturePacket p
                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]



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 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,
       (Packet, Packet), -- (topkey,subkey)
       [String],         -- usage flags
       [SignatureSubpacket], -- hashed data
       [Packet])] -- binding signatures
    )
getBindings pkts = (sigs,bindings)
 where
    (sigs,concat->bindings) = unzip $ do
        let (keys,_) = partition isKey pkts
        keys <- disjoint_fp keys
        let (bs,sigs) = verifyBindings keys pkts
        return . ((keys,sigs),) $ do
            b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
            i <- map signature_issuer (signatures_over b)
            i <- maybeToList i
            who <- maybeToList $ find_key fingerprint (Message keys) i
            let (code,claimants) =
                    case () of
                        _ | who == topkey b -> (1,[])
                        _ | who == subkey b -> (2,[])
                        _                   -> (0,[who])
            let hashed = signatures_over b >>= hashed_subpackets
                kind = guard (code==1) >> hashed >>= maybeToList . usage
            return (code,(topkey b,subkey b), kind, hashed,claimants)


-- Returned data is simmilar to getBindings but the Word8 codes
-- are ORed together.
accBindings ::
  Bits t =>
  [(t, (Packet, Packet), [a], [a1], [a2])]
  -> [(t, (Packet, Packet), [a], [a1], [a2])]
accBindings bs = as
  where
    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
    as = map (foldl1 combine) gs
    bindingPair (_,p,_,_,_) = pub2 p
      where
        pub2 (a,b) = (pub a, pub b)
        pub a = fingerprint_material a
    samePair a b = bindingPair a == bindingPair b
    combine (ac,p,akind,ahashed,aclaimaints)
            (bc,_,bkind,bhashed,bclaimaints)
        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)

sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
sortByHint fname f = sortBy (comparing gethint)
  where
    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
    defnum = -1

concatSort ::
  FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
concatSort fname getp f = concat . sortByHint fname getp . map f

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

flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs

flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
flattenAllUids fname ispub uids =
    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)

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))


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)

-- XXX keyFlags and keyflags are different functions.
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



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



uidkey :: Packet -> String
uidkey (UserIDPacket str) = str

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"



usage :: SignatureSubpacket -> Maybe String
usage (NotationDataPacket
        { human_readable = True
        , notation_name  = "usage@"
        , notation_value = u
        }) = Just u
usage _    = Nothing


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



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 <root@" ++ take 16 (torhash key) ++ ".onion>"

derToBase32 :: L.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 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




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 ])

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 (\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
        -- TODO: This should warn/fail when there are multiple matches.
        take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
        return k