path: root/lib/Transforms.hs

{-# 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 _                               = []


-- | 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
                                             (show $ 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 $ 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 -> [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")
                           ++ " "++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 0x13
                                         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 $
               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
   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 0x19
                                                     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 0x18
                                                   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) $ 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]