path: root/KeyRing.hs

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

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



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

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

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

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

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

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

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

-- type UsageTag = String
type Initializer = String

data FileType = KeyRingFile
              | PEMFile
              | WalletFile
              | Hosts

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

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

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


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

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

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

ispem :: FileType -> Bool
ispem (PEMFile {}) = True
ispem _            = False

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

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

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

data KeyRingRuntime = KeyRingRuntime
                        { rtPubring :: FilePath
                        -- ^ Path to the file represented by 'HomePub'
                        , rtSecring :: FilePath
                        -- ^ Path to the file represented by 'HomeSec'
                        , rtGrip :: Maybe String
                        -- ^ Fingerprint or portion of a fingerprint used
                        -- to identify the working GnuPG identity used to
                        -- make signatures.
                        , rtWorkingKey :: Maybe Packet
                        -- ^ The master key of the working GnuPG identity.
                        , rtKeyDB :: KeyDB
                        -- ^ The common information pool where files spilled
                        -- their content and from which they received new
                        -- content.
                        , rtRingAccess :: Map.Map InputFile Access
                        -- ^ The 'Access' values used for files of type
                        -- 'KeyRingFile'.  If 'AutoAccess' was specified
                        -- for a file, this 'Map.Map' will indicate the
                        -- detected value that was used by the algorithm.
                        , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet)
                        }

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

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

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

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

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

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

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


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

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

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

instance ASN1Object RSAPublicKey where
    -- PKCS #1 RSA Public Key
    toASN1 (RSAKey (MPI n) (MPI e))
                  = \xs -> Start Sequence
                         : IntVal n
                         : IntVal e
                         : End Sequence
                         : xs
    fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
        Right (RSAKey (MPI n) (MPI e), xs)

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

instance ASN1Object PKCS8_RSAPublicKey where

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

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

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

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

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

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



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

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

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

-- | This type is used to describe events triggered by 'runKeyRing'.  In
-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
-- non-fatal IO exceptions (e.g. 'FailedExternal').  Because a
-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
-- many inputs and outputs, an operation may be partially (or even mostly)
-- successful even when I/O failures occured.  In this situation, the files may
-- not have all the information they were intended to store, but they will be
-- in a valid format for GnuPG or kiki to operate on in the future.
data KikiReportAction =
        NewPacket String
        | MissingPacket String
        | ExportedSubkey
        | GeneratedSubkeyFile
        | NewWalletKey String
        | YieldSignature
        | YieldSecretKeyPacket String
        | UnableToUpdateExpiredSignature
        | WarnFailedToMakeSignature
        | FailedExternal Int
        | ExternallyGeneratedFile
        | UnableToExport KeyAlgorithm String
        | FailedFileWrite
        | HostsDiff ByteString
        | DeletedPacket Packet
 deriving Show

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

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

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

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

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

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


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

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

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


keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
keyflags flgs@(KeyFlagsPacket {}) =
    Just . toEnum $
        (   bit 0x1 certify_keys
        .|. bit 0x2 sign_data
        .|. bit 0x4 encrypt_communication
        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
    -- other flags:
    --  split_key
    --  authentication (ssh-client)
    --  group_key
 where
    bit v f = if f flgs then v else 0
keyflags _ = Nothing


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


usageString :: PGPKeyFlags -> String
usageString flgs =
 case flgs of
    Special -> "special"
    Vouch -> "vouch" -- signkey
    Sign -> "sign"
    VouchSign -> "vouch-sign"
    Communication -> "communication"
    VouchCommunication -> "vouch-communication"
    SignCommunication -> "sign-communication"
    VouchSignCommunication -> "vouch-sign-communication"
    Storage -> "storage"
    VouchStorage -> "vouch-storage"
    SignStorage -> "sign-storage"
    VouchSignStorage -> "vouch-sign-storage"
    Encrypt -> "encrypt"
    VouchEncrypt -> "vouch-encrypt"
    SignEncrypt -> "sign-encrypt"
    VouchSignEncrypt -> "vouch-sign-encrypt"




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

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

keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
keyFlags0 wkun uidsigs = concat
                      [ keyflags
                      , preferredsym
                      , preferredhash
                      , preferredcomp
                      , features ]

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

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

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


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

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

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

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

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




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

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

     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 -> [(Packet,[Packet])]
selectPublicKeyAndSigs (spec,mtag) db =
    case mtag of
        Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db
        Just tag -> Map.elems (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 (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 $ (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
    let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys
        zs = snd $ seek_key subspec ys1
    listToMaybe zs

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

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

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

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

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

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


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

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

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


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

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

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

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

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

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

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

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


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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    doDecrypt <- makeMemoizingDecrypter keyring ctx keys

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

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

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

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

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

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

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

derToBase32 :: ByteString -> String
derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy

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

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

try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
try x body =
    case functorToEither x of
           Left e -> return e
           Right x -> body x


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

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

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

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

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


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 $ 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
                }
        dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
        mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
        mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
            where key' = if tm < fromTime (timestamp key)
                            then key { timestamp = fromTime tm }
                            else key
        mergeDate (tm,_) (Right mb) = (tm,mb)
    return $ dta

doImport
  :: Ord k =>
     (MappedPacket -> IO (KikiCondition Packet))
     -> Map.Map k KeyData
     -> (FilePath, Maybe [Char], [k], t)
     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
doImport doDecrypt db (fname,subspec,ms,_) = do
    flip (maybe $ return CannotImportMasterKey)
         subspec $ \tag -> do
    ps <- readSecretPEMFile (ArgFile fname)
    let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
            = partition (isJust . spemCert) ps
    -- 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 (importPEMKey tag certs) (KikiSuccess (db,[])) keys
 where
    importPEMKey tag certs prior key = do
        try prior $ \(db,report) -> do
        let (m0,tailms) = splitAt 1 ms
        if (not (null tailms) || null m0)
            then return $ AmbiguousKeySpec fname
            else do
                let kk = keykey key
                    cs = filter (\c -> kk==keykey (pcertKey c)) certs
                    blobs = map mkCertNotation $ nub $ map pcertBlob cs
                    mkCertNotation bs = NotationDataPacket
                        { human_readable = False
                        , notation_name = "x509cert@"
                        , notation_value = Char8.unpack bs }
                    datedKey = key { timestamp = fromTime $ minimum dates }
                    dates = fromTime (timestamp key) : map pcertTimestamp certs
                r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
                try r $ \(db',report') -> do
                return $ KikiSuccess (db',report++report')

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

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

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

                try wkun $ \wkun -> do

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

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

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

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

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

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

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


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

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

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

ifSecret :: Packet -> t -> t -> t
ifSecret (SecretKeyPacket {}) t f = t
ifSecret _                    t f = f

showPacket :: Packet -> String
showPacket p | isKey p   = (if is_subkey p
                              then showPacket0 p
                              else ifSecret p "----Secret-----" "----Public-----")
                           ++ " "++show (key_algorithm p)++" "++fingerprint p
             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
             | otherwise = showPacket0 p
showPacket0 p = concat . take 1 $ words (show p)


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

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


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

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

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

writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
                {-
                ->  KeyDB -> Maybe Packet
                -> FilePath -> FilePath
                -}
                -> IO (KikiCondition [(FilePath,KikiReportAction)])
writeRingKeys krd rt {- db wk secring pubring -} unspilled = do
    let isring (KeyRingFile {}) = True
        isring _                = False
        db = rtKeyDB rt
        secring = rtSecring rt
        pubring = rtPubring rt
        ctx = InputFileContext secring pubring
    let s = do
        (f,f0,stream) <- do
            (f0,stream) <- Map.toList (opFiles krd)
            guard (isring $ typ stream)
            f <- resolveInputFile ctx f0
            return (f,f0,stream)
        let db' = fromMaybe db $ do
                    msg <- Map.lookup f0 unspilled
                    return $ merge db f0 msg
            x = do
                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
                    wantedForFill acc KF_None       = importByExistingMaster
                        -- Note the KF_None case is almost irrelevent as it will be
                        -- filtered later when isMutable returns False.
                        -- We use importByExistingMaster in order to generate
                        -- MissingPacket warnings.  To disable those warnings, use
                        -- const Nothing instead.
                    wantedForFill acc (KF_Match {}) = importByExistingMaster
                    wantedForFill acc KF_Subkeys    = importByExistingMaster
                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
                                                                importByAccess acc kd
                    wantedForFill acc KF_All        = importByAccess acc
                    importByAccess Pub kd = importPublic
                    importByAccess Sec kd = importSecret
                    importByAccess AutoAccess kd =
                        mplus (importByExistingMaster kd)
                              (error $ f ++ ": write public or secret key to file?")
                    importByExistingMaster kd@(KeyData p _ _ _) =
                        fmap originallyPublic $ Map.lookup f $ locations p
                d <- sortByHint f keyMappedPacket (Map.elems db')
                acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
                only_public <- maybeToList $ wantedForFill acc (fill stream) d
                guard $ only_public || isSecretKey (keyPacket d)
                case fill stream of
                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
                                         flattenTop f only_public
                                            $ filterNewSubs f (parseSpec grip usage) d
                    _              -> flattenTop f only_public d
            new_packets = filter isnew x
                where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
        guard (not $ null new_packets)
        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 "" = []
    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta

    -- 64 byte lines

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

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

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


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

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

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

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

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

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

performManipulations ::
                (MappedPacket -> IO (KikiCondition Packet))
                -> KeyRingRuntime
                -> Maybe MappedPacket
                -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
                -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
performManipulations doDecrypt rt wk manip = do
    let db = rtKeyDB rt
        performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd
    r <- Traversable.mapM performAll db
    try (sequenceA r) $ \db -> do
    return $ KikiSuccess (rt { rtKeyDB = db },[])
 where
    perform :: KikiCondition KeyData -> PacketUpdate -> IO (KikiCondition KeyData)
    perform kd (InducerSignature uid subpaks) = do
        try kd $ \kd -> do
        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
        wkun' <- doDecrypt wk'
        try wkun' $ \wkun -> do    
        let flgs = if keykey (keyPacket kd) == keykey wkun
                    then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
                    else []
            sigOver = makeInducerSig (keyPacket kd)
                                     wkun
                                     (UserIDPacket uid)
                                     $ flgs ++ subpaks
            om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
            toMappedPacket om p = (mappedPacket "" p) {locations=om}
            selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
                                   . (== keykey whosign)
                                   . keykey)) vs
            keys = map keyPacket $ Map.elems (rtKeyDB rt)
            overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
            vs :: [ ( Packet -- signature
                   , Maybe SignatureOver -- Nothing means non-verified
                   , Packet ) -- key who signed
                 ]
            vs = do
                   x <- maybeToList $ Map.lookup uid (keyUids kd)
                   sig <- map (packet . fst) (fst x)
                   o <- overs sig
                   k <- keys
                   let ov = verify (Message [k]) $ o
                   signatures_over ov
                   return (sig,Just ov,k)
            additional new_sig = do
                new_sig <- maybeToList new_sig
                guard (null $ selfsigs)
                signatures_over new_sig
        sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
        let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
            f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
                  , om `Map.union` snd x )
        return $ KikiSuccess $ kd { keyUids = Map.adjust f uid (keyUids kd) }

    perform kd (SubKeyDeletion topk subk) = do
        try kd $ \kd -> do
        -- TODO: delete key from key database
        let kk = keykey $ packet $ keyMappedPacket kd
            kd' | kk /= topk = kd
                | otherwise  = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
            pred k _ = k == subk
        return $ KikiSuccess kd'

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

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

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

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

        ifnotnull ambiguous ambiguity $ do

        -- create nonexistent files via external commands
        do
           let cmds = mapMaybe getcmd missing
                 where
                   getcmd (fname,subspec,ms,mcmd) = do
                       cmd <- mcmd
                       return (fname,subspec,ms,cmd)
           rs <- forM cmds $ \tup@(fname,subspec,ms,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 (importPEMKey decrypt)
                      (KikiSuccess (db,[])) $ do
                    ((f,subspec,ms,cmd),r) <- rs
                    guard $ case r of
                       ExternallyGeneratedFile -> True
                       _ -> False
                    return (f,subspec,map fst ms,cmd)

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

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

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

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



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

smallpr k = drop 24 $ fingerprint k

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

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


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

resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
 where
    ops = map (\u -> InducerSignature u []) us
    us = filter torStyle $ Map.keys umap
    torStyle str = and [ uid_topdomain parsed == "onion"
                        , uid_realname parsed `elem` ["","Anonymous"]
                        , uid_user parsed == "root"
                        , fmap (match . fst) (lookup (packet k) torbindings)
                            == Just True ]
      where parsed = parseUID str
            match =  (==subdom) . take (fromIntegral len)
            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
            subdom = Char8.unpack subdom0
            len = T.length (uid_subdomain parsed)
            torbindings = getTorKeys (map packet $ flattenTop "" True kd)
            getTorKeys pub = do
                xs <- groupBindings pub
                (_,(top,sub),us,_,_) <- xs
                guard ("tor" `elem` us)
                let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
                return (top,(torhash,sub))

            groupBindings pub = gs
             where (_,bindings) = getBindings pub
                   bindings' = accBindings bindings
                   code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
                   ownerkey (_,(a,_),_,_,_) = a
                   sameMaster (ownerkey->a) (ownerkey->b)
                        = fingerprint_material a==fingerprint_material b
                   gs = groupBy sameMaster (sortBy (comparing code) bindings')


resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
 where
    topk = keykey $ packet k -- key to master of key to be deleted
    subk = do
        (k,sub) <- Map.toList submap
        guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
        return k


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

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

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

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

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

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

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

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

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

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

    return ret

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

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

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

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

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

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

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

sigpackets ::
  Monad m =>
  Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
sigpackets typ hashed unhashed = return $
    signaturePacket
        4 -- version
        typ -- 0x18 subkey binding sig, or 0x19 back-signature
        RSA
        SHA1
        hashed
        unhashed
        0 -- Word16 -- Left 16 bits of the signed hash value
        [] -- [MPI]

secretToPublic :: Packet -> Packet
secretToPublic pkt@(SecretKeyPacket {}) =
    PublicKeyPacket { version = version pkt
                    , timestamp = timestamp pkt
                    , key_algorithm = key_algorithm pkt
                    -- , ecc_curve = ecc_curve pkt
                    , key = let seckey = key pkt
                                pubs = public_key_fields (key_algorithm pkt)
                            in filter (\(k,v) -> k `elem` pubs) seckey
                    , is_subkey = is_subkey pkt
                    , v3_days_of_validity = Nothing
                    }
secretToPublic pkt = pkt



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


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

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

rsaKeyFromPacket _ = Nothing


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

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

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

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



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

mkUsage :: String -> SignatureSubpacket
mkUsage tag = NotationDataPacket
                { human_readable = True
                , notation_name = "usage@"
                , notation_value = tag
                }

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

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

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



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

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

type KeyKey = [ByteString]
data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show

-- | This is a GPG Identity which includes a master key and all its UIDs and
-- subkeys and associated signatures.
data KeyData = KeyData { keyMappedPacket :: MappedPacket    -- main key
                       , keySigAndTrusts :: [SigAndTrust]  -- sigs on main key
                       , keyUids :: (Map.Map String ([SigAndTrust],OriginMap))  -- uids
                       , keySubKeys :: (Map.Map KeyKey SubKey)    -- subkeys
                       } deriving Show

type KeyDB = Map.Map KeyKey KeyData

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

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

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

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

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

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

    qs = scanPackets filename ps

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

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


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

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


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

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

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

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

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


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

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

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

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

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

unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
unsig fname isPublic (sig,trustmap) =
    sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
  where
    f n _ = n==fname -- && trace ("fname=n="++show n) True
    asMapped n p = let m = mappedPacket fname p
                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }

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

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

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


flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
flattenTop fname ispub (KeyData key sigs uids subkeys) =
    unk ispub key :
            ( flattenAllUids fname ispub uids
             ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))

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

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

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

flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
flattenUid fname ispub (str,(sigs,om)) =
    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs

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

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

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

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

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

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

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

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

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

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

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

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

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