path: root/lib/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 PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
module KeyRing
    (
    -- * Error Handling
      KikiResult(..)
    , KikiCondition(..)
    , KikiReportAction(..)
    , errorString
    , reportString
    -- * Manipulating Keyrings
    , runKeyRing
    , KeyRingOperation(..)
    , PassphraseSpec(..)
    , Transform(..)
    -- , PacketUpdate(..)
    -- , guardAuthentic
    -- * Describing File Operations
    , StreamInfo(..)
    , Access(..)
    , FileType(..)
    , InputFile(..)
    , Initializer(..)
    , KeyFilter(..)
    -- * Results of a KeyRing Operation
    , KeyRingRuntime(..)
    , OriginMapped(..)
    , MappedPacket
    , KeyDB
    , KeyData(..)
    , SubKey(..)
    , keyflags
    -- * Miscelaneous Utilities
    , isKey
    , isSecretKey
    , derRSA
    , derToBase32
    , backsig
    , filterMatches
    , flattenKeys
    , flattenTop
    , Hosts.Hosts
    , isCryptoCoinKey
    , matchpr
    , parseSpec
    , Spec
    , parseUID
    , UserIDRecord(..)
    , pkcs8
    , RSAPublicKey(..)
    , PKCS8_RSAPublicKey(..)
    , rsaKeyFromPacket
    , secretToPublic
    , selectPublicKey
    , selectSecretKey
    , usage
    , usageString
    , walletImportFormat
    , writePEM
    , getBindings
    , accBindings
    , isSubkeySignature
    , torhash
    , torUIDFromKey
    , ParsedCert(..)
    , parseCertBlob
    , packetFromPublicRSAKey
    , decodeBlob
    , selectPublicKeyAndSigs
    , x509cert
    , getHomeDir
    , unconditionally
    , SecretPEMData(..)
    , readSecretPEMFile
    , writeInputFileL
    , InputFileContext(..)
    , onionNameForContact
    , keykey
    , keyPacket
    , KeySpec(..)
    , MatchingField(..)
    , SpecError(..)
    , SingleKeySpec(..)
    , parseSpec3
    , getHostnames
    , secretPemFromPacket
    , SubkeyStatus(..)
    , getSubkeys
    , writeKeyToFile
    , resolveForReport
    , KeyKey -- needed for Type sigs
    , makeMemoizingDecrypter
    , showPacket
    ) where

import System.Environment
import Control.Monad
import Control.Exception ( catch )
import System.IO.Error ( isDoesNotExistError )
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
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
import qualified Data.ByteString      as S
#if defined(VERSION_memory)
import qualified Data.ByteString.Char8 as S8
import Data.ByteArray.Encoding
#elif defined(VERSION_dataenc)
import qualified Codec.Binary.Base32 as Base32
import qualified Codec.Binary.Base64 as Base64
#endif
#if !defined(VERSION_cryptonite)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Types.PubKey.ECC as ECC
#else
import qualified Crypto.Hash as Vincent
import Data.ByteArray (convert)
import qualified Crypto.PubKey.ECC.Types as ECC
#endif
import 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, stderr, hClose)
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) )
import GnuPGAgent as Agent
import Types
import PacketTranscoder
import Transforms

-- 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"]
    }

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

isMutable :: StreamInfo -> Bool
isMutable stream | KF_None <- fill stream = 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


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 PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show

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

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"



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

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

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




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 KeySpec =
      KeyGrip String       -- fp:
    | KeyTag Packet String -- fp:????/t:
    | KeyUidMatch String   -- u:
 deriving Show

data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
data SingleKeySpec = FingerprintMatch String
                   | SubstringMatch (Maybe MatchingField) String
                   | EmptyMatch
                   | AnyMatch
                   | WorkingKeyMatch
 deriving (Show,Eq,Ord)

getStr (FingerprintMatch x) = x
getStr (SubstringMatch _ x) = x
getStr _ = ""

-- | Spec
--
-- The product type, SingleKeySpec³ = Circle × Identity × Key.
--
--  Key      -   A single public or private key (subkey, or master without subkeys) (eg, pem file)
--  Identity -   A single master key with all its subkeys
--  Circle   -   A collection of master keys with their subkeys                     (eg, gpg file)
--
-- The three fields are deliminated by slashes.
--
-- When context does not disambiguate, use the following default rules:
-- There are(is)
--    - no slashes,  so interpret as Key
--    - one slash,   so interpret as Identity/Key
--    - two slashes, so interpret as Circle/Identity/Key
--
-- (Any of the fields may be left empty.)
type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec)

parseSingleSpec :: String -> SingleKeySpec
parseSingleSpec "*"              = AnyMatch
parseSingleSpec "-"              = WorkingKeyMatch
parseSingleSpec ""               = EmptyMatch
parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
parseSingleSpec ('c':':':tag)    = SubstringMatch (Just GroupIDField) tag
parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
parseSingleSpec str
    | is40digitHex str = FingerprintMatch str
    | otherwise        = SubstringMatch Nothing str

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

data SpecError = SpecENone String
               | SpecEMissMatch String (Maybe MatchingField) MatchingField
               | SpecETooBig    Spec
               | SpecETooMany String
        deriving (Eq,Show,Ord)

  --  t:tor            -- (AnyMatch  ,                 AnyMatch,                  SubstringMatch type "tor")
  --  u:joe            -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch ""      )
  --  u:joe/           -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch "!"     )
  --  fp:4A39F/tor     -- (AnyMatch  ,                 FingerprintMatch "4A39F",  SubstringMatch type "tor")
  --  u:joe/tor        -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
  --  u:joe/t:tor      -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
  --  u:joe/fp:4abf30  -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch "4abf30")
  --  joe/tor          -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
  --  u:joe//fp:4abf30 -- (SubstringMatch user "joe",  AnyMatch                 , FingerprintMatch "4abf30")
  --  c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch                 , FingerprintMatch "4abf3" )
  --
  --                    where type = Just KeyTypeField
  --                          user = Just UserIDField
  --                          circ = Just GroupIDField

-- | parseSpec3 - Parse a key specification.
parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec
parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = 
  tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$> 
    case fields of
        []         -> Left (SpecENone spec)
        xs@[t]     -> 
                  let ds = [0]
                      x  = l ds xs
                      getTup1 [x] = tupSection1 (adjustPos x maybeExpecting) x
                        where
                          tupSection1 0 = (AnyMatch,AnyMatch,)
                          tupSection1 1 = (AnyMatch,,AnyMatch)
                          tupSection1 2 = (,AnyMatch,AnyMatch)
                          tupSection1 _ = tupSection1 0 
                      in if all fst x then Right $ getTup1 (map (fst . snd) x)
                                      else Left $ mismatch x
        xs@[u,t]   -> 
                  let ds = [1,0]
                      x  = l ds xs
                      getTup2 [u,t] = indexHole (head (filter (`notElem` gots [u,t]) [0..2])) u t
                        where gots xs = zipWith gotIndex [1,0] xs
                              indexHole 0 = (,,AnyMatch)
                              indexHole 1 = (,AnyMatch,)
                              indexHole 2 = (AnyMatch,,)
                      in if all fst x then Right $ getTup2 (map (fst . snd) x)
                                      else Left $ mismatch x
        xs@[c,u,t] ->
                  let ds = [2,1,0]
                      x  = l ds xs
                      getTup3 [a,b,c] = (a,b,c)
                      in if all fst x then Right $ getTup3 (map (fst . snd) x)
                                      else Left $ mismatch x
        _          -> Left (SpecETooMany spec)
        where expectIndex dflt = maybe dflt fromEnum maybeExpecting

              l :: [Int] -> [String] -> [(Bool, (SingleKeySpec,Int))]
              l defaults specs = zipWith (\x y -> (valid (p x) y, (p x,y))) specs defaults
                    where p x = parseSingleSpec x

              valid :: SingleKeySpec -> Int -> Bool
              valid spec dflt = ("tuc"::String) !! gotIndex dflt spec `notElem` forbidden (gotIndex dflt spec)
                where
                  forbidden 0 = "uc" :: [Char]
                  forbidden 1 = "tc"
                  forbidden 2 = "tu"

              adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0
              adjustPos (SubstringMatch (Just UserIDField)  _) Nothing = 1
              adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2
              adjustPos _ (Just i) = fromEnum i

              gotIndex :: Int -> SingleKeySpec -> Int
              gotIndex dflt (SubstringMatch (Just got) _) = fromEnum got
              gotIndex dflt _ = dflt 

              -- FIXME: This throws an exception if input is
              --        not an erroneous SubstringMatch.
              mismatch :: [(Bool,(SingleKeySpec,Int))] -> SpecError
              mismatch xs = case find (not . fst)  (reverse xs) of
                                    Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n)

              fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t)
                where
                    set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs
                    set _ EmptyMatch = AnyMatch
                    set field x = x

              applyContext :: Maybe MatchingField -> Spec -> Spec
              applyContext Nothing x = x

              applyContext (Just KeyTypeField) ((AnyMatch,u,AnyMatch)) = (AnyMatch,AnyMatch,u)
              applyContext (Just KeyTypeField) ((g,u,AnyMatch)) = (g,AnyMatch,u)
              applyContext (Just KeyTypeField) x = x

              applyContext (Just UserIDField) ((AnyMatch,AnyMatch,x)) = (AnyMatch,x,AnyMatch)
              applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x)
              applyContext (Just UserIDField) x = x

              applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch)
              applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x)
              applyContext (Just GroupIDField) x = x

              --applyContext (Just UserIDField) (Right (g,u,x)) = Left $ 
              --  SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField
              tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $
                SpecEMissMatch str (Just GroupIDField) KeyTypeField
              tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $
                SpecEMissMatch str (Just GroupIDField) UserIDField

              tooBigError Nothing             x = return x
              tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $
                SpecETooBig s -- (getStr g) (Just GroupIDField) UserIDField
              tooBigError (Just KeyTypeField) s@(g,u,t) | g /= AnyMatch = Left $
                SpecETooBig s --(getStr g) (Just GroupIDField) KeyTypeField
              tooBigError _ x = return x

wordsBy _ [] = []
wordsBy c xs = let (b,a) = span (/=c) xs
                   in b:wordsBy c (drop 1 a)



-- | Parse a key specification.
-- The first argument is a grip for the default working key.
parseSpec :: String -> String -> (KeySpec,Maybe String)
parseSpec wkgrip spec =
    if not slashed
        then
            case prespec of
                AnyMatch                               -> (KeyGrip "", Nothing)
                EmptyMatch                             -> error "Bad key spec."
                WorkingKeyMatch                        -> (KeyGrip wkgrip, Nothing)
                SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
                SubstringMatch Nothing str             -> (KeyGrip wkgrip, Just str)
                SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
                FingerprintMatch fp                    -> (KeyGrip fp, Nothing)
        else
            case (prespec,postspec) of
                (FingerprintMatch fp, SubstringMatch st t)
                    | st /= Just UserIDField                -> (KeyGrip fp, Just t)
                (SubstringMatch mt u, _)
                    | postspec `elem` [AnyMatch,EmptyMatch]
                      && mt /= Just KeyTypeField            -> (KeyUidMatch u, Nothing)
                (SubstringMatch mt u, SubstringMatch st t)
                    | mt /= Just KeyTypeField
                      && st /= Just UserIDField             -> (KeyUidMatch u, Just t)
                (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
                (_,FingerprintMatch fp)                 -> error "todo: support /fp: spec"
                (FingerprintMatch fp,_)                 -> error "todo: support fp:/ spec"
                _                                       -> error "Bad key spec."
 where
    (preslash,slashon) = break (=='/') spec
    slashed = not $ null $ take 1 slashon
    postslash = drop 1 slashon

    prespec = parseSingleSpec preslash
    postspec = parseSingleSpec postslash

{-
 - BUGGY
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 _                = ""


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 (\h x-> hPutStr h x >> hClose h)  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
-}


generateSubkey ::
  PacketTranscoder
  -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
  -> (GenerateKeyParams, StreamInfo)
  -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
    try kd' $ \(kd,report0) -> do
    let subs = do
            SubKey p sigs <- Map.elems $ keySubKeys kd
            filter (has_tag tag) $ map (packet . fst) sigs
    if null subs
      then do
        newkey <- generateKey genparam
        kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
        try kdr $ \(newkd,report) -> do
        return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
      else do
        return $ KikiSuccess (kd,report0)
generateSubkey _ kd _ = return kd

importSecretKey ::
  (PacketTranscoder)
  -> KikiCondition
       (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
  -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
  -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
importSecretKey transcode db' tup = do
            try db' $ \(db',report0) -> do
            r <- doImport transcode
                      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

        readInputFileL' ctx f =
            readInputFileL ctx f
                `catch` \e -> do when (not $ isDoesNotExistError e) $ do
                                   return () -- todo report problem
                                 return L.empty

    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 stream | KF_None <- fill stream = False
        isMutableHosts stream | Hosts <- typ stream    = 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

-- | buildKeyDB
--
--   merge all keyrings, PEM files, and wallets into process memory.
--
buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
              -> IO (KikiCondition (({- db        -} KeyDB
                                    ,{- grip      -} Maybe String
                                    ,{- wk        -} Maybe MappedPacket
                                    ,{- hs        -} ({- hostdbs0 -}[Hosts.Hosts],
                                                      {- hostdbs  -}[Hosts.Hosts],
                                                      {- u1       -}Hosts.Hosts,
                                                      {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
                                                      {- outgoing_names -}[SockAddr])
                                    ,{- accs      -} Map.Map InputFile Access
                                    ,{- doDecrypt -} PacketTranscoder
                                    ,{- unspilled -} Map.Map InputFile Message
                                    )
                                   ,{- report_imports -} [(FilePath,KikiReportAction)]))
buildKeyDB ctx grip0 keyring = do
    let files istyp = do
            (f,stream) <- Map.toList (opFiles keyring)
            guard (istyp $ typ stream)
            return f -- resolveInputFile ctx f

        ringMap0 = Map.filter (isring . typ) $ opFiles keyring
        (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
            where
                isgen (Generate _ _) _ = True
                isgen _              _ = False

        readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message)
        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 n)

    -- KeyRings (todo: KikiCondition reporting?)
    (spilled,mwk,grip,accs,keyqs,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
            --    ring packets with info available for export
            -- | unspilled 
            --    the rest
            (spilled,unspilled) = Map.partition (spillable . fst) ringPackets

            -- | keys
            -- process ringPackets, and get a map of fingerprint info to 
            -- to a packet, remembering it's original file, access.
            keys :: Map.Map KeyKey (OriginMapped Query)
            mwk :: Maybe MappedPacket
            (mwk, keys) = keyQueries grip ringPackets

            -- | accs
            -- file access(Sec | Pub) lookup table
            accs :: Map.Map InputFile Access
            accs = fmap (access . fst) ringPackets
        return (spilled,mwk,grip,accs,keys,fmap snd unspilled)

    transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
    let doDecrypt = transcode (Unencrypted,S2K 100 "")

    let wk = fmap packet mwk
        rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
                             , rtSecring = homesecPath ctx
                             , rtGrip = grip
                             , rtWorkingKey = wk
                             , rtRingAccess = accs
                             , rtKeyDB = Map.empty
                             , rtPassphrases = transcode
                             }
    -- autosigns and deletes
    transformed0 <-
        let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
            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,rtKeyDB rt2)
        -- XXX: Unspilled keys are not obtainable from rtKeyDB.
        --  If the working key is marked non spillable, then how
        --  would we look up it's UID and such?
#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 - all keyrings combined into one 
        db_rings :: Map.Map KeyKey KeyData
        db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
                    where
                      mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData  db dbtrans
        -- | reportTrans
        -- events, indexed by file
        reportTrans :: [(FilePath, KikiReportAction)]
        reportTrans = concat $ Map.elems $ fmap fst transformed

    -- Wallets
    let importWalletKey wk db' (top,fname,sub,tag) = do
            try db' $ \(db',report0) -> do
            r <- doImportG transcode
                      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
            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?
            -- TODO: parseSpec3
            let (topspec,subspec) = parseSpec grip usage
                ms = map fst $ filterMatches topspec (Map.toList db)
                cmd = initializer stream
            return (n,subspec,ms,stream, cmd)

    imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
                              _                   -> return True)
                       pems
    db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
    try db $ \(db,reportPEMs) -> do

    -- generate keys
    let gens = mapMaybe g $ Map.toList genMap
                where g (Generate _ params,v) = Just (params,v)
                      g _                     = Nothing

    db <- generateInternals transcode mwk db gens
    try db $ \(db,reportGens) -> do

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

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

generateInternals ::
    PacketTranscoder
    -> Maybe MappedPacket
    -> Map.Map KeyKey KeyData
    -> [(GenerateKeyParams,StreamInfo)]
    -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
generateInternals transcode mwk db gens = do
    case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
        Just kd0 -> do
            kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
            try kd $ \(kd,reportGens) -> do
            let kk = keykey $ packet $ fromJust mwk
            return $ KikiSuccess (Map.insert kk kd db,reportGens)
        Nothing -> return $ KikiSuccess (db,[])

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

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
#if defined(VERSION_memory)
     where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob)
    bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
     where
        nlen = S.length bs
#elif defined(VERSION_dataenc)
     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
#endif


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
  :: PacketTranscoder
     -> Map.Map KeyKey KeyData
     -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
    flip (maybe $ return CannotImportMasterKey)
         subspec $ \tag -> do
    (certs,keys) <- case typ of
        PEMFile -> do
            ps <- readSecretPEMFile fname
            let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
                    = partition (isJust . spemCert) ps
            return (certs,keys)
        DNSPresentation -> do
            p <- readSecretDNSFile 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 (resolveForReport Nothing 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 transcode db m0 (mkUsage tag:blobs) fname datedKey
                try r $ \(db',report') -> do
                return $ KikiSuccess (db',report++report')

doImportG
  :: PacketTranscoder
     -> Map.Map KeyKey KeyData
     -> [KeyKey] -- m0,  only head is used
     -> [SignatureSubpacket] -- tags
     -> InputFile
     -> Packet
     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
doImportG transcode db m0 tags fname key = do
    let kk = head m0
        Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
    kdr <- insertSubkey transcode kk kd tags fname key
    try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)

insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
    let topcipher = symmetric_algorithm $ packet top
        tops2k    = s2k $ packet top
        doDecrypt = transcode (Unencrypted,S2K 100 "")
        fname = resolveForReport Nothing inputfile
        subkk = keykey key0
        istor = do
            guard ("tor" `elem` mapMaybe usage tags)
            return $ torUIDFromKey key0
        addOrigin (SubKey mp sigs) =
                                    let mp' = mp
                                          { locations = Map.insert fname
                                                             (origin (packet mp) (-1))
                                                             (locations mp) }
                                    in SubKey mp' sigs

    subkey_result <- do
        case Map.lookup subkk subs of
            Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing)
            Nothing  -> do
                wkun' <- doDecrypt top
                try wkun' $ \wkun -> do
                key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
                try key' $ \key -> do
                return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key))


    try subkey_result $ \(is_new,subkey,decrypted) -> do

    let subs' = Map.insert subkk subkey subs

    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

                let keyflags = keyFlags (error "dummy argument (insertSubkey)") (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) (packet top) uid keyflags
                wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted
                try wkun' $ \wkun -> do
                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 key0 subsigs
        doInsert mbsig = do
            -- NEW SUBKEY BINDING SIGNATURE
            -- XXX: Here I assume that key0 is the unencrypted version
            --      of subkey_p.  TODO: Check this assumption.
            sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} 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 ( KeyData top topsigs uids' subs'
                                 , report )

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

    case minsig of
        Nothing          -> doInsert Nothing -- 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 ( KeyData top topsigs uids' subs'
                                                 , report )
        Just (False,sig) -> doInsert (Just sig) -- 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 stream | KF_None <- fill stream      = False
        isMutableWallet stream | WalletFile {} <- typ stream = 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

-- | 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 -- TODO: parseSpec3
                    _              -> 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

secretPemFromPacket :: Packet -> Maybe String
secretPemFromPacket packet = pemFromPacket Sec packet

pemFromPacket :: Access -> Packet -> Maybe String
pemFromPacket Sec packet =
    case key_algorithm packet of
     RSA -> do
        rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
        let asn1 = toASN1 rsa []
            bs = encodeASN1 DER asn1
#if defined(VERSION_memory)
            dta = S8.unpack $ convertToBase Base64 (L.toStrict bs)
#elif defined(VERSION_dataenc)
            dta = Base64.encode (L.unpack bs)
#endif
            output = writePEM "RSA PRIVATE KEY" dta
        Just output
     algo -> Nothing
pemFromPacket Pub packet =
    case key_algorithm packet of
     RSA -> do
        rsa <- rsaKeyFromPacket packet
        let asn1 = toASN1 (pkcs8 rsa) []
            bs = encodeASN1 DER asn1
#if defined(VERSION_memory)
            dta = S8.unpack $ convertToBase Base64 (L.toStrict bs)
#elif defined(VERSION_dataenc)
            dta = Base64.encode (L.unpack bs)
#endif
            output = writePEM "PUBLIC KEY" dta
        Just output
     algo -> Nothing
pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p
pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p
pemFromPacket AutoAccess _ = Nothing

writeKeyToFile ::
  StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
writeKeyToFile stream@(StreamInfo { typ = PEMFile }) fname packet = do
    case pemFromPacket (access stream) packet of
     Just output -> do
        let 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)]
     Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]

writeKeyToFile StreamInfo { typ = 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)
#if defined(VERSION_memory)
            b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i
#elif defined(VERSION_dataenc)
            b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
#endif
             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 :: (PacketDecrypter)
                -> KeyDB
                -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
                -> 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,stream,p) -> writeKeyToFile stream (ArgFile f) p)
                       (rights ds')
            return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
        else do
            return (head $ lefts ds')
 where
    decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
        = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
    decryptKeys (fname,subspec,[p],stream) = do
        pun <- doDecrypt p
        try pun $ \pun -> do
        return $ KikiSuccess (fname,stream,pun)

initializeMissingPEMFiles ::
    KeyRingOperation
      -> InputFileContext
      -> Maybe String
      -> Maybe MappedPacket
      -> PacketTranscoder
      -> KeyDB
      -> IO (KikiCondition ( (KeyDB,[( FilePath
                                     , Maybe String
                                     , [MappedPacket]
                                     , StreamInfo )])
                           , [(FilePath,KikiReportAction)]))
initializeMissingPEMFiles operation ctx grip mwk transcode db = do
        let decrypt = transcode (Unencrypted,S2K 100 "")

        -- nonexistants - files missing from disk.
        nonexistents <-
           filterM (fmap not . doesFileExist . fst)
               $ do (f,t) <- Map.toList (opFiles operation)
                    f <- resolveInputFile ctx f
                    return (f,t)

        -- missing - mutable files not in the keyring and not on disk
        -- notmissing - mutable keys in the keyring, but not on disk
        let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
                (fname,stream) <- nonexistents
                let mutableTag
                        | isMutable stream = usageFromFilter (fill stream)
                        | otherwise        = Nothing
                usage <- maybeToList mutableTag
                -- TODO: Use parseSpec3
                -- TODO: Report error if generating without specifying usage tag.
                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,stream)
            (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
                                             notmissing
            exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) 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,stream) = do
                       cmd <- case initializer stream of
                                External str -> Just str
                                _            -> Nothing
                       return (fname,subspec,ms,stream,cmd)
           rs <- forM cmds $ \tup@(fname,subspec,ms,stream,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 transcode)
                      (KikiSuccess (db,[])) $ do
                    ((f,subspec,ms,stream,cmd),r) <- rs
                    guard $ case r of
                       ExternallyGeneratedFile -> True
                       _ -> False
                    return (ArgFile f,subspec,map fst ms,stream,cmd)

           try v $ \(db,import_rs) -> do

           -- generateInternals
           let internals = mapMaybe getParams $ do
                    (f,stream) <- nonexistents
                    usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
                    let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
                    guard $ null $ do
                        (kk,kd) <- filterMatches topspec $ Map.toList db
                        subkeysForExport subspec kd
                    return (f,stream)
                where
                    getParams (fname,stream) =
                        case initializer stream of
                            Internal p -> do _ <- internalInitializer stream
                                             Just $ Right (p, stream)
                            WarnMissing warning -> Just $ Left warning
                            _          -> Nothing

                    internalInitializer StreamInfo
                        { initializer = Internal _
                        , spill       = KF_Match tag } = Just tag
                    internalInitializer _              = Nothing

           mapM_ (hPutStrLn stderr) (lefts internals)
           v <- generateInternals transcode mwk db (rights internals)

           try v $ \(db,internals_rs) -> do

           return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
                                     ++ import_rs ++ internals_rs)

-- | combineTransforms 
-- remove rundant transforms, and compile the rest to PacketUpdate(s)
--
-- eqivalent to:
-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt 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



-- | Load and update key files according to the specified 'KeyRingOperation'.
runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
runKeyRing operation = do
    -- get homedir and keyring files + fingerprint for working key
    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
        createDirectoryIfMissing True $ takeDirectory f
        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,transcode,unspilled),report_imports) -> do

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

        let decrypt = transcode (Unencrypted,S2K 100 "")
            rt = KeyRingRuntime
                       { rtPubring = homepubPath ctx
                       , rtSecring = homesecPath ctx
                       , rtGrip = grip
                       , rtWorkingKey = fmap packet wk
                       , rtKeyDB = db
                       , rtRingAccess = accs
                       , rtPassphrases = transcode
                       }

        -- Maybe add signatures, delete subkeys
        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

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
            }


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


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


merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
                -> KeyDB
merge_ db filename qs = foldl mergeit db (zip [0..] qs)
 where
    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
    mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
      where
        update Nothing   = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
        update (Just kd) = dbInsertPacket kd filename adding
    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p

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



mergeKeyData :: KeyData -> KeyData -> KeyData
mergeKeyData (KeyData atop asigs auids asubs)
             (KeyData btop  bsigs buids bsubs)
    = KeyData top sigs uids subs
 where
    mergeMapped a b =
        MappedPacket { packet = packet a
                     , locations = Map.union (locations a) (locations b)
                     }

    top = mergeMapped atop btop

    sigs = foldl' (flip mergeSig) asigs bsigs

    uids = Map.unionWith mergeUIDSigs auids buids
    subs = Map.unionWith mergeSub asubs bsubs

    mergeSub :: SubKey -> SubKey -> SubKey
    mergeSub (SubKey a as) (SubKey b bs) =
        SubKey (mergeMapped a b)
               (foldl' (flip mergeSig) as bs)

    mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
                    -> ([SigAndTrust],OriginMap)
    mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)


dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
 where
    asMapped n p = mappedPacketWithHint filename p n
    asSigAndTrust n (p,tm) = (asMapped n p,tm)

    -- 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) [] Map.empty 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 (first (flip (mappedPacketWithHint filename) 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)

    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


    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) 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 (first (flip (mappedPacketWithHint filename) n) sig) sigs)
    mergeSubSig n sig Nothing = error $
        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)

mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
mergeSig sig sigs =
      let (xs,ys) = break (isSameSig (first packet sig)) sigs
      in if null ys
          then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig]
          else let y:ys'=ys
               in xs ++ (mergeSameSig 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 :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
        mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
          | isSignaturePacket (packet a) && isSignaturePacket b =
                ( m { packet = b { unhashed_subpackets =
                                      union (unhashed_subpackets b) (unhashed_subpackets $ packet a)
                                 }
                   , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs }
                -- TODO: when merging items, we should delete invalidated origins
                -- from the orgin map.
                , tb `Map.union` ta )

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


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


data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
 deriving (Eq,Ord,Enum,Show,Read)

getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
getSubkeys ck topk subs tag = do
        SubKey k sigs <- Map.elems subs
        let subk = packet k
        let sigs' = do
                -- require tag
                torsig <- filter (has_tag tag) $ map (packet . fst) sigs

                -- require parent's signature
                when (ck > Unsigned) $ do
                    sig <- (signatures $ Message [topk,subk,torsig])
                    let v = verify (Message [topk]) sig
                    -- Require parent's signature
                    guard (not . null $ signatures_over v)

                -- require child's back signature
                when (ck == CrossSigned ) $ do
                    let unhashed = unhashed_subpackets torsig
                        subsigs = mapMaybe backsig unhashed
                        -- This should consist only of 0x19 values
                        -- subtypes = map signature_type subsigs
                    -- subtyp <- subtypes
                    -- guard (subtyp == 0x19)
                    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

-- |
-- Returns (ip6 fingerprint address,(onion names,other host names))
--
-- Requires a validly cross-signed tor key for each onion name returned.
-- (Signature checks are performed.)
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 = getSubkeys CrossSigned topk subs "tor"

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

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
    case getHostnames contact of
        (_,(name:_,_)) -> Just $ Char8.unpack name
        _              -> Nothing