path: root/lib/Transforms.hs

{-# LANGUAGE CPP               #-}
{-# 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.List
import Data.Maybe
import Data.Ord
import Data.OpenPGP
import Data.OpenPGP.Util
import Data.Word
import KeyRing.Types
import FunctorToMaybe
import GnuPGAgent ( key_nbits )
import PacketTranscoder
import TimeUtil
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)
#endif
import Data.ASN1.BinaryEncoding ( DER(..) )
import Data.ASN1.Types (toASN1, ASN1Object, fromASN1, ASN1(Start, End, IntVal), ASN1ConstructionType(Sequence) )

import Data.ASN1.Encoding ( encodeASN1 )
import qualified Data.Text as T ( Text, unpack, pack,
        strip, reverse, drop, break, dropAround, length )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Bits              ((.|.), (.&.), Bits)

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

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

splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
splitAtMinBy comp xs = minimumBy comp' xxs
 where
    xxs = zip (inits xs) (tails xs)
    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
    compM (Just a) (Just b) = comp a b
    compM Nothing  mb       = GT
    compM _        _        = LT


-- | Get the time stamp of a signature.
--
-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
-- the hashed section.  TODO: change this?
--
signature_time :: SignatureOver -> Word32
signature_time ov = case (if null cs then ds else cs) of
                                [] -> minBound
                                xs -> maximum xs
          where
            ps = signatures_over ov
            ss = filter isSignaturePacket ps
            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
            creationTime (SignatureCreationTimePacket t) = [t]
            creationTime _                               = []


-- | Given list of subpackets, a master key, one of its subkeys and a
-- list of signatures on that subkey, yields:
--
--   * preceding list of signatures
--
--   * The most recent valid signature made by the master key along with a
--   flag that indicates whether or not all of the supplied subpackets occur in
--   it or, if no valid signature from the working key is present, Nothing.
--
--   * following list of signatures
--
findTag ::
  [SignatureSubpacket]
  -> Packet
  -> Packet
  -> [(MappedPacket, b)]
  -> ([(MappedPacket, b)],
      Maybe (Bool, (MappedPacket, b)),
      [(MappedPacket, b)])
findTag tag topk subkey subsigs = (xs',minsig,ys')
         where
            vs = map (\sig ->
                          (sig, do
                                sig <- Just (packet . fst $ sig)
                                guard (isSignaturePacket sig)
                                guard $ flip isSuffixOf
                                             (fingerprint topk)
                                        . fromMaybe "%bad%" 
                                        . signature_issuer
                                        $ sig
                                listToMaybe $
                                  map (signature_time . verify (Message [topk]))
                                      (signatures $ Message [topk,subkey,sig])))
                     subsigs
            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
            xs' = map fst xs
            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
            minsig = do
                (sig,ov) <- listToMaybe ys
                ov
                let hshed = hashed_subpackets $ packet $ fst sig
                return ( null $ tag \\ hshed, sig)

mkUsage :: String -> SignatureSubpacket
mkUsage tag | Just flags <- lookup tag specials
  = KeyFlagsPacket
        { certify_keys          = fromEnum flags .&. 0x1 /= 0
        , sign_data             = fromEnum flags .&. 0x2 /= 0
        , encrypt_communication = fromEnum flags .&. 0x4 /= 0
        , encrypt_storage       = fromEnum flags .&. 0x8 /= 0
        , split_key             = False
        , authentication        = False
        , group_key             = False
        }
 where
    flagsets = [Special .. VouchSignEncrypt]
    specials = map (\f -> (usageString f, f)) flagsets
mkUsage tag = NotationDataPacket
                { human_readable = True
                , notation_name  = "usage@"
                , notation_value = tag
                }


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 :: Packet -> [Char]
smallpr k = drop 24 $ fingerprint k

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


isSubkeySignature :: SignatureOver -> Bool
isSubkeySignature (SubkeySignature {}) = True
isSubkeySignature _                    = False


has_tag :: String -> Packet -> Bool
has_tag tag p = isSignaturePacket p
                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]



verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
 where
    verified = do
        sig <- signatures (Message nonkeys)
        let v = verify (Message keys) sig
        guard (not . null $ signatures_over v)
        return v
    (top,othersigs) = partition isSubkeySignature verified
    embedded = do
        sub <- top
        let sigover = signatures_over sub
            unhashed = sigover >>= unhashed_subpackets
            subsigs = mapMaybe backsig unhashed
            -- This should consist only of 0x19 values
            -- subtypes = map signature_type subsigs
        -- trace ("subtypes = "++show subtypes) (return ())
        -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
        let v = verify (Message [subkey sub]) sig
        guard (not . null $ signatures_over v)
        return v

disjoint_fp :: [Packet] -> [[Packet]]
disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
 where
    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
    samepr a b = smallpr a == smallpr b

    {-
    -- useful for testing
    group2 :: [a] -> [[a]]
    group2 (x:y:ys) = [x,y]:group2 ys
    group2 [x]      = [[x]]
    group2 []       = []
    -}



subkeyMappedPacket :: SubKey -> MappedPacket
subkeyMappedPacket (SubKey k _ ) = k

getBindings ::
  [Packet]
  ->
    ( [([Packet],[SignatureOver])] --  other signatures with key sets
                                   --  that were used for the verifications
    , [(Word8,               -- 1-master, 2-subkey, 0-other(see last element of tuple)
       (Packet, Packet),     -- (topkey,subkey)
       [String],             -- usage flags
       [SignatureSubpacket], -- hashed data
       [Packet])]            -- binding signatures
    )
getBindings pkts = (sigs,bindings)
 where
    (sigs,concat->bindings) = unzip $ do
        keys <- disjoint_fp (filter isKey pkts)
        let (bs,sigs) = verifyBindings keys pkts
        return . ((keys,sigs),) $ do
            b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
            i <- map signature_issuer (signatures_over b)
            i <- maybeToList i
            who <- maybeToList $ find_key fingerprint (Message keys) i
            let (code,claimants) =
                    case () of
                        _ | who == topkey b -> (1,[])
                        _ | who == subkey b -> (2,[])
                        _                   -> (0,[who])
            let hashed = signatures_over b >>= hashed_subpackets
                kind = guard (code==1) >> hashed >>= maybeToList . usage
            return (code,(topkey b,subkey b), kind, hashed,claimants)


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

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 (usage_tags,flags) of
            ([],[]) -> ""
            (_:_,_) -> " "++show usage_tags
            (_,ts)  -> " "++show ts
     where
        usage_tags = mapMaybe usage xs
        flags = mapMaybe (fmap usageString . keyflags) xs
        xs = hashed_subpackets p

showPacket0 :: Show a => a -> [Char]
showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
 where
    dropSuffix :: String -> String -> String
    dropSuffix _    [] = ""
    dropSuffix suff (x:xs) | (x:xs)==suff = ""
                           | otherwise    = x:dropSuffix suff xs



makeInducerSig
  :: Packet
     -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
-- torsig g topk wkun uid timestamp extras = todo
makeInducerSig topk wkun uid extras
    = CertificationSignature (secretToPublic topk)
                             uid
                             (sigpackets 0x13
                                         subpackets
                                         subpackets_unh)
   where
    subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
                 tsign
                 ++ extras
    subpackets_unh = [IssuerPacket (fingerprint wkun)]
    tsign = if keykey wkun == keykey topk
             then [] -- tsign doesnt make sense for self-signatures
             else [ TrustSignaturePacket 1 120
                  , RegularExpressionPacket regex]
    -- <[^>]+[@.]asdf\.nowhere>$
    regex = "<[^>]+[@.]"++hostname++">$"
    -- regex = username ++ "@" ++ hostname
    -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
    hostname = subdomain' pu ++ "\\." ++ topdomain' pu
    pu = parseUID uidstr where UserIDPacket uidstr = uid
    subdomain' = escape . T.unpack . uid_subdomain
    topdomain' = escape . T.unpack . uid_topdomain
    escape s = concatMap echar s
      where
        echar '|' = "\\|"
        echar '*' = "\\*"
        echar '+' = "\\+"
        echar '?' = "\\?"
        echar '.' = "\\."
        echar '^' = "\\^"
        echar '$' = "\\$"
        echar '\\' = "\\\\"
        echar '[' = "\\["
        echar ']' = "\\]"
        echar c = [c]


keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
keyFlags0 wkun uidsigs = concat
                      [ keyflags
                      , preferredsym
                      , preferredhash
                      , preferredcomp
                      , features ]
 where
    subs = concatMap hashed_subpackets uidsigs
    keyflags = filterOr isflags subs $
               KeyFlagsPacket { certify_keys = True
                              , sign_data = True
                              , encrypt_communication = False
                              , encrypt_storage = False
                              , split_key = False
                              , authentication = False
                              , group_key = False
                              }
    preferredsym = filterOr ispreferedsym subs $
               PreferredSymmetricAlgorithmsPacket
                              [ AES256
                              , AES192
                              , AES128
                              , CAST5
                              , TripleDES
                              ]
    preferredhash = filterOr ispreferedhash subs $
               PreferredHashAlgorithmsPacket
                              [ SHA256
                              , SHA1
                              , SHA384
                              , SHA512
                              , SHA224
                              ]
    preferredcomp = filterOr ispreferedcomp subs $
               PreferredCompressionAlgorithmsPacket
                              [ ZLIB
                              , BZip2
                              , ZIP
                              ]
    features = filterOr isfeatures subs $
               FeaturesPacket { supports_mdc = True
                              }

    filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs

    isflags (KeyFlagsPacket {}) = True
    isflags _ = False
    ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
    ispreferedsym _ = False
    ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
    ispreferedhash _ = False
    ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
    ispreferedcomp _ = False
    isfeatures (FeaturesPacket {}) = True
    isfeatures _ = False



keyPacket :: KeyData -> Packet
keyPacket (KeyData k _ _ _) = packet k


rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
rsaKeyFromPacket p | isKey p = do
    n <- lookup 'n' $ key p
    e <- lookup 'e' $ key p
    return $ RSAKey n e
rsaKeyFromPacket _ = Nothing


torhash :: Packet -> String
torhash key = fromMaybe "" $ derToBase32 <$> derRSA key

torUIDFromKey :: Packet -> String
torUIDFromKey key = "Anonymous <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

makeSig ::
  PacketDecrypter
  -> MappedPacket
  -> FilePath
  -> MappedPacket
  -> [SignatureSubpacket]
  -> Maybe (MappedPacket, Map.Map k a)
  -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
makeSig doDecrypt top fname subkey_p tags mbsig = do
    let wk = packet top
    wkun <- doDecrypt top
    try wkun $ \wkun -> do
    let grip = fingerprint wk
        addOrigin new_sig =
            flip (maybe $ return FailedToMakeSignature)
                 (new_sig >>= listToMaybe . signatures_over)
                 $ \new_sig -> do
            let mp' = mappedPacket fname new_sig
            return $ KikiSuccess (mp', Map.empty)
        parsedkey = [packet subkey_p]
        hashed0 | any isFlagsPacket tags = tags
                | otherwise
                  = KeyFlagsPacket
                    { certify_keys = False
                    , sign_data = False
                    , encrypt_communication = False
                    , encrypt_storage = False
                    , split_key = False
                    , authentication = True
                    , group_key = False }
                    : tags
                    -- implicitly added:
                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
        isFlagsPacket (KeyFlagsPacket {}) = True
        isFlagsPacket _                   = False
        subgrip = fingerprint (head parsedkey)

    back_sig <- pgpSign (Message parsedkey)
                        (SubkeySignature wk
                                         (head parsedkey)
                                         (sigpackets 0x19
                                                     hashed0
                                                     [IssuerPacket subgrip]))
                        (if key_algorithm (head parsedkey)==ECDSA
                            then SHA256
                            else SHA1)
                        subgrip
    let iss = IssuerPacket (fingerprint wk)
        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
        unhashed0 = maybe [iss] cons_iss back_sig

    new_sig <- pgpSign (Message [wkun])
                       (SubkeySignature wk
                                        (head parsedkey)
                                        (sigpackets 0x18
                                                   hashed0
                                                   unhashed0))
                      SHA1
                      grip
    let newSig = do
            r <- addOrigin new_sig
            return $ fmap (,[]) r
    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
    let sig = packet mp
        isCreation (SignatureCreationTimePacket {}) = True
        isCreation _ = False
        isExpiration (SignatureExpirationTimePacket {}) = True
        isExpiration _ = False
        (cs,ps) = partition isCreation (hashed_subpackets sig)
        (es,qs) = partition isExpiration ps
        stamp = listToMaybe . sortBy (comparing Down) $
                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
        exp = listToMaybe $ sort $
                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
        expires = liftA2 (+) stamp exp
    timestamp <- now
    if fmap ( (< timestamp) . fromIntegral) expires == Just True then
        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
    else do
        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
                        $ maybeToList $ do
                            e <- expires
                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
            sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
        new_sig <- pgpSign (Message [wkun])
                           (SubkeySignature wk
                                            (packet subkey_p)
                                            [sig'] )
                           SHA1
                           (fingerprint wk)
        newsig <- addOrigin new_sig
        return $ fmap (,[]) newsig




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

    -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
    perform kd (SubKeyRenaming srctag dsttag) = do
        try kd $ \(kd,report) -> do
        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
        subkeys' <- traverse (freshenOne wk') (keySubKeys kd)
        let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport))
            succeded (KikiSuccess a) = True
            succeded _               = False
            (good,bad) = Map.partition succeded subkeys'
            uncondition (KikiSuccess a) = a
            uncondition _               = error "unexpected error"
            good' = fmap uncondition good
        if not (Map.null bad)
            then return $ fmap (error "bad cast") $ head (Map.elems bad)
            else return $ KikiSuccess ( kd { keySubKeys = fmap fst good' }
                                      , report ++ concatMap snd (Map.elems good'))
     where
        freshenOne :: MappedPacket -> SubKey -> IO (KikiCondition (SubKey,[(FilePath, KikiReportAction)]))
        freshenOne wk subkey@(SubKey subkey_p subsigs) = do
            let (xs',minsig,ys') = findTag [mkUsage srctag] (packet wk) (packet subkey_p) subsigs
            case minsig of
                Just (True,sig) -> do
                    let fname = "--rename-subkey"
                        not_deleted p = mkUsage srctag /= p
                        mod sig = sig { hashed_subpackets = filter not_deleted $ hashed_subpackets sig }
                        sig' = first (fmap mod) sig
                    sigr <- makeSig doDecrypt wk fname subkey_p [mkUsage dsttag] (Just sig')
                    try sigr $ \(sig',sigreport) -> do
                    let old = packet (fst sig)
                    report <- return $ fmap (fname,) sigreport ++ [(fname, DeletedPacket (showPacket old)),(fname, YieldSignature)]
                    return $ KikiSuccess $ (SubKey subkey_p $ xs'++[sig']++ys', report)
                _ -> return $ KikiSuccess (subkey, [])


isBracket :: Char -> Bool
isBracket '<' = True
isBracket '>' = True
isBracket _   = False


parseUID :: String -> UserIDRecord
parseUID str = UserIDRecord {
                    uid_full = str,
                    uid_realname = realname,
                    uid_user = user,
                    uid_subdomain = subdomain,
                    uid_topdomain = topdomain
                }
 where
    text = T.pack str
    (T.strip-> realname, T.dropAround isBracket-> email)
                              = T.break (=='<') text
    (user, T.drop 1-> hostname) = T.break (=='@') email
    ( T.reverse            -> topdomain,
      T.reverse . T.drop 1 -> subdomain)
                              = T.break (=='.') . T.reverse $ hostname

-- | resolveTransform
resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
 where
    ops = map (\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 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
 where
    topk = keykey $ packet k -- key to master of key to be deleted
    subk = do
        (k,sub) <- Map.toList submap
        guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
        return k

-- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
 where
    topk = keykey $ packet k -- key to master of key to be deleted
    subk = do
        (k,SubKey p sigs) <- Map.toList submap
        -- TODO: This should warn/fail when there are multiple matches.
        take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
        return k

-- (4 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
resolveTransform (RenameSubkeys srctag dsttag) rt kd = [SubKeyRenaming srctag dsttag]