Factored Transforms out of goliath KeyRing module.

1 files changed, 738 insertions, 0 deletions

diff --git a/lib/Transforms.hs b/lib/Transforms.hs
new file mode 100644
index 0000000..093d594
--- /dev/null
+++ b/lib/Transforms.hs
@@ -0,0 +1,738 @@
+{-# 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
+