path: root/KeyRing.hs

---------------------------------------------------------------------------
-- |
-- Module      :  KeyRing
--
-- Maintainer  :  joe@jerkface.net
-- Stability   :  experimental
--
-- kiki is a command-line utility for manipulating GnuPG's keyring files.  This
-- module is the programmer-facing API it uses to do that.
--
-- Note: This is *not* a public facing API. I (the author) consider this
-- library to be internal to kiki and subject to change at my whim.
--
-- Typically, a client to this module would prepare a 'KeyRingOperation'
-- describing what he wants done, and then invoke 'runKeyRing' to make it
-- happen.
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE NoPatternGuards #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module KeyRing
    (
    -- * Error Handling
      KikiResult(..)
    , KikiCondition(..)
    , KikiReportAction(..)
    , errorString
    , reportString
    -- * Manipulating Keyrings
    , runKeyRing
    , KeyRingOperation(..)
    , PassphraseSpec(..)
    , Transform(..)
    -- , PacketUpdate(..)
    -- , guardAuthentic
    -- * Describing File Operations
    , StreamInfo(..)
    , Access(..)
    , FileType(..)
    , InputFile(..)
    , KeyFilter(..)
    -- * Results of a KeyRing Operation
    , KeyRingRuntime(..)
    , KeyDB
    , KeyData(..)
    , SubKey(..)
    , packet
    , locations
    , keyflags
    -- * Miscelaneous Utilities
    , isKey
    , derRSA
    , derToBase32
    , backsig
    , filterMatches
    , flattenKeys
    , flattenTop
    , Hosts.Hosts
    , isCryptoCoinKey
    , matchpr
    , parseSpec
    , parseUID
    , UserIDRecord(..)
    , pkcs8
    , RSAPublicKey(..)
    , PKCS8_RSAPublicKey(..)
    , rsaKeyFromPacket
    , secretToPublic
    , selectPublicKey
    , selectSecretKey
    , usage
    , usageString
    , walletImportFormat
    , writePEM
    , getBindings
    , accBindings
    , isSubkeySignature
    , torhash
    , ParsedCert(..)
    , parseCertBlob
    , packetFromPublicRSAKey
    , decodeBlob
    , selectPublicKeyAndSigs
    , x509cert
    , getHomeDir
    , unconditionally
    , SecretPEMData(..)
    , readSecretPEMFile
    , writeInputFileL
    , InputFileContext(..)
    , onionNameForContact
    , keykey
    , keyPacket
    , KeySpec(..)
    , getHostnames
    ) where

import System.Environment
import Control.Monad
import Data.Maybe
import Data.Either
import Data.Char
import Data.Ord
import Data.List
import Data.OpenPGP
import Data.Functor
import Data.Monoid
import Data.Tuple             ( swap )
import Data.Bits              ( (.|.), (.&.) )
import Control.Applicative    ( Applicative, pure, liftA2, (<*>) )
import System.Directory       ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
import Control.Arrow          ( first, second )
import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
import Data.ByteString.Lazy   ( ByteString )
import Text.Show.Pretty as PP ( ppShow )
import Data.Binary {- decode, decodeOrFail -}
import ControlMaybe ( handleIO_ )
import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
       , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
import Data.ASN1.BitArray ( BitArray(..), toBitArray )
import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
import Data.ASN1.BinaryEncoding ( DER(..) )
import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
import Data.Time.Clock ( UTCTime )
import Data.Bits ( Bits, shiftR )
import Data.Text.Encoding ( encodeUtf8 )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
        , index, break, pack )
import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr, singleton, unfoldr, reverse )
import qualified Codec.Binary.Base32 as Base32
import qualified Codec.Binary.Base64 as Base64
#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 qualified Data.X509 as X509
import qualified Crypto.PubKey.RSA as RSA
import qualified Codec.Compression.GZip as GZip
import qualified Data.Text as T ( Text, unpack, pack,
        strip, reverse, drop, break, dropAround, length )
import qualified System.Posix.Types as Posix
import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
        , setFileCreationMask, setFileTimes )
#if MIN_VERSION_x509(1,5,0)
import Data.Hourglass.Types
import Data.Hourglass
#endif
#if MIN_VERSION_unix(2,7,0)
import System.Posix.Files ( setFdTimesHiRes )
import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
#else
import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
import Foreign.Marshal.Array ( withArray )
import Foreign.Ptr
import Foreign.C.Error ( throwErrnoIfMinus1_ )
import Foreign.Storable
#endif
import System.FilePath ( takeDirectory )
import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr)
import Data.IORef
import System.Posix.IO ( fdToHandle )
import qualified Data.Traversable as Traversable
import Data.Traversable ( sequenceA )
#if ! MIN_VERSION_base(4,6,0)
import GHC.Exts ( Down(..) )
#endif
#if MIN_VERSION_binary(0,7,0)
import Debug.Trace
#endif
import Network.Socket -- (SockAddr)
import qualified Data.ByteString.Lazy.Char8 as Char8
import Compat

import TimeUtil
import PEM
import ScanningParser
import qualified Hosts
import qualified CryptoCoins
import Base58
import FunctorToMaybe
import DotLock
import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )

-- DER-encoded elliptic curve ids
-- nistp256_id  = 0x2a8648ce3d030107
secp256k1_id :: Integer
secp256k1_id = 0x2b8104000a
-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
{-     OID                  Curve description              Curve name
    ----------------------------------------------------------------   
    1.2.840.10045.3.1.7  NIST Curve P-256 [FIPS 186-2]  "NIST P-256"
    1.3.132.0.34         NIST Curve P-384 [FIPS 186-2]  "NIST P-384"  
    1.3.132.0.35         NIST Curve P-521 [FIPS 186-2]  "NIST P-521"  

    Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
    P-521".  The hexadecimal representation used in the public and
    private key encodings are:

    Curve Name   Len  Hexadecimal representation of the OID
    ----------------------------------------------------------------   
    "NIST P-256"  8   0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 
    "NIST P-384"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x22            
    "NIST P-521"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x23          
-}

data HomeDir =
    HomeDir { homevar :: String
            , appdir :: String
            , optfile_alts :: [String]
            }

home :: HomeDir
home = HomeDir
    { homevar = "GNUPGHOME"
    , appdir  = ".gnupg"
    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
    }

data InputFile = HomeSec
               -- ^ A file named secring.gpg located in the home directory.
               -- See 'opHome'.
               | HomePub
               -- ^ A file named pubring.gpg located in the home directory.
               -- See 'opHome'.
               | ArgFile FilePath
               -- ^ Contents will be read or written from the specified path.
               | FileDesc Posix.Fd
               -- ^ Contents will be read or written from the specified file
               -- descriptor.
               | Pipe Posix.Fd Posix.Fd
               -- ^ Contents will be read from the first descriptor and updated
               -- content will be writen to the second. Note: Don't use Pipe
               -- for 'Wallet' files. (TODO: Wallet support)
 deriving (Eq,Ord,Show)

-- type UsageTag = String
type Initializer = String

data FileType = KeyRingFile
              | PEMFile
              | WalletFile
              | DNSPresentation
              | Hosts

-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
-- to contain secret or public PGP key packets.  Note that it is not supported
-- to mix both in the same file and that the secret key packets include all of
-- the information contained in their corresponding public key packets.
data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
                         --   (see 'rtRingAccess')
            | Sec        -- ^ secret information
            | Pub        -- ^ public information
 deriving (Eq,Ord,Show)

-- | Note that the documentation here is intended for when this value is
-- assigned to 'fill'.  For other usage, see 'spill'.
data KeyFilter = KF_None -- ^ No keys will be imported.
               | KF_Match String -- ^ Only the key that matches the spec will be imported.
               | KF_Subkeys   -- ^ Subkeys will be imported if their owner key is
                              -- already in the ring.  TODO: Even if their signatures
                              -- are bad?
               | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
                              -- identity (signed or self-authenticating).
               | KF_All -- ^ All keys will be imported.

-- | This type describes how 'runKeyRing' will treat a file.
data StreamInfo = StreamInfo { access :: Access
    -- ^ Indicates whether the file is allowed to contain secret information.
    , typ :: FileType
    -- ^ Indicates the format and content type of the file.
    , fill :: KeyFilter
    -- ^ This filter controls what packets will be inserted into a file.
    , spill :: KeyFilter
    --
    -- ^ Use this to indicate whether or not a file's contents should be
    -- available for updating other files.  Note that although its type is
    -- 'KeyFilter', it is usually interpretted as a boolean flag.  Details
    -- depend on 'typ' and are as follows:
    --
    -- 'KeyRingFile':
    --
    --  * 'KF_None' - The file's contents will not be shared.
    --
    --  * otherwise - The file's contents will be shared.
    --
    -- 'PEMFile':
    --
    --  * 'KF_None'  - The file's contents will not be shared.
    --
    --  * 'KF_Match' - The file's key will be shared with the specified owner
    --  key and usage tag.  If 'fill' is also a 'KF_Match', then it must be
    --  equal to this value; changing the usage or owner of a key is not
    --  supported via the fill/spill mechanism.
    --
    --  * otherwise  - Unspecified.  Do not use.
    --
    -- 'WalletFile':
    --
    --  * The 'spill' setting is ignored and the file's contents are shared.
    --  (TODO)
    --
    -- 'Hosts': 
    --
    --  * The 'spill' setting is ignored and the file's contents are shared.
    --  (TODO)
    --
    , initializer :: Maybe String
    -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is
    -- interpretted as a shell command that may be used to create the key if it
    -- does not exist.
    , transforms :: [Transform] 
    -- ^ Per-file transformations that occur before the contents of a file are
    -- spilled into the common pool.
    }


spillable :: StreamInfo -> Bool
spillable (spill -> KF_None) = False
spillable _                  = True

isMutable :: StreamInfo -> Bool
isMutable (fill -> KF_None) = False
isMutable _                 = True

isring :: FileType -> Bool
isring (KeyRingFile {}) = True
isring _                = False

isSecretKeyFile :: FileType -> Bool
isSecretKeyFile PEMFile         = True
isSecretKeyFile DNSPresentation = True
isSecretKeyFile _               = False

{-
pwfile :: FileType -> Maybe InputFile
pwfile (KeyRingFile f) = f
pwfile _               = Nothing
-}

iswallet :: FileType -> Bool
iswallet (WalletFile {}) = True
iswallet _               = False

usageFromFilter :: MonadPlus m => KeyFilter -> m String
usageFromFilter (KF_Match usage) = return usage
usageFromFilter _                = mzero

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 :: MappedPacket -> IO (KikiCondition Packet)
                        }

-- | Roster-entry level actions
data PacketUpdate = InducerSignature String [SignatureSubpacket]
                  | SubKeyDeletion KeyKey KeyKey

-- | This type is used to indicate where to obtain passphrases.
data PassphraseSpec = PassphraseSpec
    { passSpecRingFile :: Maybe FilePath
    -- ^ If not Nothing, the passphrase is to be used for packets
    -- from this file.
    , passSpecKeySpec :: Maybe String
    -- ^ Non-Nothing value reserved for future use.
    -- (TODO: Use this to implement per-key passphrase associations).
    , passSpecPassFile :: InputFile
    -- ^ The passphrase will be read from this file or file descriptor.
    }
    -- | Use this to carry pasphrases from a previous run.
    | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))

data Transform =
        Autosign
        -- ^ This operation will make signatures for any tor-style UID
        -- that matches a tor subkey and thus can be authenticated without
        -- requring the judgement of a human user.
        --
        -- A tor-style UID is one of the following form:
        --
        -- > Anonymous <root@HOSTNAME.onion>
        | DeleteSubKey String
        -- ^ Delete the subkey specified by the given fingerprint and any
        -- associated signatures on that key.
 deriving (Eq,Ord)

-- | This type describes an idempotent transformation (merge or import) on a
-- set of GnuPG keyrings and other key files.
data KeyRingOperation = KeyRingOperation
    { opFiles :: Map.Map InputFile StreamInfo
    -- ^ Indicates files to be read or updated.
    , opPassphrases :: [PassphraseSpec]
    -- ^ Indicates files or file descriptors where passphrases can be found.
    , opTransforms :: [Transform]
    -- ^ Transformations to be performed on the key pool after all files have
    -- been read and before any have been written.
    , opHome :: Maybe FilePath
    -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
    -- files reside.  Otherwise, the evironment variable $GNUPGHOME is consulted
    -- and if that is not set, it falls back to $HOME/.gnupg.
    }

resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
resolveInputFile ctx = resolve
 where
    resolve HomeSec = return (homesecPath ctx)
    resolve HomePub = return (homepubPath ctx)
    resolve (ArgFile f) = return f
    resolve _ = []

resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
 where str = case (fdr,fdw) of
                (0,1) -> "-"
                _     -> "&pipe" ++ show (fdr,fdw)
resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
 where str = "&" ++ show fd
resolveForReport mctx f = concat $ resolveInputFile ctx f
 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx

filesToLock ::
  KeyRingOperation -> InputFileContext -> [FilePath]
filesToLock k ctx = do
    (f,stream) <- Map.toList (opFiles k)
    case fill stream of
        KF_None -> []
        _       -> resolveInputFile ctx f


-- kret :: a -> KeyRingOperation a
-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)

data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show

pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
pkcs8 (RSAKey n e) = RSAKey8 n e

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"

instance ASN1Object PKCS8_RSAPublicKey where

    -- PKCS #8 Public key data
    toASN1 (RSAKey8 (MPI n) (MPI e))
                  = \xs -> Start Sequence
                         : Start Sequence
                         : OID [1,2,840,113549,1,1,1]
                         : Null -- Doesn't seem to be neccessary, but i'm adding it
                                -- to match PEM files I see in the wild.
                         : End Sequence
                         : BitString (toBitArray bs 0)
                         : End Sequence
                         : xs
        where
            pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
            bs = encodeASN1' DER pubkey

    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
        Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) =
        case decodeASN1' DER bs of
            Right as -> fromASN1 as
            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
      where
        BitArray _ bs = b
    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
        case decodeASN1' DER bs of
            Right as -> fromASN1 as
            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
      where
        BitArray _ bs = b

    fromASN1 _ =
        Left "fromASN1: RSAPublicKey: unexpected format"

{-
RSAPrivateKey ::= SEQUENCE {
  version           Version,
  modulus           INTEGER,  -- n
  publicExponent    INTEGER,  -- e
  privateExponent   INTEGER,  -- d
  prime1            INTEGER,  -- p
  prime2            INTEGER,  -- q
  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
  exponent2         INTEGER,  -- d mod (q-1)
  coefficient       INTEGER,  -- (inverse of q) mod p
  otherPrimeInfos   OtherPrimeInfos OPTIONAL
  }
-}
data RSAPrivateKey = RSAPrivateKey
    { rsaN :: MPI
    , rsaE :: MPI
    , rsaD :: MPI
    , rsaP :: MPI
    , rsaQ :: MPI
    , rsaDmodP1 :: MPI
    , rsaDmodQminus1 :: MPI
    , rsaCoefficient :: MPI
    }
 deriving Show

instance ASN1Object RSAPrivateKey where
    toASN1 rsa@(RSAPrivateKey {})
        = \xs -> Start Sequence
               : IntVal 0
               : mpiVal rsaN
               : mpiVal rsaE
               : mpiVal rsaD
               : mpiVal rsaP
               : mpiVal rsaQ
               : mpiVal rsaDmodP1
               : mpiVal rsaDmodQminus1
               : mpiVal rsaCoefficient
               : End Sequence
               : xs
                  where mpiVal f = IntVal x where MPI x = f rsa

    fromASN1 ( Start Sequence
             : IntVal _ -- version
             : IntVal n
             : IntVal e
             : IntVal d
             : IntVal p
             : IntVal q
             : IntVal dmodp1
             : IntVal dmodqminus1
             : IntVal coefficient
             : ys) =
        Right ( privkey, tail $ dropWhile notend ys)
         where
            notend (End Sequence) = False
            notend _              = True
            privkey = RSAPrivateKey
                { rsaN = MPI n
                , rsaE = MPI e
                , rsaD = MPI d
                , rsaP = MPI p
                , rsaQ = MPI q
                , rsaDmodP1 = MPI dmodp1
                , rsaDmodQminus1 = MPI dmodqminus1
                , rsaCoefficient = MPI coefficient
                }
    fromASN1 _ =
        Left "fromASN1: RSAPrivateKey: unexpected format"



-- | This type is used to indicate success or failure
-- and in the case of success, return the computed object.
-- The 'FunctorToMaybe' class is implemented to facilitate
-- branching on failture.
data KikiCondition a = KikiSuccess a
    | FailedToLock [FilePath]
    | BadPassphrase
    | FailedToMakeSignature
    | CantFindHome
    | AmbiguousKeySpec FilePath
    | CannotImportMasterKey
    | NoWorkingKey
 deriving ( Functor, Show )

instance FunctorToMaybe KikiCondition where
    functorToMaybe (KikiSuccess a) = Just a
    functorToMaybe _               = Nothing

instance Applicative KikiCondition where
    pure a  = KikiSuccess a
    f <*> a =
        case functorToEither f of
            Right f  -> case functorToEither a of
                            Right a  -> pure (f a)
                            Left err -> err
            Left err -> err

-- | 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 ByteString
        | DeletedPacket String
 deriving Show

uncamel :: String -> String
uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
  where
    (.:) = fmap . fmap
    ( firstWord  ,
      otherWords ) = splitAt 1 ws
    ws             = camel >>= groupBy (\_ c -> isLower c)
    ( camel, args) = splitAt 1 $ words str

reportString :: KikiReportAction -> String
reportString x = uncamel $ show x

errorString :: KikiCondition a -> String
errorString (KikiSuccess {}) = "success"
errorString e = uncamel . show $ fmap (const ()) e

-- | Errors in kiki are indicated by the returning of this record.
data KikiResult a = KikiResult
    { kikiCondition :: KikiCondition a
    -- ^ The result or a fatal error condition.
    , kikiReport :: KikiReport
    -- ^ A list of non-fatal warnings and informational messages
    -- along with the files that triggered them.
    }

type KikiReport = [ (FilePath, KikiReportAction) ]

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

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


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

x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
x509cert (NotationDataPacket
        { human_readable = False
        , notation_name  = "x509cert@"
        , notation_value = u
        }) = Just (Char8.pack u)
x509cert _    = Nothing

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]


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


data PGPKeyFlags =
    Special
    | Vouch -- Signkey
    | Sign
    | VouchSign
    | Communication
    | VouchCommunication
    | SignCommunication
    | VouchSignCommunication
    | Storage
    | VouchStorage
    | SignStorage
    | VouchSignStorage
    | Encrypt
    | VouchEncrypt
    | SignEncrypt
    | VouchSignEncrypt
 deriving (Eq,Show,Read,Enum)


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"




-- matchpr computes the fingerprint of the given key truncated to
-- be the same lenght as the given fingerprint for comparison.
matchpr :: String -> Packet -> String
matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp

keyFlags :: t -> [Packet] -> [SignatureSubpacket]
keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)

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


matchSpec :: KeySpec -> KeyData -> Bool
matchSpec (KeyGrip grip) (KeyData p _ _ _)
    | matchpr grip (packet p)==grip = True
    | otherwise                     = False

matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
 where
    ps = map (packet .fst) sigs
    match p = isSignaturePacket p
                && has_tag tag p
                && has_issuer key p
    has_issuer key p = isJust $ do
        issuer <- signature_issuer p
        guard $ matchpr issuer key == issuer
    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))

matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
  where
    us = filter (isInfixOf pat) $ Map.keys uids

data UserIDRecord = UserIDRecord {
    uid_full :: String,
    uid_realname :: T.Text,
    uid_user :: T.Text,
    uid_subdomain :: T.Text,
    uid_topdomain :: T.Text
}
 deriving Show

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
isBracket :: Char -> Bool
isBracket '<' = True
isBracket '>' = True
isBracket _   = False




data KeySpec =
      KeyGrip String
    | KeyTag Packet String
    | KeyUidMatch String
 deriving Show

-- | Parse a key specification.
-- The first argument is a grip for the default working key.
parseSpec :: String -> String -> (KeySpec,Maybe String)
parseSpec grip spec = (topspec,subspec)
 where
     (topspec0,subspec0) = unprefix '/' spec
     (toptyp,top) = unprefix ':' topspec0
     (subtyp,sub) = unprefix ':' subspec0
     topspec = case () of
                    _ | null top && or [ subtyp=="fp"
                                       , null subtyp && is40digitHex sub
                                       ]
                                 -> KeyGrip sub
                    _ | null top && null grip -> KeyUidMatch sub
                    _ | null top -> KeyGrip grip
                    _ | toptyp=="fp" || (null toptyp && is40digitHex top)
                                 -> KeyGrip top
                    _ | toptyp=="u" -> KeyUidMatch top
                    _            -> KeyUidMatch top
     subspec = case subtyp of
                "t" -> Just sub
                "fp" | top=="" -> Nothing
                "" | top=="" && is40digitHex sub -> Nothing
                "" -> listToMaybe sub >> Just sub
                _ -> Nothing

     is40digitHex xs = ys == xs && length ys==40
      where
        ys = filter ishex xs
        ishex c | '0' <= c && c <= '9' = True
                | 'A' <= c && c <= 'F' = True
                | 'a' <= c && c <= 'f' = True
        ishex c = False

     -- | Split a string into two at the first occurance of the given
     -- delimiter.  If the delimeter does not occur, then the first
     -- item of the returned pair is empty and the second item is the
     -- input string.
     unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
      where p = break (==c) spec


filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
filterMatches spec ks = filter (matchSpec spec . snd) ks

filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
 where
    matchAll = KeyGrip ""

    subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
    subkeySpec (topspec,Just mtag)    = (topspec , KeyTag (packet p) mtag)

    match spec mps 
               = not . null
               . snd
               . seek_key spec
               . map packet
               $ mps

    old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)

    oldOrMatch spec sub = old sub
                          || match spec (flattenSub "" True sub)

    subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
                         then oldOrMatch subspec
                         else old)
                       subs
        where
            (topspec,subspec) = subkeySpec spec

selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db

selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db

selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
selectPublicKeyAndSigs (spec,mtag) db =
    case mtag of
        Nothing -> do
            (kk,r) <- Map.toList $ fmap (findbyspec spec) db
            (sub,sigs) <- r
            return (kk,sub,sigs)
        Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
 where
    topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)

    findbyspec (KeyGrip g) kd = do
        filter ismatch $
            topresult kd
            : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
                  (Map.elems $ keySubKeys kd)
      where
        ismatch (p,sigs) = matchpr g p ==g
    findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []

    findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
     where
        gettag (SubKey sub sigs) = do
            let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
            (hastag,_) <- maybeToList mb
            guard hastag
            return $ (kk, packet sub, map (packet . fst) sigs)

selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
selectKey0 wantPublic (spec,mtag) db = do
    let Message ps = flattenKeys wantPublic db
        ys = snd $ seek_key spec ps
    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
    case ys of
        y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
        []    -> Nothing

{-
selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
selectAll wantPublic (spec,mtag) db = do
    let Message ps = flattenKeys wantPublic db
        ys = snd $ seek_key spec ps
    y <- take 1 ys
    case mtag of
        Nothing -> return (y,Nothing)
        Just tag ->
            let search ys1 = do
                    let zs = snd $ seek_key (KeyTag y tag) ys1
                    z <- take 1 zs
                    (y,Just z):search (drop 1 zs)
            in search (drop 1 ys)
-}

seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
seek_key (KeyGrip grip) sec = (pre, subs)
  where
    (pre,subs) = break pred sec
    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
    pred _                      = False

seek_key (KeyTag key tag) ps
    | null bs = (ps, [])
    | null qs =
      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
        (as ++ (head bs : as'), bs')
    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
  where
    (as,bs) = break (\p -> isSignaturePacket p
                        && has_tag tag p
                        && isJust (signature_issuer p)
                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
                    ps
    (rs,qs) = break isKey (reverse as)

    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))

seek_key (KeyUidMatch pat) ps
    | null bs = (ps, [])
    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
                    (as ++ (head bs : as'), bs')
    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
  where
    (as,bs) = break (isInfixOf pat . uidStr) ps
    (rs,qs) = break isKey (reverse as)

    uidStr (UserIDPacket s) = s
    uidStr _                = ""


data InputFileContext = InputFileContext
    { homesecPath :: FilePath
    , homepubPath :: FilePath
    }

readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
readInputFileS ctx (Pipe fd _)   = fdToHandle fd >>= S.hGetContents
readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
readInputFileS ctx inp = do
    let fname = resolveInputFile ctx inp
    fmap S.concat $ mapM S.readFile fname

readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
readInputFileL ctx (Pipe fd _)   = fdToHandle fd >>= L.hGetContents
readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
readInputFileL ctx inp = do
    let fname = resolveInputFile ctx inp
    fmap L.concat $ mapM L.readFile fname


writeInputFileL ctx (Pipe _ fd) bs   = fdToHandle fd >>= (`L.hPut` bs)
writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs)
writeInputFileL ctx inp bs = do
    let fname = resolveInputFile ctx inp
    mapM_ (`L.writeFile` bs) fname

-- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
-- writeStamped0 :: InputFileContext -> InputFile

getWriteFD :: InputFile -> Maybe Posix.Fd
getWriteFD (Pipe _ fd)   = Just fd
getWriteFD (FileDesc fd) = Just fd
getWriteFD _             = Nothing

writeStamped0 :: InputFileContext
    -> InputFile
    -> Posix.EpochTime
    -> (Either Handle FilePath -> t -> IO ())
    -> t
    -> IO ()
writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do
    h <- fdToHandle fd
    dowrite (Left h) bs
    handleIO_ (return ())
     $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp)
writeStamped0 ctx inp stamp dowrite bs = do
    let fname = resolveInputFile ctx inp
    forM_ fname $ \fname -> do
    createDirectoryIfMissing True $ takeDirectory fname
    dowrite (Right fname) bs
    setFileTimes fname stamp stamp

{- This may be useful later.  Commented for now, as it is not used.
 -
writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs
-}

writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str

getInputFileTime :: InputFileContext -> InputFile -> IO CTime
getInputFileTime ctx (Pipe fdr fdw) = do
    mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
    maybe tryw return mt
 where
    tryw = do
        handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
            $ modificationTime <$> getFdStatus fdw
getInputFileTime ctx (FileDesc fd) = do
    handleIO_ (error $ "&"++show fd++": modificaiton time?") $
                    modificationTime <$> getFdStatus fd
getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
    handleIO_ (error $ fname++": modificaiton time?") $
                    modificationTime <$> getFileStatus fname

{-
 - This may be useful later.  Commented for now as it is not used.
 -
doesInputFileExist :: InputFileContext -> InputFile -> IO Bool
doesInputFileExist ctx f = do
    case resolveInputFile ctx f of
        [n] -> doesFileExist n
        _   -> return True
-}


cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
cachedContents maybePrompt ctx fd = do
    ref <- newIORef Nothing
    return $ get maybePrompt ref fd
 where
    trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs

    get maybePrompt ref fd = do
        pw <- readIORef ref
        flip (flip maybe return) pw $ do
            if fd == FileDesc 0 then case maybePrompt of
                                    Just prompt -> S.putStr prompt
                                    Nothing -> return ()
                               else return ()
            pw <- fmap trimCR $ readInputFileS ctx fd
            writeIORef ref (Just pw)
            return pw

importSecretKey ::
  (MappedPacket -> IO (KikiCondition Packet))
  -> KikiCondition
       (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
  -> (FilePath, Maybe [Char], [KeyKey], FileType, t)
  -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
importSecretKey doDecrypt db' tup = do
            try db' $ \(db',report0) -> do
            r <- doImport doDecrypt
                      db'
                      tup
            try r $ \(db'',report) -> do
            return $ KikiSuccess (db'', report0 ++ report)


mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
     -> IO
          (KikiCondition
             ( ( Map.Map [Char8.ByteString] KeyData
               , ( [Hosts.Hosts]
                 , [Hosts.Hosts]
                 , Hosts.Hosts
                 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
                 , [SockAddr]))
             , [(FilePath,KikiReportAction)]))
mergeHostFiles krd db ctx = do
    let hns = files ishosts
        ishosts Hosts = True
        ishosts _     = False
        files istyp = do
            (f,stream) <- Map.toList (opFiles krd)
            guard (istyp $ typ stream)
            return f

    hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns

    let gpgnames = map getHostnames $ Map.elems db
        os = do
            (addr,(ns,_)) <- gpgnames
            n <- ns
            return (addr,n)
        setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
        -- we ensure .onion names are set properly
        hostdbs = map setOnions hostdbs0
        outgoing_names = do
            (addr,(_,gns)) <- gpgnames
            guard . not $ null gns
            guard $ all (null . Hosts.namesForAddress addr) hostdbs0
            return addr
    -- putStrLn $ "hostdbs = " ++ show hostdbs

    -- 1. let U = union all the host dbs 
    --     preserving whitespace and comments of the first
    let u0 = foldl' Hosts.plus Hosts.empty hostdbs
        -- we filter U to be only finger-dresses
        u1 = Hosts.filterAddrs (hasFingerDress db) u0

    -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
    {-
    putStrLn $ "_  = {\n" ++ show (head hostdbs) ++ "}"
    putStrLn $ "--> " ++ show (nf (head hostdbs))
    putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
    putStrLn $ "--> " ++ show (nf u0)
    putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
    putStrLn $ "--> " ++ show (nf u1)
    -}
    
    -- 2. replace gpg annotations with those in U
    -- forM use_db
    db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db

    return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])

writeHostsFiles
  :: KeyRingOperation -> InputFileContext
     -> ([Hosts.Hosts],
         [Hosts.Hosts],
         Hosts.Hosts,
         [(SockAddr, (t1, [Char8.ByteString]))],
         [SockAddr])
     -> IO [(FilePath, KikiReportAction)]
writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
    let hns = files isMutableHosts
        isMutableHosts (fill -> KF_None) = False
        isMutableHosts (typ -> Hosts)    = True
        isMutableHosts _                 = False
        files istyp = do
            (f,stream) <- Map.toList (opFiles krd)
            guard (istyp stream)
            return f -- resolveInputFile ctx f

    -- 3. add hostnames from gpg for addresses not in U
    let u = foldl' f u1 ans
        ans = reverse $ do
            (addr,(_,ns)) <- gpgnames
            guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
            n <- ns
            return (addr,n)
        f h (addr,n) = Hosts.assignNewName addr n h

    -- 4. for each host db H, union H with U and write it out as H'
    --     only if there is a non-empty diff
    rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do 
        let h = h1 `Hosts.plus` u
            d = Hosts.diff h0 h
            rs = map ((fname,) . HostsDiff) d
        unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h
        return $ map (first $ resolveForReport $ Just ctx) rs
    return $ concat rss

isSecretKey :: Packet -> Bool
isSecretKey (SecretKeyPacket {}) = True
isSecretKey _                    = False

buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
              -> IO (KikiCondition ((KeyDB
                                    ,Maybe String
                                    ,Maybe MappedPacket
                                    ,([Hosts.Hosts],
                                             [Hosts.Hosts],
                                             Hosts.Hosts,
                                             [(SockAddr, (KeyKey, KeyKey))],
                                             [SockAddr])
                                    ,Map.Map InputFile Access
                                    ,MappedPacket -> IO (KikiCondition Packet)
                                    ,Map.Map InputFile Message
                                    )
                                   ,[(FilePath,KikiReportAction)]))
buildKeyDB ctx grip0 keyring = do
    let 
        files isring = do
            (f,stream) <- Map.toList (opFiles keyring)
            guard (isring $ typ stream)
            resolveInputFile ctx f

        ringMap = Map.filter (isring . typ) $ opFiles keyring

        readp f stream = fmap readp0 $ readPacketsFromFile ctx f
         where
          readp0 ps = (stream { access = acc' }, ps)
           where acc' = case access stream of
                            AutoAccess ->
                                case ps of
                                    Message ((PublicKeyPacket {}):_) -> Pub
                                    Message ((SecretKeyPacket {}):_) -> Sec
                                    _                                -> AutoAccess
                            acc -> acc

        readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))

    -- KeyRings (todo: KikiCondition reporting?)
    (spilled,mwk,grip,accs,keys,unspilled) <- do
#if MIN_VERSION_containers(0,5,0)
        ringPackets <- Map.traverseWithKey readp ringMap
#else
        ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
#endif
        let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)

        let grip = grip0 `mplus` (fingerprint <$> fstkey)
              where
                fstkey = do
                    (_,Message ps) <- Map.lookup HomeSec ringPackets
                    listToMaybe ps
            (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
            keys :: Map.Map KeyKey MappedPacket
            keys = Map.foldl slurpkeys Map.empty
                        $ Map.mapWithKey filterSecrets ringPackets
                    where
                          filterSecrets f (_,Message ps) =
                            filter (isSecretKey . packet)
                                $ zipWith (mappedPacketWithHint fname) ps [1..]
                            where fname = resolveForReport (Just ctx) f
                          slurpkeys m ps = m `Map.union` Map.fromList ps'
                            where ps' = zip (map (keykey . packet) ps) ps
            wk = listToMaybe $ do
                    fp <- maybeToList grip
                    let matchfp mp = not (is_subkey p) && matchpr fp p == fp
                            where p = packet mp
                    Map.elems $ Map.filter matchfp keys
            accs = fmap (access . fst) ringPackets
        return (spilled,wk,grip,accs,keys,fmap snd unspilled)

    doDecrypt <- makeMemoizingDecrypter keyring ctx keys

    let wk = fmap packet mwk
        rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
                             , rtSecring = homesecPath ctx
                             , rtGrip = grip
                             , rtWorkingKey = wk
                             , rtRingAccess = accs
                             , rtKeyDB = Map.empty
                             , rtPassphrases = doDecrypt
                             }
    transformed0 <-
        let trans f (info,ps) = do
                let manip = combineTransforms (transforms info)
                    rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
                    acc = Just Sec /= Map.lookup f accs
                r <- performManipulations doDecrypt rt1 mwk manip
                try r $ \(rt2,report) -> do
                return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2))
#if MIN_VERSION_containers(0,5,0)
        in fmap sequenceA $ Map.traverseWithKey trans spilled
#else
        in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
#endif
    try transformed0 $ \transformed -> do
    let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
                    where
                      mergeIt db f (_,(info,ps)) = merge db f ps
        reportTrans = concat $ Map.elems $ fmap fst transformed

    -- Wallets
    let importWalletKey wk db' (top,fname,sub,tag) = do
            try db' $ \(db',report0) -> do
            r <- doImportG doDecrypt
                      db'
                      (fmap keykey $ maybeToList wk)
                      [mkUsage tag]
                      fname
                      sub
            try r $ \(db'',report) -> do
            return $ KikiSuccess (db'', report0 ++ report)

    wms <- mapM (readw wk) (files iswallet)
    let wallet_keys = do
            maybeToList wk
            (fname,xs) <- wms
            (_,sub,(_,m)) <- xs
            (tag,top) <- Map.toList m
            return (top,fname,sub,tag)
    db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
    try db $ \(db,reportWallets) -> do

    -- PEM files
    let pems = do
            (n,stream) <- Map.toList $ opFiles keyring
            grip <- maybeToList grip
            n <- resolveInputFile ctx n
            guard $ spillable stream && isSecretKeyFile (typ stream)
            let us = mapMaybe usageFromFilter [fill stream,spill stream]
            usage <- take 1 us
            guard $ all (==usage) $ drop 1 us
            -- TODO: KikiCondition reporting for spill/fill usage mismatch?
            let (topspec,subspec) = parseSpec grip usage
                ms = map fst $ filterMatches topspec (Map.toList db)
                cmd = initializer stream
            return (n,subspec,ms,typ stream, cmd)
    imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
    db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
    try db $ \(db,reportPEMs) -> do

    r <- mergeHostFiles keyring db ctx
    try r $ \((db,hs),reportHosts) -> do

    return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
                         , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts )

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

derToBase32 :: ByteString -> String
#if !defined(VERSION_cryptonite)
derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
#else
derToBase32 = map toLower . Base32.encode . S.unpack . sha1
 where
   sha1 :: L.ByteString -> S.ByteString
   sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
#endif

derRSA :: Packet -> Maybe ByteString
derRSA rsa = do
    k <- rsaKeyFromPacket rsa
    return $ encodeASN1 DER (toASN1 k [])

unconditionally :: IO (KikiCondition a) -> IO a
unconditionally action = do
    r <- action
    case r of
        KikiSuccess x -> return x
        e -> error $ errorString e

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


data ParsedCert = ParsedCert
    { pcertKey :: Packet
    , pcertTimestamp :: UTCTime
    , pcertBlob :: L.ByteString
    }
 deriving (Show,Eq)
data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
 deriving (Show,Eq)

spemPacket (PEMPacket p) = Just p
spemPacket _ = Nothing

spemCert (PEMCertificate p) = Just p
spemCert _ = Nothing

toStrict :: L.ByteString -> S.ByteString
toStrict = foldr1 (<>) . L.toChunks

-- No instance for (ASN1Object RSA.PublicKey)

parseCertBlob comp bs = do
    asn1 <- either (const Nothing) Just
                $ decodeASN1 DER bs
    let asn1' = drop 2 asn1
    cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
    let _ = cert :: X509.Certificate
        notBefore :: UTCTime
#if MIN_VERSION_x509(1,5,0)
        notBefore =  toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
            where (vincentTime,_) = X509.certValidity cert
#else
        (notBefore,_) = X509.certValidity cert
#endif
    case X509.certPubKey cert of
        X509.PubKeyRSA key -> do
            let withoutkey =
                    let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
                        (pre,post) = S.breakSubstring ekey $ toStrict bs
                        post' = S.drop (S.length ekey) post
                        len :: Word16
                        len = if S.null post then maxBound
                                             else fromIntegral $ S.length pre
                    in if len < 4096
                        then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
                        else bs
            return
                ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
                                                               (MPI $ RSA.public_n key)
                                                               (MPI $ RSA.public_e key)
                           , pcertTimestamp = notBefore
                           , pcertBlob = if comp then withoutkey
                                                 else bs
                           }
        _ -> Nothing

packetFromPublicRSAKey notBefore n e =
    PublicKeyPacket { version = 4
                    , timestamp = round $ utcTimeToPOSIXSeconds notBefore
                    , key_algorithm = RSA
                    , key = [('n',n),('e',e)]
                    , is_subkey = True
                    , v3_days_of_validity = Nothing
                    }

decodeBlob cert =
    if 0 /= (bs `L.index` 0) .&. 0x10
     then bs
     else let (keypos0,bs') = L.splitAt 2 bs
              keypos :: Word16
              keypos = decode keypos0
              ds = GZip.decompress bs'
              (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
           in prekey <> key <> postkey
 where
    bs = pcertBlob cert
    key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert

extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
extractRSAKeyFields kvs = do
    let kvs' = mapMaybe  (\(k,v) -> (k,) <$> parseField v) kvs
    n <- lookup "Modulus" kvs'
    e <- lookup "PublicExponent" kvs'
    d <- lookup "PrivateExponent" kvs'
    p <- lookup "Prime1" kvs' -- p
    q <- lookup "Prime2" kvs' -- q
    dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
    dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
    u <- lookup "Coefficient" kvs'
    {-
    case (d,p,dmodp1) of
        (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
        _ -> error "dmodp fail!"
    case (d,q,dmodqminus1) of
        (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
        _ -> error "dmodq fail!"
    -}
    return $ RSAPrivateKey
        { rsaN = n
        , rsaE = e
        , rsaD = d
        , rsaP = p
        , rsaQ = q
        , rsaDmodP1 = dmodp1
        , rsaDmodQminus1 = dmodqminus1
        , rsaCoefficient = u }
 where
    parseField blob = MPI <$> m
     where m = bigendian <$> Base64.decode (Char8.unpack blob)

    bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
     where
        nlen = length bs

rsaToPGP stamp rsa = SecretKeyPacket
                { version = 4
                , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
                , key_algorithm = RSA
                , key = [ -- public fields...
                         ('n',rsaN rsa)
                        ,('e',rsaE rsa)
                        -- secret fields
                        ,('d',rsaD rsa)
                        ,('p',rsaQ rsa) -- Note: p & q swapped
                        ,('q',rsaP rsa) -- Note: p & q swapped
                        ,('u',rsaCoefficient rsa)
                        ]
                -- , ecc_curve = def
                , s2k_useage = 0
                , s2k = S2K 100 ""
                , symmetric_algorithm = Unencrypted
                , encrypted_data = ""
                , is_subkey = True
                }

readSecretDNSFile :: InputFile -> IO Packet
readSecretDNSFile fname = do
    let ctx = InputFileContext "" ""
    stamp <- getInputFileTime ctx fname
    input <- readInputFileL ctx fname
    let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
                  . Char8.break (==':'))
               $ Char8.lines input
        alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
        parseAlg spec = case Char8.words spec of
                            nstr:_ -> case read (Char8.unpack nstr) :: Int of
                                            2 -> DH
                                            3 -> DSA -- SHA1
                                            5 -> RSA -- SHA1
                                            6 -> DSA -- NSEC3-SHA1 (RFC5155)
                                            7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
                                            8 -> RSA -- SHA256
                                            10 -> RSA -- SHA512 (RFC5702)
                                            -- 12 -> GOST
                                            13 -> ECDSA -- P-256 SHA256 (RFC6605)
                                            14 -> ECDSA -- P-384 SHA384 (RFC6605)
                            _ -> RSA
    case alg of
        RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs


readSecretPEMFile :: InputFile -> IO [SecretPEMData]
readSecretPEMFile fname = do
    -- warn $ fname ++ ": reading ..."
    let ctx = InputFileContext "" ""
    -- Note: The key's timestamp is included in it's fingerprint.
    --       Therefore, we should attempt to preserve it.
    stamp <- getInputFileTime ctx fname
    input <- readInputFileL ctx fname
    let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
        pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
                    $ pemParser $ Just "RSA PRIVATE KEY"
        cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
                    $ pemParser $ Just "CERTIFICATE"
        parseRSAPrivateKey dta = do
           let e = decodeASN1 DER dta
           asn1 <- either (const $ mzero) return e
           rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
           let _ = rsa :: RSAPrivateKey
           return $ PEMPacket $ rsaToPGP stamp rsa
        dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
        mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
        mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
            where key' = if tm < fromTime (timestamp key)
                            then key { timestamp = fromTime tm }
                            else key
        mergeDate (tm,_) (Right mb) = (tm,mb)
    return $ dta

doImport
  :: Ord k =>
     (MappedPacket -> IO (KikiCondition Packet))
     -> Map.Map k KeyData
     -> (FilePath, Maybe [Char], [k], FileType, t)
     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
doImport doDecrypt db (fname,subspec,ms,typ,_) = do
    flip (maybe $ return CannotImportMasterKey)
         subspec $ \tag -> do
    (certs,keys) <- case typ of
        PEMFile -> do
            ps <- readSecretPEMFile (ArgFile fname)
            let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
                    = partition (isJust . spemCert) ps
            return (certs,keys)
        DNSPresentation -> do
            p <- readSecretDNSFile (ArgFile fname)
            return ([],[p])
    -- TODO Probably we need to move to a new design where signature
    -- packets are merged into the database in one phase with null
    -- signatures, and then the signatures are made in the next phase.
    -- This would let us merge annotations (like certificates) from
    -- seperate files.
    foldM (importKey tag certs) (KikiSuccess (db,[])) keys
 where
    importKey tag certs prior key = do
        try prior $ \(db,report) -> do
        let (m0,tailms) = splitAt 1 ms
        if (not (null tailms) || null m0)
            then return $ AmbiguousKeySpec fname
            else do
                let kk = keykey key
                    cs = filter (\c -> kk==keykey (pcertKey c)) certs
                    blobs = map mkCertNotation $ nub $ map pcertBlob cs
                    mkCertNotation bs = NotationDataPacket
                        { human_readable = False
                        , notation_name = "x509cert@"
                        , notation_value = Char8.unpack bs }
                    datedKey = key { timestamp = fromTime $ minimum dates }
                    dates = fromTime (timestamp key) : map pcertTimestamp certs
                r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
                try r $ \(db',report') -> do
                return $ KikiSuccess (db',report++report')

doImportG
  :: Ord k =>
     (MappedPacket -> IO (KikiCondition Packet))
     -> Map.Map k KeyData
     -> [k]
     -> [SignatureSubpacket]
     -> [Char]
     -> Packet
     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
doImportG doDecrypt db m0 tags fname key = do
    let kk = head m0
        Just (KeyData top topsigs uids subs) = Map.lookup kk db
        subkk = keykey key
        (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
                                               [])
                                 ( (False,) . addOrigin )
                                 (Map.lookup subkk subs)
                             where
                                addOrigin (SubKey mp sigs) =
                                    let mp' = mp
                                          { locations = Map.insert fname
                                                             (origin (packet mp) (-1))
                                                             (locations mp) }
                                    in SubKey mp' sigs
        subs' = Map.insert subkk subkey subs

        istor = do
            guard ("tor" `elem` mapMaybe usage tags)
            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"

    uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
                let has_torid = do
                     -- TODO: check for omitted real name field
                     (sigtrusts,om) <- Map.lookup idstr uids
                     listToMaybe $ do
                         s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
                         signatures_over $ verify (Message [packet top]) s
                flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
                wkun <- doDecrypt top

                try wkun $ \wkun -> do

                let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
                    uid = UserIDPacket idstr
                    -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
                    tor_ov = makeInducerSig (packet top) wkun uid keyflags
                sig_ov <- pgpSign (Message [wkun])
                                  tor_ov
                                  SHA1
                                  (fingerprint wkun)
                flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
                     (sig_ov >>= listToMaybe . signatures_over)
                     $ \sig -> do
                let om = Map.singleton fname (origin sig (-1))
                    trust = Map.empty
                return $ KikiSuccess
                    ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
                                         , trust)],om) uids
                    , [] )

    try uids' $ \(uids',report) -> do

    let SubKey subkey_p subsigs = subkey
        wk = packet top
        (xs',minsig,ys') = findTag tags wk key subsigs
        doInsert mbsig db = do
            -- NEW SUBKEY BINDING SIGNATURE
            sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
            try sig' $ \(sig',report) -> do
            report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
            let subs' = Map.insert subkk
                                   (SubKey subkey_p $ xs'++[sig']++ys')
                                   subs
            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
                                 , report )

    report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
                                    else id
                  s = show (fmap fst minsig,fingerprint key)
              in return (f report)

    case minsig of
        Nothing          -> doInsert Nothing db    -- we need to create a new sig
        Just (True,sig)  -> -- we can deduce is_new == False
                            -- we may need to add a tor id
                            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
                                                 , report )
        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag

isCryptoCoinKey :: Packet -> Bool
isCryptoCoinKey p =
    and [ isKey p
        , key_algorithm p == ECDSA
        , lookup 'c' (key p) == Just (MPI secp256k1_id)
        ]

getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork
getCryptoCoinTag p | isSignaturePacket p = do
    -- CryptoCoins.secret
    let sps = hashed_subpackets p ++ unhashed_subpackets p
    u <- listToMaybe $ mapMaybe usage sps
    CryptoCoins.lookupNetwork CryptoCoins.network_name u
getCryptoCoinTag _ = Nothing


coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)]
coinKeysOwnedBy db wk = do
    wk <- maybeToList wk
    let kk = keykey wk
    KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
    (subkk,SubKey mp sigs) <- Map.toList subs
    let sub = packet mp
    guard $ isCryptoCoinKey sub
    tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
    return (tag,mp)

walletImportFormat :: Word8 -> Packet -> String
walletImportFormat idbyte k = secret_base58_foo
 where
    -- isSecret (SecretKeyPacket {}) = True
    -- isSecret _                    = False
    secret_base58_foo = base58_encode seckey
    Just d = lookup 'd' (key k)
    (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
    seckey = S.cons idbyte bigendian

writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
writeWalletKeys krd db wk = do
    let cs = db `coinKeysOwnedBy` wk
    -- export wallet keys
        isMutableWallet (fill -> KF_None)      = False
        isMutableWallet (typ -> WalletFile {}) = True
        isMutableWallet _                      = False
        files pred = do
            (f,stream) <- Map.toList (opFiles krd)
            guard (pred stream)
            resolveInputFile (InputFileContext "" "") f
    let writeWallet report n = do
        let cs' = do
            (nw,mp) <- cs
            -- let fns = Map.keys (locations mp)
            -- trace ("COIN KEY: "++show fns) $ return ()
            guard . not $ Map.member n (locations mp)
            let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
            return (CryptoCoins.network_name nw,wip)
        handleIO_ (return report) $ do
        -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based
        -- to InputFile-based.
        withFile n AppendMode $ \fh -> do
        rs <- forM cs' $ \(net,wip) -> do
            hPutStrLn fh wip
            return (n, NewWalletKey net)
        return (report ++ rs)
    report <- foldM writeWallet [] (files isMutableWallet)
    return $ KikiSuccess report

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 (key_algorithm p)++" "++fingerprint p
             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
             | otherwise = showPacket0 p
showPacket0 p = concat . take 1 $ words (show p)


-- | returns Just True so as to indicate that
-- the public portions of keys will be imported
importPublic :: Maybe Bool
importPublic = Just True

-- | returns False True so as to indicate that
-- the public portions of keys will be imported
importSecret :: Maybe Bool
importSecret = Just False


-- TODO: Do we need to memoize this?
guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe ()
guardAuthentic rt keydata = guard (isauth rt keydata)

isauth :: KeyRingRuntime -> KeyData -> Bool
isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
          where wk = workingKey (rtGrip rt) (rtKeyDB rt)
                dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
                                                   $ locations p
                has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
                 where
                    goodsig (uidstr,(sigs,_)) = not . null $ do
                        sig0 <- fmap (packet . fst) sigs
                        pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0])
                        signatures_over $ verify (Message [wk]) pre_ov

                workingKey grip use_db = listToMaybe $ do
                            fp <- maybeToList grip
                            elm <- Map.elems use_db
                            guard $ matchSpec (KeyGrip fp) elm
                            return $ keyPacket elm

writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
                    -> [(FilePath,KikiReportAction)]
                {-
                ->  KeyDB -> Maybe Packet
                -> FilePath -> FilePath
                -}
                -> IO (KikiCondition [(FilePath,KikiReportAction)])
writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
    let isring (KeyRingFile {}) = True
        isring _                = False
        db = rtKeyDB rt
        secring = rtSecring rt
        pubring = rtPubring rt
        ctx = InputFileContext secring pubring
    let s = do
        (f,f0,stream) <- do
            (f0,stream) <- Map.toList (opFiles krd)
            guard (isring $ typ stream)
            f <- resolveInputFile ctx f0
            return (f,f0,stream)
        let db' = fromMaybe db $ do
                    msg <- Map.lookup f0 unspilled
                    return $ merge db f0 msg
            x = do
                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
                    wantedForFill acc KF_None       = importByExistingMaster
                        -- Note the KF_None case is almost irrelevent as it will be
                        -- filtered later when isMutable returns False.
                        -- We use importByExistingMaster in order to generate
                        -- MissingPacket warnings.  To disable those warnings, use
                        -- const Nothing instead.
                    wantedForFill acc (KF_Match {}) = importByExistingMaster
                    wantedForFill acc KF_Subkeys    = importByExistingMaster
                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
                                                                importByAccess acc kd
                    wantedForFill acc KF_All        = importByAccess acc
                    importByAccess Pub kd = importPublic
                    importByAccess Sec kd = importSecret
                    importByAccess AutoAccess kd =
                        mplus (importByExistingMaster kd)
                              (error $ f ++ ": write public or secret key to file?")
                    importByExistingMaster kd@(KeyData p _ _ _) =
                        fmap originallyPublic $ Map.lookup f $ locations p
                d <- sortByHint f keyMappedPacket (Map.elems db')
                acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
                only_public <- maybeToList $ wantedForFill acc (fill stream) d
                guard $ only_public || isSecretKey (keyPacket d)
                case fill stream of
                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
                                         flattenTop f only_public
                                            $ filterNewSubs f (parseSpec grip usage) d
                    _              -> flattenTop f only_public d
            new_packets = filter isnew x
                where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
            -- TODO: We depend on an exact string match between the reported
            -- file origin of the deleted packet and the path of the file we are
            -- writing.  Verify that this is a safe assumption.
            isdeleted (f',DeletedPacket _) = f'==f
            isdeleted _                    = False
        guard (not (null new_packets) || any isdeleted report_manips)
        return ((f0,isMutable stream),(new_packets,x))
    let (towrites,report) = (\f -> foldl f ([],[]) s) $
         \(ws,report) ((f,mutable),(new_packets,x)) ->
            if mutable
                then
                     let rs = flip map new_packets
                                $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c))
                     in (ws++[(f,x)],report++rs)
                else
                     let rs = flip map new_packets
                                $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c)))
                     in (ws,report++rs)
    forM_ towrites $ \(f,x) -> do
        let m = Message $ map packet x
        -- warn $ "writing "++f
        writeInputFileL ctx f (encode m)
    return $ KikiSuccess report


{-
getSubkeysForExport kk subspec db = do
    kd <- maybeToList $ Map.lookup kk db
    subkeysForExport subspec kd
-}

-- | If provided Nothing for the first argument, this function returns the
-- master key of the given identity.  Otherwise, it returns all the subkeys of
-- the given identity which have a usage tag that matches the first argument.
subkeysForExport :: Maybe String -> KeyData -> [MappedPacket]
subkeysForExport subspec (KeyData key _ _ subkeys) = do
    let subs tag = do
            e <- Map.elems subkeys
            guard $ doSearch key tag e
            return $ subkeyMappedPacket e
    maybe [key] subs subspec
 where
    doSearch key tag (SubKey sub_mp sigtrusts) =
        let (_,v,_) = findTag [mkUsage tag]
                          (packet key)
                          (packet sub_mp)
                          sigtrusts
        in fmap fst v==Just True

writePEM :: String -> String -> String
writePEM typ dta = pem
 where
    pem = unlines . concat $
            [ ["-----BEGIN " <> typ <> "-----"]
            , split64s dta
            , ["-----END " <> typ <> "-----"] ]
    split64s :: String -> [String]
    split64s "" = []
    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta

    -- 64 byte lines

rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
    -- public fields...
    n <- lookup 'n' $ key pkt
    e <- lookup 'e' $ key pkt
    -- secret fields
    MPI d <- lookup 'd' $ key pkt
    MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
    MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped

    -- Note: Here we fail if 'u' key is missing.
    -- Ideally, it would be better to compute (inverse q) mod p
    -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
    --     (package constructive-algebra)
    coefficient <- lookup 'u' $ key pkt

    let dmodp1 = MPI $ d `mod` (p - 1)
        dmodqminus1 = MPI $ d `mod` (q - 1)
    return $ RSAPrivateKey
        { rsaN = n
        , rsaE = e
        , rsaD = MPI d
        , rsaP = MPI p
        , rsaQ = MPI q
        , rsaDmodP1 = dmodp1
        , rsaDmodQminus1 = dmodqminus1
        , rsaCoefficient = coefficient }
rsaPrivateKeyFromPacket _ = Nothing


writeKeyToFile ::
  Bool -> FileType -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
writeKeyToFile False PEMFile fname packet = do
    case key_algorithm packet of
     RSA -> do
        flip (maybe (return []))
             (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
            $ \rsa -> do
        let asn1 = toASN1 rsa []
            bs = encodeASN1 DER asn1
            dta = Base64.encode (L.unpack bs)
            output = writePEM "RSA PRIVATE KEY" dta
            stamp = toEnum . fromEnum $ timestamp packet
        handleIO_ (return [(fname, FailedFileWrite)]) $ do
            saved_mask <- setFileCreationMask 0o077
            -- Note: The key's timestamp is included in it's fingerprint.
            --       Therefore, we should attempt to preserve it.
            writeStamped (InputFileContext "" "") fname stamp output
            setFileCreationMask saved_mask
            return [(fname, ExportedSubkey)]
     algo -> return [(fname, UnableToExport algo $ fingerprint packet)]

writeKeyToFile False DNSPresentation fname packet = do
    case key_algorithm packet of
     RSA -> do
        flip (maybe (return []))
             (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
            $ \rsa -> do
        let -- asn1 = toASN1 rsa []
            -- bs = encodeASN1 DER asn1
            -- dta = Base64.encode (L.unpack bs)
            b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
             where
                MPI i = ac rsa
                i2bs_unsized :: Integer -> S.ByteString
                i2bs_unsized 0 = S.singleton 0
                i2bs_unsized i = S.reverse $ S.unfoldr go i
                 where go i' = if i' <= 0 then Nothing
                                          else Just (fromIntegral i', (i' `shiftR` 8))
            output = unlines
                [ "Private-key-format: v1.2"
                , "Algorithm: 8 (RSASHA256)"
                , "Modulus: " ++ b64 rsaN rsa
                , "PublicExponent: " ++ b64 rsaE rsa
                , "PrivateExponent: " ++ b64 rsaD rsa
                , "Prime1: " ++ b64 rsaP rsa
                , "Prime2: " ++ b64 rsaQ rsa
                , "Exponent1: " ++ b64 rsaDmodP1 rsa
                , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
                , "Coefficient: " ++ b64 rsaCoefficient rsa
                ]
            stamp = toEnum . fromEnum $ timestamp packet
        handleIO_ (return [(fname, FailedFileWrite)]) $ do
            saved_mask <- setFileCreationMask 0o077
            -- Note: The key's timestamp is included in it's fingerprint.
            --       Therefore, we should attempt to preserve it.
            writeStamped (InputFileContext "" "") fname stamp output
            setFileCreationMask saved_mask
            return [(fname, ExportedSubkey)]
     algo -> return [(fname, UnableToExport algo $ fingerprint packet)]

writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
                -> KeyDB
                -> [(FilePath,Maybe String,[MappedPacket],FileType,Maybe Initializer)]
                -> IO (KikiCondition [(FilePath,KikiReportAction)])
writePEMKeys doDecrypt db exports = do
    ds <- mapM decryptKeys exports
    let ds' = map functorToEither ds
    if null (lefts ds')
        then do
            rs <- mapM (\(f,typ,p) -> writeKeyToFile False typ (ArgFile f) p)
                       (rights ds')
            return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
        else do
            return (head $ lefts ds')
 where
    decryptKeys (fname,subspec,[p],typ,_) = do
        pun <- doDecrypt p
        try pun $ \pun -> do
        return $ KikiSuccess (fname,typ,pun)

makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
                        -> Map.Map KeyKey MappedPacket
                        -> IO (MappedPacket -> IO (KikiCondition Packet))
makeMemoizingDecrypter operation ctx keys =
   if null chains then  do
    -- (*) Notice we do not pass ctx to resolveForReport.
    -- This is because the merge function does not currently use a context
    -- and the pws map keys must match the MappedPacket locations.
    -- TODO: Perhaps these should both be of type InputFile rather than
    -- FilePath?
    -- pws :: Map.Map FilePath (IO S.ByteString)
    {-
    pws <-
        Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
                         (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
                            $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
    -}
        let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
        pws2 <- 
            Traversable.mapM (cachedContents prompt ctx)
             $ Map.fromList $ mapMaybe
                    (\spec -> (,passSpecPassFile spec) `fmap` do
                        guard $ isNothing $ passSpecKeySpec spec
                        passSpecRingFile spec)
                    passspecs
        defpw <- do
            Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
             $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
                                            && isNothing (passSpecKeySpec sp))
                                        $ opPassphrases operation
        unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
    else let PassphraseMemoizer f = head chains
         in return f
 where
    (chains,passspecs) = partition isChain $ opPassphrases operation
                            where isChain (PassphraseMemoizer {}) = True
                                  isChain _ = False
    doDecrypt :: IORef (Map.Map KeyKey Packet)
                -> Map.Map FilePath (IO S.ByteString)
                -> Maybe (IO S.ByteString)
                -> MappedPacket
                -> IO (KikiCondition Packet)
    doDecrypt unkeysRef pws defpw mp0 = do
        unkeys <- readIORef unkeysRef
        let mp = fromMaybe mp0 $ do
                    k <- Map.lookup kk keys
                    return $ mergeKeyPacket "decrypt" mp0 k
            wk = packet mp0
            kk = keykey wk
            fs = Map.keys $ locations mp

            decryptIt [] = return BadPassphrase
            decryptIt (getpw:getpws) = do
                -- TODO: This function should use mergeKeyPacket to 
                --  combine the packet with it's unspilled version before
                --  attempting to decrypt it.
                pw <- getpw
                let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
                case symmetric_algorithm wkun of
                    Unencrypted -> do
                        writeIORef unkeysRef (Map.insert kk wkun unkeys)
                        return $ KikiSuccess wkun
                    _ -> decryptIt getpws

            getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw

        case symmetric_algorithm wk of
            Unencrypted -> return (KikiSuccess wk)
            _ -> maybe (decryptIt getpws)
                       (return . KikiSuccess)
                    $ Map.lookup kk unkeys

performManipulations ::
                (MappedPacket -> IO (KikiCondition Packet))
                -> 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 ])

initializeMissingPEMFiles ::
    KeyRingOperation
      -> InputFileContext -> Maybe String
      -> (MappedPacket -> IO (KikiCondition Packet))
      -> KeyDB
      -> IO (KikiCondition ( (KeyDB,[( FilePath
                                     , Maybe String
                                     , [MappedPacket]
                                     , FileType
                                     , Maybe Initializer)])
                           , [(FilePath,KikiReportAction)]))
initializeMissingPEMFiles operation ctx grip decrypt db = do
        nonexistents <-
           filterM (fmap not . doesFileExist . fst)
               $ do (f,t) <- Map.toList (opFiles operation)
                    f <- resolveInputFile ctx f
                    return (f,t)

        let (missing,notmissing) = partition (\(_,_,ns,_,_)->null (ns >>= snd)) $ do
                (fname,stream) <- nonexistents
                guard $ isMutable stream
                guard $ isSecretKeyFile (typ stream)
                usage <- usageFromFilter (fill stream) -- TODO: Error if no result?
                let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
                    -- ms will contain duplicates if a top key has multiple matching
                    -- subkeys.  This is intentional.
                    -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
                    -- ms = filterMatches topspec $ Map.toList db
                    ns = do
                       (kk,kd) <- filterMatches topspec $ Map.toList db
                       return (kk , subkeysForExport subspec kd)
                return (fname,subspec,ns,(typ stream),initializer stream)
            (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd))
                                             notmissing
            exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,typ,cmd)) exports0

            ambiguity (f,topspec,subspec,_,_) = do
               return $ AmbiguousKeySpec f

            ifnotnull (x:xs) f g = f x
            ifnotnull _      f g = g

        ifnotnull ambiguous ambiguity $ do

        -- create nonexistent files via external commands
        do
           let cmds = mapMaybe getcmd missing
                 where
                   getcmd (fname,subspec,ms,typ,mcmd) = do
                       cmd <- mcmd
                       return (fname,subspec,ms,typ,cmd)
           rs <- forM cmds $ \tup@(fname,subspec,ms,typ,cmd) -> do
               e <- systemEnv [ ("file",fname)
                              , ("usage",fromMaybe "" subspec) ]
                              cmd
               case e of
                 ExitFailure num -> return (tup,FailedExternal num)
                 ExitSuccess     -> return (tup,ExternallyGeneratedFile)

           v <- foldM (importSecretKey decrypt)
                      (KikiSuccess (db,[])) $ do
                    ((f,subspec,ms,typ,cmd),r) <- rs
                    guard $ case r of
                       ExternallyGeneratedFile -> True
                       _ -> False
                    return (f,subspec,map fst ms,typ,cmd)

           try v $ \(db,import_rs) -> do
           return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
                                     ++ import_rs)
{-
interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
interpretManip kd manip = return kd
-}

combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
combineTransforms trans rt kd = updates
 where
    updates = -- kManip operation rt kd ++
              concatMap (\t -> resolveTransform t rt kd) sanitized
    sanitized = group (sort trans) >>= take 1

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

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



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

smallpr k = drop 24 $ fingerprint k

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 []       = []
    -}


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)

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


resolveTransform (DeleteSubKey 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


-- | Load and update key files according to the specified 'KeyRingOperation'.
runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
runKeyRing operation = do
    homedir <- getHomeDir (opHome operation)
    let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
        -- FIXME: try' should probably accept a list of KikiReportActions.
        --  This would be useful for reporting on disk writes that have already
        --  succeded prior to this termination.
        try' v body =
            case functorToEither v of
                   Left e -> return $ KikiResult e []
                   Right wkun -> body wkun
    try' homedir $ \(homedir,secring,pubring,grip0) -> do
    let ctx = InputFileContext secring pubring
        tolocks = filesToLock operation ctx 
    secring <- return Nothing
    pubring <- return Nothing
    lks <- forM tolocks $ \f -> do
        lk <- dotlock_create f 0
        v <- flip (maybe $ return Nothing) lk $ \lk -> do
                e <- dotlock_take lk (-1)
                if e==0 then return $ Just lk
                        else dotlock_destroy lk >> return Nothing
        return (v,f)
    let (lked, map snd -> failed_locks) = partition (isJust . fst) lks
    ret <-
      if not $ null failed_locks
       then return $ KikiResult (FailedToLock failed_locks) []
       else do

        -- merge all keyrings, PEM files, and wallets
        bresult <- buildKeyDB ctx grip0 operation
        try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do

        externals_ret <- initializeMissingPEMFiles operation
                                                   ctx
                                                   grip
                                                   decrypt
                                                   db
        try' externals_ret $ \((db,exports),report_externals) -> do

        let rt = KeyRingRuntime
                       { rtPubring = homepubPath ctx
                       , rtSecring = homesecPath ctx
                       , rtGrip = grip
                       , rtWorkingKey = fmap packet wk
                       , rtKeyDB = db
                       , rtRingAccess = accs
                       , rtPassphrases = decrypt
                       }

        r <- performManipulations decrypt
                                  rt
                                  wk
                                  (combineTransforms $ opTransforms operation)
        try' r $ \(rt,report_manips) -> do

        r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
        try' r $ \report_wallets -> do

        r <- writeRingKeys operation rt unspilled report_manips
        try' r $ \report_rings -> do

        r <- writePEMKeys decrypt (rtKeyDB rt) exports
        try' r $ \report_pems -> do
        
        import_hosts <- writeHostsFiles operation ctx hs

        return $ KikiResult (KikiSuccess rt)
                   $ concat [ report_imports
                            , report_externals
                            , report_manips
                            , report_wallets
                            , report_rings
                            , report_pems ]

    forM_ lked $ \(Just lk, fname) -> dotlock_release lk

    return ret

parseOptionFile :: FilePath -> IO [String]
parseOptionFile fname = do
    xs <- fmap lines (readFile fname)
    let ys = filter notComment xs
        notComment ('#':_) = False
        notComment cs      = not (all isSpace cs)
    return ys

-- | returns ( home directory
--           , path to secret ring
--           , path to public ring
--           , fingerprint of working key
--           )
getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
getHomeDir protohome = do
        homedir <- envhomedir protohome
        flip (maybe (return CantFindHome))
             homedir $ \homedir -> do
        -- putStrLn $ "homedir = " ++show homedir
        let secring = homedir ++ "/" ++ "secring.gpg"
            pubring = homedir ++ "/" ++ "pubring.gpg"
        -- putStrLn $ "secring = " ++ show secring
        workingkey <- getWorkingKey homedir
        return $ KikiSuccess (homedir,secring,pubring,workingkey)
 where
    envhomedir opt = do
        gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
        homed <- fmap (mfilter (/="") . Just) getHomeDirectory
        let homegnupg = (++('/':(appdir home))) <$> homed
        let val = (opt `mplus` gnupghome `mplus` homegnupg)
        return $ val

    -- TODO: rename this to getGrip
    getWorkingKey homedir = do
        let o = Nothing
            h = Just homedir
        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
                let optfiles = map (second ((h++"/")++))
                                   (maybe optfile_alts' (:[]) o')
                    optfile_alts' = zip (False:repeat True) (optfile_alts home)
                    o' = fmap (False,) o
                in filterM (doesFileExist . snd) optfiles
        args <- flip (maybe $ return []) ofile $
            \(forgive,fname) -> parseOptionFile fname
        let config = map (topair . words) args
                        where topair (x:xs) = (x,xs)
        return $ lookup "default-key" config >>= listToMaybe

#if MIN_VERSION_base(4,6,0)
#else
lookupEnv :: String -> IO (Maybe String) 
lookupEnv var =
    handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif

isKey :: Packet -> Bool
isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isUserID :: Packet -> Bool
isUserID (UserIDPacket {}) = True
isUserID _                 = False

isTrust :: Packet -> Bool
isTrust (TrustPacket {}) = True
isTrust _                = False

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]

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



slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
slurpWIPKeys stamp "" = ([],[])
slurpWIPKeys stamp cs =
    let (b58,xs) = Char8.span (`elem` base58chars) cs
        mb        = decode_btc_key stamp (Char8.unpack b58)
    in if L.null b58
        then let (ys,xs') = Char8.break (`elem` base58chars) cs
                 (ks,js)  = slurpWIPKeys stamp xs'
             in (ks,ys:js)
        else let (ks,js) = slurpWIPKeys stamp xs
             in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb


decode_btc_key ::
  Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
decode_btc_key timestamp str = do
    (network_id,us) <- base58_decode str
    return . (network_id,) $ Message $ do
        let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
            {-
            xy = secp256k1_G `pmul` d
            x = getx xy
            y = gety xy
            -- y² = x³ + 7 (mod p)
            y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
            y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
            -}
            secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
            ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
            -- pub = cannonical_eckey x y
            -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
            -- address = base58_encode hash
            -- pubstr = concatMap (printf "%02x") $ pub
            -- _ = pubstr :: String
        return $ {- trace (unlines ["pub="++show pubstr
                                ,"add="++show address
                                ,"y  ="++show y
                                ,"y' ="++show y'
                                ,"y''="++show y'']) -}
            SecretKeyPacket
            { version = 4
            , timestamp = toEnum (fromEnum timestamp)
            , key_algorithm = ECDSA
            , key = [ -- public fields...
                     ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
                    ,('l',MPI 256)
                    ,('x',MPI x)
                    ,('y',MPI y)
                    -- secret fields
                    ,('d',MPI d)
                    ]
            , s2k_useage = 0
            , s2k = S2K 100 ""
            , symmetric_algorithm = Unencrypted
            , encrypted_data = ""
            , is_subkey = True
            }

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


readPacketsFromWallet ::
    Maybe Packet
    -> InputFile
    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
readPacketsFromWallet wk fname = do
    let ctx = InputFileContext "" ""
    timestamp <- getInputFileTime ctx fname
    input <- readInputFileL ctx fname
    let (ks,_) = slurpWIPKeys timestamp input
    unless (null ks) $ do
        -- decrypt wk
        -- create sigs
        -- return key/sig pairs
        return ()
    return $ do
        wk <- maybeToList wk
        guard (not $ null ks)
        let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
                                where tag = CryptoCoins.nameFromSecretByte tagbyte
        (wk,MarkerPacket,(MarkerPacket,Map.empty))
         :map prep ks

readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
readPacketsFromFile ctx fname = do
    -- warn $ fname ++ ": reading..."
    input <- readInputFileL ctx fname
#if MIN_VERSION_binary(0,7,0)
    return $
      case decodeOrFail input of
        Right (_,_,msg ) -> msg
        Left  (_,_,_)    ->
          -- FIXME
          -- trace (fname++": read fail") $
          Message []
#else
    return $ decode input
#endif

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

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



-- | 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 = NotationDataPacket
                { human_readable = True
                , notation_name = "usage@"
                , notation_value = tag
                }

makeSig ::
  (MappedPacket -> IO (KikiCondition Packet))
  -> MappedPacket
  -> [Char]
  -> 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 = 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)
        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



data OriginFlags = OriginFlags {
        originallyPublic :: Bool,
        originalNum :: Int
    }
    deriving Show
type OriginMap = Map.Map FilePath OriginFlags
data MappedPacket = MappedPacket
        { packet :: Packet
        , locations :: OriginMap
        } deriving Show

type TrustMap = Map.Map FilePath Packet
type SigAndTrust = ( MappedPacket
                   , TrustMap     ) -- trust packets

type KeyKey = [ByteString]
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

origin :: Packet -> Int -> OriginFlags
origin p n = OriginFlags ispub n
 where
    ispub = case p of
                    SecretKeyPacket {} -> False
                    _                  -> True

mappedPacket :: FilePath -> Packet -> MappedPacket
mappedPacket filename p = MappedPacket
    { packet = p
    , locations = Map.singleton filename (origin p (-1))
    }

mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
mappedPacketWithHint filename p hint = MappedPacket
    { packet = p
    , locations = Map.singleton filename (origin p hint)
    }

keykey :: Packet -> KeyKey
keykey key =
    -- Note: The key's timestamp is normally included in it's fingerprint.
    --       This is undesirable for kiki because it causes the same
    --       key to be imported multiple times and show as apparently
    --       distinct keys with different fingerprints.
    --       Thus, we will remove the timestamp.
    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?

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

merge :: KeyDB -> InputFile -> Message -> KeyDB
merge db inputfile (Message ps) = merge_ db filename qs
 where
    filename = resolveForReport Nothing inputfile

    qs = scanPackets filename ps

    scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
    scanPackets filename [] = []
    scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
     where
        ret p = (p,Map.empty)
        doit (top,sub,prev) p =
            case p of
                _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
                _ | isKey p && is_subkey p       -> (top,p,ret p)
                _ | isUserID p                   -> (top,p,ret p)
                _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
                _                                -> (top,sub,ret p)

        updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
        updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
        updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret


{-
onionName :: KeyData -> (SockAddr,L.ByteString)
onionName kd = (addr,name)
 where
    (addr,(name:_,_)) = getHostnames kd
-}
keyCompare :: String -> Packet -> Packet -> Ordering
keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
keyCompare what a b | keykey a==keykey b = EQ
keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
                              , fingerprint a
                              , PP.ppShow a
                              , fingerprint b
                              , PP.ppShow b
                              ]

mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
mergeKeyPacket what key p = 
    key { packet = minimumBy (keyCompare what) [packet key,packet p]
        , locations = Map.union (locations key) (locations p)
        }


merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
                -> KeyDB
merge_ db filename qs = foldl mergeit db (zip [0..] qs)
 where
    asMapped n p = mappedPacketWithHint filename p n
    asSigAndTrust n (p,tm) = (asMapped n p,tm)
    emptyUids = Map.empty
    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
     where
        -- NOTE:
        --  if a keyring file has both a public key packet and a secret key packet
        --  for the same key, then only one of them will survive, which ever is
        --  later in the file.
        --
        --  This is due to the use of statements like
        --      (Map.insert filename (origin p n) (locations key))
        --
        update :: Maybe KeyData -> Maybe KeyData
        update v | isKey p && not (is_subkey p)
          = case v of
             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
                     -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
                                       sigs
                                       uids
                                       subkeys
             _       -> error . concat $ ["Unexpected master key merge error: "
                                         ,show (fingerprint top, fingerprint p)]
        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
        update (Just (KeyData key sigs uids subkeys)) | isUserID p
          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
                                    subkeys
        update (Just (KeyData key sigs uids subkeys))
          = case sub of
             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
             UserIDPacket {} -> Just $ KeyData key
                                               sigs
                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
                                               subkeys
             _  | isKey sub  -> Just $ KeyData key
                                               sigs
                                               uids
                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)

    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p

    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
    mergeSubkey n p (Just (SubKey key sigs)) = Just $
        SubKey (mergeKeyPacket "subs" key $ asMapped n p)
               sigs

    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p

    whatP (a,_) = concat . take 1 . words . show $ a


    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
    mergeSig n sig sigs =
      let (xs,ys) = break (isSameSig sig) sigs
      in if null ys
          then sigs++[first (asMapped n) sig]
          else let y:ys'=ys
               in xs ++ (mergeSameSig n sig y : ys')
     where
        isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
            a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
        isSameSig (a,_) (MappedPacket {packet=b},_) = a==b

        mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
        mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
          | isSignaturePacket a && isSignaturePacket b =
                ( m { packet = b { unhashed_subpackets =
                                      union (unhashed_subpackets b) (unhashed_subpackets a)
                                 }
                   , locations = Map.insert filename (origin a n) locs }
                -- TODO: when merging items, we should delete invalidated origins
                -- from the orgin map.
                , tb `Map.union` ta )

        mergeSameSig n a b = b -- trace ("discarding dup "++show a) b

    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)

    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
    mergeSubSig n sig Nothing = error $
        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)

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

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

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

flattenKeys :: Bool -> KeyDB -> Message
flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
 where
    prefilter = if isPublic then id else filter isSecret
                 where
                  isSecret (_,(KeyData
                                  (MappedPacket { packet=(SecretKeyPacket {})})
                                  _
                                  _
                                  _)) = True
                  isSecret _          = False


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

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

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

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

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

getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
 where
    othernames = do
        mp <- flattenAllUids "" True uids
        let p = packet mp
        guard $ isSignaturePacket p
        uh <- unhashed_subpackets p
        case uh of
            NotationDataPacket True "hostname@" v
              -> return $ Char8.pack v
            _ -> mzero

    addr = fingerdress topk
    -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
    topk = packet topmp
    torkeys = do
        SubKey k sigs <- Map.elems subs
        let subk = packet k
        let sigs' = do
                torsig <- filter (has_tag "tor") $ map (packet . fst) sigs
                sig <- (signatures $ Message [topk,subk,torsig])
                let v = verify (Message [topk]) sig
                -- Require parent's signature
                guard (not . null $ signatures_over v)
                let unhashed = unhashed_subpackets torsig
                    subsigs = mapMaybe backsig unhashed
                    -- This should consist only of 0x19 values
                    -- subtypes = map signature_type subsigs
                sig' <- signatures . Message $ [topk,subk]++subsigs
                let v' = verify (Message [subk]) sig'
                -- Require subkey's signature
                guard . not . null $ signatures_over v'
                return torsig
        guard (not $ null sigs')
        return subk
    has_tag tag p = isSignaturePacket p
                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
    -- subkeyPacket (SubKey k _ ) = k
    onames :: [L.ByteString]
    onames = map ( (<> ".onion")
                 . Char8.pack
                 . take 16
                 . torhash )
                 torkeys

hasFingerDress :: KeyDB -> SockAddr -> Bool
hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
 where
    (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
    g' = map toUpper g

-- We return into IO in case we want to make a signature here.
setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
    -- TODO: we are removing the origin from the UID OriginMap,
    --       when we should be removing origins from the locations
    --       field of the sig's MappedPacket records.
    -- Call getHostnames and compare to see if no-op.
    if not (pred addr) || names0 == names \\ onions 
        then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
                             , "                   file: "++show (map Char8.unpack names)
                             , "                   pred: "++show (pred addr)]) -}
                    (return kd)
        else do
    -- We should be sure to remove origins so that the data is written
    --   (but only if something changed).
    -- Filter all hostnames present in uids
    -- Write notations into first uid
    {-
    trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
                   , "                    file: "++show (map Char8.unpack names) ]) $ do
    -}
    return $ KeyData topmp topsigs uids1 subs
 where
    topk = packet topmp
    addr = fingerdress topk
    names :: [Char8.ByteString]
    names = Hosts.namesForAddress addr hosts
    (_,(onions,names0)) = getHostnames kd
    notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
    isName (NotationDataPacket True "hostname@" _) = True
    isName _ = False
    uids0 = fmap zapIfHasName uids
    fstuid = head $ do
        p <- map packet $ flattenAllUids "" True uids
        guard $ isUserID p
        return $ uidkey p
    uids1 = Map.adjust addnames fstuid uids0
    addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
     where
        (ss,ts) = splitAt 1 sigs
        f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
                                                       else (sig, tm)
         where p' = (packet sig) { unhashed_subpackets=uh }
               uh = unhashed_subpackets (packet sig) ++ notations
    zapIfHasName (sigs,om) = if or bs then (sigs',om)  -- XXX: removed om=Map.empty to preserve UserID origin
                                      else (sigs,om)
     where
        (bs, sigs') = unzip $ map unhash sigs

        unhash (sig,tm) = ( not (null ns)
                          , ( sig { packet = p', locations = Map.empty }
                            , tm ) )
         where
            psig = packet sig
            p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
                                           else psig
            uh = unhashed_subpackets psig
            (ns,ps) = partition isName uh

fingerdress :: Packet -> SockAddr
fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
 where
    zero = SockAddrInet 0 0
    addr_str = colons $  "fd" ++ drop 10 (map toLower $ fingerprint topk)
    colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
    colons xs                 = xs

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

socketFamily :: SockAddr -> Family
socketFamily (SockAddrInet _ _)      = AF_INET
socketFamily (SockAddrInet6 {}) = AF_INET6
socketFamily (SockAddrUnix _)        = AF_UNIX

#if ! MIN_VERSION_unix(2,7,0)
setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO ()
setFdTimesHiRes (Posix.Fd fd) atime mtime =
  withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
    throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times)

data CTimeSpec = CTimeSpec Posix.EpochTime CLong
instance Storable CTimeSpec where
    sizeOf    _ = (16)
    alignment _ = alignment (undefined :: CInt)
    poke p (CTimeSpec sec nsec) = do
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec
    peek p = do
        sec  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
        nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
        return $ CTimeSpec sec nsec

toCTimeSpec :: POSIXTime -> CTimeSpec
toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac)
  where
    (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
    (sec', frac') = properFraction $ toRational t

foreign import ccall unsafe "futimens"
    c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt
#endif

onionNameForContact :: KeyKey -> KeyDB -> Maybe String
onionNameForContact kk db = do
    contact <- Map.lookup kk db
    let (_,(name:_,_)) = getHostnames contact
    return $ Char8.unpack name