1 files changed, 3583 insertions, 0 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
new file mode 100644
index 0000000..1c6dea8
--- /dev/null
+++ b/lib/KeyRing.hs
@@ -0,0 +1,3583 @@
+---------------------------------------------------------------------------
+-- |
+-- 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(..)
+    , Initializer(..)
+    , KeyFilter(..)
+    -- * Results of a KeyRing Operation
+    , KeyRingRuntime(..)
+    , MappedPacket(..)
+    , KeyDB
+    , KeyData(..)
+    , SubKey(..)
+    , 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
+    , secretPemFromPacket
+    , getCrossSignedSubkeys
+    ) 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, generateKey, GenerateKeyParams(..))
+import Data.ByteString.Lazy   ( ByteString )
+import Text.Show.Pretty as PP ( ppShow )
+import Data.Binary {- decode, decodeOrFail -}
+import ControlMaybe ( handleIO_ )
+import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
+       , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
+import Data.ASN1.BitArray ( BitArray(..), toBitArray )
+import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
+import Data.ASN1.BinaryEncoding ( DER(..) )
+import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
+import Data.Time.Clock ( UTCTime )
+import Data.Bits ( Bits, shiftR )
+import Data.Text.Encoding ( encodeUtf8 )
+import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
+        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
+        , index, break, pack )
+import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse )
+import qualified Codec.Binary.Base32 as Base32
+import qualified Codec.Binary.Base64 as Base64
+#if !defined(VERSION_cryptonite)
+import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Crypto.Types.PubKey.ECC as ECC
+#else
+import qualified Crypto.Hash as Vincent
+import Data.ByteArray (convert)
+import qualified Crypto.PubKey.ECC.Types as ECC
+#endif
+import qualified Data.X509 as X509
+import qualified Crypto.PubKey.RSA as RSA
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.Text as T ( Text, unpack, pack,
+        strip, reverse, drop, break, dropAround, length )
+import qualified System.Posix.Types as Posix
+import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
+        , setFileCreationMask, setFileTimes )
+#if MIN_VERSION_x509(1,5,0)
+import Data.Hourglass.Types
+import Data.Hourglass
+#endif
+#if MIN_VERSION_unix(2,7,0)
+import System.Posix.Files ( setFdTimesHiRes )
+import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
+#else
+import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
+import Foreign.Marshal.Array ( withArray )
+import Foreign.Ptr
+import Foreign.C.Error ( throwErrnoIfMinus1_ )
+import Foreign.Storable
+#endif
+import System.FilePath ( takeDirectory )
+import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
+import Data.IORef
+import System.Posix.IO ( fdToHandle )
+import qualified Data.Traversable as Traversable
+import Data.Traversable ( sequenceA )
+#if ! MIN_VERSION_base(4,6,0)
+import GHC.Exts ( Down(..) )
+#endif
+#if MIN_VERSION_binary(0,7,0)
+import Debug.Trace
+#endif
+import Network.Socket -- (SockAddr)
+import qualified Data.ByteString.Lazy.Char8 as Char8
+import Compat
+
+import TimeUtil
+import PEM
+import ScanningParser
+import qualified Hosts
+import qualified CryptoCoins
+import Base58
+import FunctorToMaybe
+import DotLock
+import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
+
+-- DER-encoded elliptic curve ids
+-- nistp256_id  = 0x2a8648ce3d030107
+secp256k1_id :: Integer
+secp256k1_id = 0x2b8104000a
+-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
+{-     OID                  Curve description              Curve name
+    ----------------------------------------------------------------   
+    1.2.840.10045.3.1.7  NIST Curve P-256 [FIPS 186-2]  "NIST P-256"
+    1.3.132.0.34         NIST Curve P-384 [FIPS 186-2]  "NIST P-384"  
+    1.3.132.0.35         NIST Curve P-521 [FIPS 186-2]  "NIST P-521"  
+
+    Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
+    P-521".  The hexadecimal representation used in the public and
+    private key encodings are:
+
+    Curve Name   Len  Hexadecimal representation of the OID
+    ----------------------------------------------------------------   
+    "NIST P-256"  8   0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 
+    "NIST P-384"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x22            
+    "NIST P-521"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x23          
+-}
+
+data HomeDir =
+    HomeDir { homevar :: String
+            , appdir :: String
+            , optfile_alts :: [String]
+            }
+
+home :: HomeDir
+home = HomeDir
+    { homevar = "GNUPGHOME"
+    , appdir  = ".gnupg"
+    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
+    }
+
+data InputFile = HomeSec
+               -- ^ A file named secring.gpg located in the home directory.
+               -- See 'opHome'.
+               | HomePub
+               -- ^ A file named pubring.gpg located in the home directory.
+               -- See 'opHome'.
+               | ArgFile FilePath
+               -- ^ Contents will be read or written from the specified path.
+               | FileDesc Posix.Fd
+               -- ^ Contents will be read or written from the specified file
+               -- descriptor.
+               | Pipe Posix.Fd Posix.Fd
+               -- ^ Contents will be read from the first descriptor and updated
+               -- content will be writen to the second. Note: Don't use Pipe
+               -- for 'Wallet' files. (TODO: Wallet support)
+               | Generate Int GenerateKeyParams
+               -- ^ New key packets will be generated if there is no
+               -- matching content already in the key pool. The integer is
+               -- a unique id number so that multiple generations can be
+               -- inserted into 'opFiles'
+ deriving (Eq,Ord,Show)
+
+-- type UsageTag = String
+data Initializer = NoCreate | Internal GenerateKeyParams | External String
+ deriving (Eq,Ord,Show)
+
+data FileType = KeyRingFile
+              | PEMFile
+              | WalletFile
+              | DNSPresentation
+              | Hosts
+ deriving (Eq,Ord,Enum,Show)
+
+-- | 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.
+  deriving (Eq,Ord,Show)
+
+-- | 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 :: Initializer
+    -- ^ If 'typ' is 'PEMFile' and an 'External' '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.
+    }
+ deriving (Eq,Show)
+
+
+spillable :: StreamInfo -> Bool
+spillable (spill -> KF_None) = False
+spillable _                  = True
+
+isMutable :: StreamInfo -> Bool
+isMutable (fill -> KF_None) = False
+isMutable _                 = True
+
+isring :: FileType -> Bool
+isring (KeyRingFile {}) = True
+isring _                = False
+
+isSecretKeyFile :: FileType -> Bool
+isSecretKeyFile PEMFile         = True
+isSecretKeyFile DNSPresentation = True
+isSecretKeyFile _               = False
+
+{-
+pwfile :: FileType -> Maybe InputFile
+pwfile (KeyRingFile f) = f
+pwfile _               = Nothing
+-}
+
+iswallet :: FileType -> Bool
+iswallet (WalletFile {}) = True
+iswallet _               = False
+
+usageFromFilter :: MonadPlus m => KeyFilter -> m String
+usageFromFilter (KF_Match usage) = return usage
+usageFromFilter _                = mzero
+
+data KeyRingRuntime = KeyRingRuntime
+                        { rtPubring :: FilePath
+                        -- ^ Path to the file represented by 'HomePub'
+                        , rtSecring :: FilePath
+                        -- ^ Path to the file represented by 'HomeSec'
+                        , rtGrip :: Maybe String
+                        -- ^ Fingerprint or portion of a fingerprint used
+                        -- to identify the working GnuPG identity used to
+                        -- make signatures.
+                        , rtWorkingKey :: Maybe Packet
+                        -- ^ The master key of the working GnuPG identity.
+                        , rtKeyDB :: KeyDB
+                        -- ^ The common information pool where files spilled
+                        -- their content and from which they received new
+                        -- content.
+                        , rtRingAccess :: Map.Map InputFile Access
+                        -- ^ The 'Access' values used for files of type
+                        -- 'KeyRingFile'.  If 'AutoAccess' was specified
+                        -- for a file, this 'Map.Map' will indicate the
+                        -- detected value that was used by the algorithm.
+                        , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet)
+                        }
+
+-- | Roster-entry level actions
+data PacketUpdate = InducerSignature String [SignatureSubpacket]
+                  | SubKeyDeletion KeyKey KeyKey
+
+-- | This type is used to indicate where to obtain passphrases.
+data PassphraseSpec = PassphraseSpec
+    { passSpecRingFile :: Maybe FilePath
+    -- ^ If not Nothing, the passphrase is to be used for packets
+    -- from this file.
+    , passSpecKeySpec :: Maybe String
+    -- ^ Non-Nothing value reserved for future use.
+    -- (TODO: Use this to implement per-key passphrase associations).
+    , passSpecPassFile :: InputFile
+    -- ^ The passphrase will be read from this file or file descriptor.
+    }
+    -- | Use this to carry pasphrases from a previous run.
+    | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
+
+instance Show PassphraseSpec where
+    show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
+    show (PassphraseMemoizer _) = "PassphraseMemoizer"
+instance Eq PassphraseSpec where
+    PassphraseSpec a b c == PassphraseSpec d e f
+        = and [a==d,b==e,c==f]
+    _ == _
+        = False
+
+
+
+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,Show)
+
+-- | 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.
+    }
+ deriving (Eq,Show)
+
+resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
+resolveInputFile ctx = resolve
+ where
+    resolve HomeSec = return (homesecPath ctx)
+    resolve HomePub = return (homepubPath ctx)
+    resolve (ArgFile f) = return f
+    resolve _ = []
+
+resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
+resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
+ where str = case (fdr,fdw) of
+                (0,1) -> "-"
+                _     -> "&pipe" ++ show (fdr,fdw)
+resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
+ where str = "&" ++ show fd
+resolveForReport mctx f = concat $ resolveInputFile ctx f
+ where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
+
+filesToLock ::
+  KeyRingOperation -> InputFileContext -> [FilePath]
+filesToLock k ctx = do
+    (f,stream) <- Map.toList (opFiles k)
+    case fill stream of
+        KF_None -> []
+        _       -> resolveInputFile ctx f
+
+
+-- kret :: a -> KeyRingOperation a
+-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
+
+data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
+data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
+
+pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
+pkcs8 (RSAKey n e) = RSAKey8 n e
+
+instance ASN1Object RSAPublicKey where
+    -- PKCS #1 RSA Public Key
+    toASN1 (RSAKey (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : IntVal n
+                         : IntVal e
+                         : End Sequence
+                         : xs
+    fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
+        Right (RSAKey (MPI n) (MPI e), xs)
+
+    fromASN1 _ = 
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+instance ASN1Object PKCS8_RSAPublicKey where
+
+    -- PKCS #8 Public key data
+    toASN1 (RSAKey8 (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : Start Sequence
+                         : OID [1,2,840,113549,1,1,1]
+                         : Null -- Doesn't seem to be neccessary, but i'm adding it
+                                -- to match PEM files I see in the wild.
+                         : End Sequence
+                         : BitString (toBitArray bs 0)
+                         : End Sequence
+                         : xs
+        where
+            pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
+            bs = encodeASN1' DER pubkey
+
+    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
+        Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
+    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) =
+        case decodeASN1' DER bs of
+            Right as -> fromASN1 as
+            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
+      where
+        BitArray _ bs = b
+    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
+        case decodeASN1' DER bs of
+            Right as -> fromASN1 as
+            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
+      where
+        BitArray _ bs = b
+
+    fromASN1 _ =
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+{-
+RSAPrivateKey ::= SEQUENCE {
+  version           Version,
+  modulus           INTEGER,  -- n
+  publicExponent    INTEGER,  -- e
+  privateExponent   INTEGER,  -- d
+  prime1            INTEGER,  -- p
+  prime2            INTEGER,  -- q
+  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
+  exponent2         INTEGER,  -- d mod (q-1)
+  coefficient       INTEGER,  -- (inverse of q) mod p
+  otherPrimeInfos   OtherPrimeInfos OPTIONAL
+  }
+-}
+data RSAPrivateKey = RSAPrivateKey
+    { rsaN :: MPI
+    , rsaE :: MPI
+    , rsaD :: MPI
+    , rsaP :: MPI
+    , rsaQ :: MPI
+    , rsaDmodP1 :: MPI
+    , rsaDmodQminus1 :: MPI
+    , rsaCoefficient :: MPI
+    }
+ deriving Show
+
+instance ASN1Object RSAPrivateKey where
+    toASN1 rsa@(RSAPrivateKey {})
+        = \xs -> Start Sequence
+               : IntVal 0
+               : mpiVal rsaN
+               : mpiVal rsaE
+               : mpiVal rsaD
+               : mpiVal rsaP
+               : mpiVal rsaQ
+               : mpiVal rsaDmodP1
+               : mpiVal rsaDmodQminus1
+               : mpiVal rsaCoefficient
+               : End Sequence
+               : xs
+                  where mpiVal f = IntVal x where MPI x = f rsa
+
+    fromASN1 ( Start Sequence
+             : IntVal _ -- version
+             : IntVal n
+             : IntVal e
+             : IntVal d
+             : IntVal p
+             : IntVal q
+             : IntVal dmodp1
+             : IntVal dmodqminus1
+             : IntVal coefficient
+             : ys) =
+        Right ( privkey, tail $ dropWhile notend ys)
+         where
+            notend (End Sequence) = False
+            notend _              = True
+            privkey = RSAPrivateKey
+                { rsaN = MPI n
+                , rsaE = MPI e
+                , rsaD = MPI d
+                , rsaP = MPI p
+                , rsaQ = MPI q
+                , rsaDmodP1 = MPI dmodp1
+                , rsaDmodQminus1 = MPI dmodqminus1
+                , rsaCoefficient = MPI coefficient
+                }
+    fromASN1 _ =
+        Left "fromASN1: RSAPrivateKey: unexpected format"
+
+
+
+-- | This type is used to indicate success or failure
+-- and in the case of success, return the computed object.
+-- The 'FunctorToMaybe' class is implemented to facilitate
+-- branching on failture.
+data KikiCondition a = KikiSuccess a
+    | FailedToLock [FilePath]
+    | BadPassphrase
+    | FailedToMakeSignature
+    | CantFindHome
+    | AmbiguousKeySpec FilePath
+    | CannotImportMasterKey
+    | NoWorkingKey
+ deriving ( Functor, Show )
+
+instance FunctorToMaybe KikiCondition where
+    functorToMaybe (KikiSuccess a) = Just a
+    functorToMaybe _               = Nothing
+
+instance Applicative KikiCondition where
+    pure a  = KikiSuccess a
+    f <*> a =
+        case functorToEither f of
+            Right f  -> case functorToEither a of
+                            Right a  -> pure (f a)
+                            Left err -> err
+            Left err -> err
+
+-- | This type is used to describe events triggered by 'runKeyRing'.  In
+-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
+-- non-fatal IO exceptions (e.g. 'FailedExternal').  Because a
+-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
+-- many inputs and outputs, an operation may be partially (or even mostly)
+-- successful even when I/O failures occured.  In this situation, the files may
+-- not have all the information they were intended to store, but they will be
+-- in a valid format for GnuPG or kiki to operate on in the future.
+data KikiReportAction =
+        NewPacket String
+        | MissingPacket String
+        | ExportedSubkey
+        | GeneratedSubkeyFile
+        | NewWalletKey String
+        | YieldSignature
+        | YieldSecretKeyPacket String
+        | UnableToUpdateExpiredSignature
+        | WarnFailedToMakeSignature
+        | FailedExternal Int
+        | ExternallyGeneratedFile
+        | UnableToExport KeyAlgorithm String
+        | FailedFileWrite
+        | HostsDiff ByteString
+        | DeletedPacket String
+ deriving Show
+
+uncamel :: String -> String
+uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
+  where
+    (.:) = fmap . fmap
+    ( firstWord  ,
+      otherWords ) = splitAt 1 ws
+    ws             = camel >>= groupBy (\_ c -> isLower c)
+    ( camel, args) = splitAt 1 $ words str
+
+reportString :: KikiReportAction -> String
+reportString x = uncamel $ show x
+
+errorString :: KikiCondition a -> String
+errorString (KikiSuccess {}) = "success"
+errorString e = uncamel . show $ fmap (const ()) e
+
+-- | Errors in kiki are indicated by the returning of this record.
+data KikiResult a = KikiResult
+    { kikiCondition :: KikiCondition a
+    -- ^ The result or a fatal error condition.
+    , kikiReport :: KikiReport
+    -- ^ A list of non-fatal warnings and informational messages
+    -- along with the files that triggered them.
+    }
+
+type KikiReport = [ (FilePath, KikiReportAction) ]
+
+keyPacket :: KeyData -> Packet
+keyPacket (KeyData k _ _ _) = packet k
+
+subkeyMappedPacket :: SubKey -> MappedPacket
+subkeyMappedPacket (SubKey k _ ) = k
+
+
+usage :: SignatureSubpacket -> Maybe String
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
+x509cert (NotationDataPacket
+        { human_readable = False
+        , notation_name  = "x509cert@"
+        , notation_value = u
+        }) = Just (Char8.pack u)
+x509cert _    = Nothing
+
+makeInducerSig
+  :: Packet
+     -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
+-- torsig g topk wkun uid timestamp extras = todo
+makeInducerSig topk wkun uid extras
+    = CertificationSignature (secretToPublic topk)
+                             uid
+                             (sigpackets 0x13
+                                         subpackets
+                                         subpackets_unh)
+   where
+    subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
+                 tsign
+                 ++ extras
+    subpackets_unh = [IssuerPacket (fingerprint wkun)]
+    tsign = if keykey wkun == keykey topk
+             then [] -- tsign doesnt make sense for self-signatures
+             else [ TrustSignaturePacket 1 120
+                  , RegularExpressionPacket regex]
+    -- <[^>]+[@.]asdf\.nowhere>$
+    regex = "<[^>]+[@.]"++hostname++">$"
+    -- regex = username ++ "@" ++ hostname
+    -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
+    hostname = subdomain' pu ++ "\\." ++ topdomain' pu
+    pu = parseUID uidstr where UserIDPacket uidstr = uid
+    subdomain' = escape . T.unpack . uid_subdomain
+    topdomain' = escape . T.unpack . uid_topdomain
+    escape s = concatMap echar s
+      where
+        echar '|' = "\\|"
+        echar '*' = "\\*"
+        echar '+' = "\\+"
+        echar '?' = "\\?"
+        echar '.' = "\\."
+        echar '^' = "\\^"
+        echar '$' = "\\$"
+        echar '\\' = "\\\\"
+        echar '[' = "\\["
+        echar ']' = "\\]"
+        echar c = [c]
+
+
+keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
+keyflags flgs@(KeyFlagsPacket {}) =
+    Just . toEnum $
+        (   bit 0x1 certify_keys
+        .|. bit 0x2 sign_data
+        .|. bit 0x4 encrypt_communication
+        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
+    -- other flags:
+    --  split_key
+    --  authentication (ssh-client)
+    --  group_key
+ where
+    bit v f = if f flgs then v else 0
+keyflags _ = Nothing
+
+
+data PGPKeyFlags =
+    Special
+    | Vouch -- Signkey
+    | Sign
+    | VouchSign
+    | Communication
+    | VouchCommunication
+    | SignCommunication
+    | VouchSignCommunication
+    | Storage
+    | VouchStorage
+    | SignStorage
+    | VouchSignStorage
+    | Encrypt
+    | VouchEncrypt
+    | SignEncrypt
+    | VouchSignEncrypt
+ deriving (Eq,Show,Read,Enum)
+
+
+usageString :: PGPKeyFlags -> String
+usageString flgs =
+ case flgs of
+    Special -> "special"
+    Vouch -> "vouch" -- signkey
+    Sign -> "sign"
+    VouchSign -> "vouch-sign"
+    Communication -> "communication"
+    VouchCommunication -> "vouch-communication"
+    SignCommunication -> "sign-communication"
+    VouchSignCommunication -> "vouch-sign-communication"
+    Storage -> "storage"
+    VouchStorage -> "vouch-storage"
+    SignStorage -> "sign-storage"
+    VouchSignStorage -> "vouch-sign-storage"
+    Encrypt -> "encrypt"
+    VouchEncrypt -> "vouch-encrypt"
+    SignEncrypt -> "sign-encrypt"
+    VouchSignEncrypt -> "vouch-sign-encrypt"
+
+
+
+
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+matchpr :: String -> Packet -> String
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+keyFlags :: t -> [Packet] -> [SignatureSubpacket]
+keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
+
+keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
+keyFlags0 wkun uidsigs = concat
+                      [ keyflags
+                      , preferredsym
+                      , preferredhash
+                      , preferredcomp
+                      , features ]
+
+ where
+    subs = concatMap hashed_subpackets uidsigs
+    keyflags = filterOr isflags subs $
+               KeyFlagsPacket { certify_keys = True
+                              , sign_data = True
+                              , encrypt_communication = False
+                              , encrypt_storage = False
+                              , split_key = False
+                              , authentication = False
+                              , group_key = False
+                              }
+    preferredsym = filterOr ispreferedsym subs $
+               PreferredSymmetricAlgorithmsPacket
+                              [ AES256
+                              , AES192
+                              , AES128
+                              , CAST5
+                              , TripleDES
+                              ]
+    preferredhash = filterOr ispreferedhash subs $
+               PreferredHashAlgorithmsPacket
+                              [ SHA256
+                              , SHA1
+                              , SHA384
+                              , SHA512
+                              , SHA224
+                              ]
+    preferredcomp = filterOr ispreferedcomp subs $
+               PreferredCompressionAlgorithmsPacket
+                              [ ZLIB
+                              , BZip2
+                              , ZIP
+                              ]
+    features = filterOr isfeatures subs $
+               FeaturesPacket { supports_mdc = True
+                              }
+
+    filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
+
+    isflags (KeyFlagsPacket {}) = True
+    isflags _ = False
+    ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
+    ispreferedsym _ = False
+    ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
+    ispreferedhash _ = False
+    ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
+    ispreferedcomp _ = False
+    isfeatures (FeaturesPacket {}) = True
+    isfeatures _ = False
+
+
+matchSpec :: KeySpec -> KeyData -> Bool
+matchSpec (KeyGrip grip) (KeyData p _ _ _)
+    | matchpr grip (packet p)==grip = True
+    | otherwise                     = False
+
+matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
+ where
+    ps = map (packet .fst) sigs
+    match p = isSignaturePacket p
+                && has_tag tag p
+                && has_issuer key p
+    has_issuer key p = isJust $ do
+        issuer <- signature_issuer p
+        guard $ matchpr issuer key == issuer
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
+  where
+    us = filter (isInfixOf pat) $ Map.keys uids
+
+data UserIDRecord = UserIDRecord {
+    uid_full :: String,
+    uid_realname :: T.Text,
+    uid_user :: T.Text,
+    uid_subdomain :: T.Text,
+    uid_topdomain :: T.Text
+}
+ deriving Show
+
+parseUID :: String -> UserIDRecord
+parseUID str = UserIDRecord {
+                    uid_full = str,
+                    uid_realname = realname,
+                    uid_user = user,
+                    uid_subdomain = subdomain,
+                    uid_topdomain = topdomain
+                }
+ where
+    text = T.pack str
+    (T.strip-> realname, T.dropAround isBracket-> email)
+                              = T.break (=='<') text
+    (user, T.drop 1-> hostname) = T.break (=='@') email
+    ( T.reverse            -> topdomain,
+      T.reverse . T.drop 1 -> subdomain)
+                              = T.break (=='.') . T.reverse $ hostname
+isBracket :: Char -> Bool
+isBracket '<' = True
+isBracket '>' = True
+isBracket _   = False
+
+
+
+
+data KeySpec =
+      KeyGrip String       -- fp:
+    | KeyTag Packet String -- fp:????/t:
+    | KeyUidMatch String   -- u:
+ deriving Show
+
+data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum)
+data SingleKeySpec = FingerprintMatch String
+                   | SubstringMatch (Maybe MatchingField) String
+                   | EmptyMatch
+                   | AnyMatch
+                   | WorkingKeyMatch
+ deriving (Show,Eq,Ord)
+
+-- A pair of specs.  The first specifies an identity and the second
+-- specifies a specific key (possibly master) associated with that
+-- identity.
+--
+-- When no slash is specified, context will decide whether the SingleKeySpec
+-- is specifying an identity or a key belonging to the working identity.
+type Spec = (SingleKeySpec,SingleKeySpec)
+
+parseSingleSpec :: String -> SingleKeySpec
+parseSingleSpec "*"              = AnyMatch
+parseSingleSpec "-"              = WorkingKeyMatch
+parseSingleSpec ""               = EmptyMatch
+parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
+parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
+parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
+parseSingleSpec str
+    | is40digitHex str = FingerprintMatch str
+    | otherwise        = SubstringMatch Nothing str
+
+is40digitHex xs = ys == xs && length ys==40
+      where
+        ys = filter ishex xs
+        ishex c | '0' <= c && c <= '9' = True
+                | 'A' <= c && c <= 'F' = True
+                | 'a' <= c && c <= 'f' = True
+        ishex c = False
+
+
+  --  t:tor                                    -- (FingerprintMatch "", SubstringMatch "tor")
+  --  u:joe                                    -- (SubstringMatch "joe", FingerprintMatch "")
+  --  u:joe/                                   -- (SubstringMatch "joe", FingerprintMatch "!")
+  --  fp:4A39F/tor                             -- (FingerprintMatch "4A39F", SubstringMatch "tor")
+  --  u:joe/tor                                -- (SubstringMatch "joe", SubstringMatch "tor")
+  --  u:joe/t:tor                              -- (SubstringMatch "joe", SubstringMatch "tor")
+  --  u:joe/fp:4abf30                          -- (SubstringMatch "joe", FingerprintMatch "4abf30")
+  --  joe/tor                                  -- (SubstringMatch "joe", SubstringMatch "tor")
+
+-- | Parse a key specification.
+-- The first argument is a grip for the default working key.
+parseSpec :: String -> String -> (KeySpec,Maybe String)
+parseSpec wkgrip spec =
+    if not slashed
+        then
+            case prespec of
+                AnyMatch                               -> (KeyGrip "", Nothing)
+                EmptyMatch                             -> error "Bad key spec."
+                WorkingKeyMatch                        -> (KeyGrip wkgrip, Nothing)
+                SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
+                SubstringMatch Nothing str             -> (KeyGrip wkgrip, Just str)
+                SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
+                FingerprintMatch fp                    -> (KeyGrip fp, Nothing)
+        else
+            case (prespec,postspec) of
+                (FingerprintMatch fp, SubstringMatch st t)
+                    | st /= Just UserIDField                -> (KeyGrip fp, Just t)
+                (SubstringMatch mt u, _)
+                    | postspec `elem` [AnyMatch,EmptyMatch]
+                      && mt /= Just KeyTypeField            -> (KeyUidMatch u, Nothing)
+                (SubstringMatch mt u, SubstringMatch st t)
+                    | mt /= Just KeyTypeField
+                      && st /= Just UserIDField             -> (KeyUidMatch u, Just t)
+                (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
+                (_,FingerprintMatch fp)                 -> error "todo: support /fp: spec"
+                (FingerprintMatch fp,_)                 -> error "todo: support fp:/ spec"
+                _                                       -> error "Bad key spec."
+ where
+    (preslash,slashon) = break (=='/') spec
+    slashed = not $ null $ take 1 slashon
+    postslash = drop 1 slashon
+
+    prespec = parseSingleSpec preslash
+    postspec = parseSingleSpec postslash
+
+{-
+ - BUGGY
+parseSpec grip spec = (topspec,subspec)
+ where
+     (topspec0,subspec0) = unprefix '/' spec
+     (toptyp,top) = unprefix ':' topspec0
+     (subtyp,sub) = unprefix ':' subspec0
+     topspec = case () of
+                    _ | null top && or [ subtyp=="fp"
+                                       , null subtyp && is40digitHex sub
+                                       ]
+                                 -> KeyGrip sub
+                    _ | null top && null grip -> KeyUidMatch sub
+                    _ | null top -> KeyGrip grip
+                    _ | toptyp=="fp" || (null toptyp && is40digitHex top)
+                                 -> KeyGrip top
+                    _ | toptyp=="u" -> KeyUidMatch top
+                    _            -> KeyUidMatch top
+     subspec = case subtyp of
+                "t" -> Just sub
+                "fp" | top=="" -> Nothing
+                "" | top=="" && is40digitHex sub -> Nothing
+                "" -> listToMaybe sub >> Just sub
+                _ -> Nothing
+
+     is40digitHex xs = ys == xs && length ys==40
+      where
+        ys = filter ishex xs
+        ishex c | '0' <= c && c <= '9' = True
+                | 'A' <= c && c <= 'F' = True
+                | 'a' <= c && c <= 'f' = True
+        ishex c = False
+
+     -- | Split a string into two at the first occurance of the given
+     -- delimiter.  If the delimeter does not occur, then the first
+     -- item of the returned pair is empty and the second item is the
+     -- input string.
+     unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
+      where p = break (==c) spec
+-}
+
+
+filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
+filterMatches spec ks = filter (matchSpec spec . snd) ks
+
+filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
+filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
+ where
+    matchAll = KeyGrip ""
+
+    subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
+    subkeySpec (topspec,Just mtag)    = (topspec , KeyTag (packet p) mtag)
+
+    match spec mps 
+               = not . null
+               . snd
+               . seek_key spec
+               . map packet
+               $ mps
+
+    old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)
+
+    oldOrMatch spec sub = old sub
+                          || match spec (flattenSub "" True sub)
+
+    subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
+                         then oldOrMatch subspec
+                         else old)
+                       subs
+        where
+            (topspec,subspec) = subkeySpec spec
+
+selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
+
+selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
+
+selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
+selectPublicKeyAndSigs (spec,mtag) db =
+    case mtag of
+        Nothing -> do
+            (kk,r) <- Map.toList $ fmap (findbyspec spec) db
+            (sub,sigs) <- r
+            return (kk,sub,sigs)
+        Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
+ where
+    topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
+
+    findbyspec (KeyGrip g) kd = do
+        filter ismatch $
+            topresult kd
+            : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
+                  (Map.elems $ keySubKeys kd)
+      where
+        ismatch (p,sigs) = matchpr g p ==g
+    findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
+
+    findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
+     where
+        gettag (SubKey sub sigs) = do
+            let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
+            (hastag,_) <- maybeToList mb
+            guard hastag
+            return $ (kk, packet sub, map (packet . fst) sigs)
+
+selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectKey0 wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
+    case ys of
+        y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
+        []    -> Nothing
+
+{-
+selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
+selectAll wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    y <- take 1 ys
+    case mtag of
+        Nothing -> return (y,Nothing)
+        Just tag ->
+            let search ys1 = do
+                    let zs = snd $ seek_key (KeyTag y tag) ys1
+                    z <- take 1 zs
+                    (y,Just z):search (drop 1 zs)
+            in search (drop 1 ys)
+-}
+
+seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
+seek_key (KeyGrip grip) sec = (pre, subs)
+  where
+    (pre,subs) = break pred sec
+    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
+    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
+    pred _                      = False
+
+seek_key (KeyTag key tag) ps
+    | null bs = (ps, [])
+    | null qs =
+      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
+        (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (\p -> isSignaturePacket p
+                        && has_tag tag p
+                        && isJust (signature_issuer p)
+                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
+                    ps
+    (rs,qs) = break isKey (reverse as)
+
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+seek_key (KeyUidMatch pat) ps
+    | null bs = (ps, [])
+    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
+                    (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (isInfixOf pat . uidStr) ps
+    (rs,qs) = break isKey (reverse as)
+
+    uidStr (UserIDPacket s) = s
+    uidStr _                = ""
+
+
+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.hPutStr stderr prompt
+                                    Nothing -> return ()
+                               else return ()
+            pw <- fmap trimCR $ readInputFileS ctx fd
+            writeIORef ref (Just pw)
+            return pw
+
+generateSubkey ::
+  (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
+  -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
+  -> (GenerateKeyParams, StreamInfo)
+  -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
+generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
+    try kd' $ \(kd,report0) -> do
+    let subs = do
+            SubKey p sigs <- Map.elems $ keySubKeys kd
+            filter (has_tag tag) $ map (packet . fst) sigs
+    if null subs
+      then do
+        newkey <- generateKey genparam
+        kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
+        try kdr $ \(newkd,report) -> do
+        return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
+      else do
+        return $ KikiSuccess (kd,report0)
+generateSubkey _ kd _ = return kd
+
+importSecretKey ::
+  (MappedPacket -> IO (KikiCondition Packet))
+  -> KikiCondition
+       (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
+  -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+  -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
+importSecretKey doDecrypt db' tup = do
+            try db' $ \(db',report0) -> do
+            r <- doImport doDecrypt
+                      db'
+                      tup
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+
+
+mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
+     -> IO
+          (KikiCondition
+             ( ( Map.Map [Char8.ByteString] KeyData
+               , ( [Hosts.Hosts]
+                 , [Hosts.Hosts]
+                 , Hosts.Hosts
+                 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
+                 , [SockAddr]))
+             , [(FilePath,KikiReportAction)]))
+mergeHostFiles krd db ctx = do
+    let hns = files ishosts
+        ishosts Hosts = True
+        ishosts _     = False
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (istyp $ typ stream)
+            return f
+
+    hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns
+
+    let gpgnames = map getHostnames $ Map.elems db
+        os = do
+            (addr,(ns,_)) <- gpgnames
+            n <- ns
+            return (addr,n)
+        setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
+        -- we ensure .onion names are set properly
+        hostdbs = map setOnions hostdbs0
+        outgoing_names = do
+            (addr,(_,gns)) <- gpgnames
+            guard . not $ null gns
+            guard $ all (null . Hosts.namesForAddress addr) hostdbs0
+            return addr
+    -- putStrLn $ "hostdbs = " ++ show hostdbs
+
+    -- 1. let U = union all the host dbs 
+    --     preserving whitespace and comments of the first
+    let u0 = foldl' Hosts.plus Hosts.empty hostdbs
+        -- we filter U to be only finger-dresses
+        u1 = Hosts.filterAddrs (hasFingerDress db) u0
+
+    -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
+    {-
+    putStrLn $ "_  = {\n" ++ show (head hostdbs) ++ "}"
+    putStrLn $ "--> " ++ show (nf (head hostdbs))
+    putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
+    putStrLn $ "--> " ++ show (nf u0)
+    putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
+    putStrLn $ "--> " ++ show (nf u1)
+    -}
+    
+    -- 2. replace gpg annotations with those in U
+    -- forM use_db
+    db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
+
+    return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
+
+writeHostsFiles
+  :: KeyRingOperation -> InputFileContext
+     -> ([Hosts.Hosts],
+         [Hosts.Hosts],
+         Hosts.Hosts,
+         [(SockAddr, (t1, [Char8.ByteString]))],
+         [SockAddr])
+     -> IO [(FilePath, KikiReportAction)]
+writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
+    let hns = files isMutableHosts
+        isMutableHosts (fill -> KF_None) = False
+        isMutableHosts (typ -> Hosts)    = True
+        isMutableHosts _                 = False
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (istyp stream)
+            return f -- resolveInputFile ctx f
+
+    -- 3. add hostnames from gpg for addresses not in U
+    let u = foldl' f u1 ans
+        ans = reverse $ do
+            (addr,(_,ns)) <- gpgnames
+            guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
+            n <- ns
+            return (addr,n)
+        f h (addr,n) = Hosts.assignNewName addr n h
+
+    -- 4. for each host db H, union H with U and write it out as H'
+    --     only if there is a non-empty diff
+    rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do 
+        let h = h1 `Hosts.plus` u
+            d = Hosts.diff h0 h
+            rs = map ((fname,) . HostsDiff) d
+        unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h
+        return $ map (first $ resolveForReport $ Just ctx) rs
+    return $ concat rss
+
+isSecretKey :: Packet -> Bool
+isSecretKey (SecretKeyPacket {}) = True
+isSecretKey _                    = False
+
+buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
+              -> IO (KikiCondition ((KeyDB
+                                    ,Maybe String
+                                    ,Maybe MappedPacket
+                                    ,([Hosts.Hosts],
+                                             [Hosts.Hosts],
+                                             Hosts.Hosts,
+                                             [(SockAddr, (KeyKey, KeyKey))],
+                                             [SockAddr])
+                                    ,Map.Map InputFile Access
+                                    ,MappedPacket -> IO (KikiCondition Packet)
+                                    ,Map.Map InputFile Message
+                                    )
+                                   ,[(FilePath,KikiReportAction)]))
+buildKeyDB ctx grip0 keyring = do
+    let 
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles keyring)
+            guard (istyp $ typ stream)
+            resolveInputFile ctx f
+
+        ringMap0 = Map.filter (isring . typ) $ opFiles keyring
+        (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
+            where
+                isgen (Generate _ _) _ = True
+                isgen _              _ = False
+
+        readp f stream = fmap readp0 $ readPacketsFromFile ctx f
+         where
+          readp0 ps = (stream { access = acc' }, ps)
+           where acc' = case access stream of
+                            AutoAccess ->
+                                case ps of
+                                    Message ((PublicKeyPacket {}):_) -> Pub
+                                    Message ((SecretKeyPacket {}):_) -> Sec
+                                    _                                -> AutoAccess
+                            acc -> acc
+
+        readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
+
+    -- KeyRings (todo: KikiCondition reporting?)
+    (spilled,mwk,grip,accs,keys,unspilled) <- do
+#if MIN_VERSION_containers(0,5,0)
+        ringPackets <- Map.traverseWithKey readp ringMap
+#else
+        ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
+#endif
+        let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
+
+        let grip = grip0 `mplus` (fingerprint <$> fstkey)
+              where
+                fstkey = do
+                    (_,Message ps) <- Map.lookup HomeSec ringPackets
+                    listToMaybe ps
+            (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
+            keys :: Map.Map KeyKey MappedPacket
+            keys = Map.foldl slurpkeys Map.empty
+                        $ Map.mapWithKey filterSecrets ringPackets
+                    where
+                          filterSecrets f (_,Message ps) =
+                            filter (isSecretKey . packet)
+                                $ zipWith (mappedPacketWithHint fname) ps [1..]
+                            where fname = resolveForReport (Just ctx) f
+                          slurpkeys m ps = m `Map.union` Map.fromList ps'
+                            where ps' = zip (map (keykey . packet) ps) ps
+            wk = listToMaybe $ do
+                    fp <- maybeToList grip
+                    let matchfp mp = not (is_subkey p) && matchpr fp p == fp
+                            where p = packet mp
+                    Map.elems $ Map.filter matchfp keys
+            accs = fmap (access . fst) ringPackets
+        return (spilled,wk,grip,accs,keys,fmap snd unspilled)
+
+    doDecrypt <- makeMemoizingDecrypter keyring ctx keys
+
+    let wk = fmap packet mwk
+        rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
+                             , rtSecring = homesecPath ctx
+                             , rtGrip = grip
+                             , rtWorkingKey = wk
+                             , rtRingAccess = accs
+                             , rtKeyDB = Map.empty
+                             , rtPassphrases = doDecrypt
+                             }
+    transformed0 <-
+        let trans f (info,ps) = do
+                let manip = combineTransforms (transforms info)
+                    rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
+                    acc = Just Sec /= Map.lookup f accs
+                r <- performManipulations doDecrypt rt1 mwk manip
+                try r $ \(rt2,report) -> do
+                return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2))
+#if MIN_VERSION_containers(0,5,0)
+        in fmap sequenceA $ Map.traverseWithKey trans spilled
+#else
+        in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
+#endif
+    try transformed0 $ \transformed -> do
+    let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
+                    where
+                      mergeIt db f (_,(info,ps)) = merge db f ps
+        reportTrans = concat $ Map.elems $ fmap fst transformed
+
+    -- Wallets
+    let importWalletKey wk db' (top,fname,sub,tag) = do
+            try db' $ \(db',report0) -> do
+            r <- doImportG doDecrypt
+                      db'
+                      (fmap keykey $ maybeToList wk)
+                      [mkUsage tag]
+                      fname
+                      sub
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+
+    wms <- mapM (readw wk) (files iswallet)
+    let wallet_keys = do
+            maybeToList wk
+            (fname,xs) <- wms
+            (_,sub,(_,m)) <- xs
+            (tag,top) <- Map.toList m
+            return (top,fname,sub,tag)
+    db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
+    try db $ \(db,reportWallets) -> do
+
+    -- PEM files
+    let pems = do
+            (n,stream) <- Map.toList $ opFiles keyring
+            grip <- maybeToList grip
+            n <- resolveInputFile ctx n
+            guard $ spillable stream && isSecretKeyFile (typ stream)
+            let us = mapMaybe usageFromFilter [fill stream,spill stream]
+            usage <- take 1 us
+            guard $ all (==usage) $ drop 1 us
+            -- TODO: KikiCondition reporting for spill/fill usage mismatch?
+            let (topspec,subspec) = parseSpec grip usage
+                ms = map fst $ filterMatches topspec (Map.toList db)
+                cmd = initializer stream
+            return (n,subspec,ms,stream, cmd)
+    imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
+    db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
+    try db $ \(db,reportPEMs) -> do
+
+    -- generate keys
+    let gens = mapMaybe g $ Map.toList genMap
+                where g (Generate _ params,v) = Just (params,v)
+                      g _                     = Nothing
+
+    db <- generateInternals doDecrypt mwk db gens
+    try db $ \(db,reportGens) -> do
+
+    r <- mergeHostFiles keyring db ctx
+    try r $ \((db,hs),reportHosts) -> do
+
+    return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
+                         , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
+
+generateInternals ::
+    (MappedPacket -> IO (KikiCondition Packet))
+    -> Maybe MappedPacket
+    -> Map.Map KeyKey KeyData
+    -> [(GenerateKeyParams,StreamInfo)]
+    -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
+generateInternals doDecrypt mwk db gens = do
+    case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
+        Just kd0 -> do
+            kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
+            try kd $ \(kd,reportGens) -> do
+            let kk = keykey $ packet $ fromJust mwk
+            return $ KikiSuccess (Map.insert kk kd db,reportGens)
+        Nothing -> return $ KikiSuccess (db,[])
+
+torhash :: Packet -> String
+torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
+
+derToBase32 :: ByteString -> String
+#if !defined(VERSION_cryptonite)
+derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
+#else
+derToBase32 = map toLower . Base32.encode . S.unpack . sha1
+ where
+   sha1 :: L.ByteString -> S.ByteString
+   sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
+#endif
+
+derRSA :: Packet -> Maybe ByteString
+derRSA rsa = do
+    k <- rsaKeyFromPacket rsa
+    return $ encodeASN1 DER (toASN1 k [])
+
+unconditionally :: IO (KikiCondition a) -> IO a
+unconditionally action = do
+    r <- action
+    case r of
+        KikiSuccess x -> return x
+        e -> error $ errorString e
+
+try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
+try x body =
+    case functorToEither x of
+           Left e -> return e
+           Right x -> body x
+
+
+data ParsedCert = ParsedCert
+    { pcertKey :: Packet
+    , pcertTimestamp :: UTCTime
+    , pcertBlob :: L.ByteString
+    }
+ deriving (Show,Eq)
+data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
+ deriving (Show,Eq)
+
+spemPacket (PEMPacket p) = Just p
+spemPacket _ = Nothing
+
+spemCert (PEMCertificate p) = Just p
+spemCert _ = Nothing
+
+toStrict :: L.ByteString -> S.ByteString
+toStrict = foldr1 (<>) . L.toChunks
+
+-- No instance for (ASN1Object RSA.PublicKey)
+
+parseCertBlob comp bs = do
+    asn1 <- either (const Nothing) Just
+                $ decodeASN1 DER bs
+    let asn1' = drop 2 asn1
+    cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
+    let _ = cert :: X509.Certificate
+        notBefore :: UTCTime
+#if MIN_VERSION_x509(1,5,0)
+        notBefore =  toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
+            where (vincentTime,_) = X509.certValidity cert
+#else
+        (notBefore,_) = X509.certValidity cert
+#endif
+    case X509.certPubKey cert of
+        X509.PubKeyRSA key -> do
+            let withoutkey =
+                    let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
+                        (pre,post) = S.breakSubstring ekey $ toStrict bs
+                        post' = S.drop (S.length ekey) post
+                        len :: Word16
+                        len = if S.null post then maxBound
+                                             else fromIntegral $ S.length pre
+                    in if len < 4096
+                        then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
+                        else bs
+            return
+                ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
+                                                               (MPI $ RSA.public_n key)
+                                                               (MPI $ RSA.public_e key)
+                           , pcertTimestamp = notBefore
+                           , pcertBlob = if comp then withoutkey
+                                                 else bs
+                           }
+        _ -> Nothing
+
+packetFromPublicRSAKey notBefore n e =
+    PublicKeyPacket { version = 4
+                    , timestamp = round $ utcTimeToPOSIXSeconds notBefore
+                    , key_algorithm = RSA
+                    , key = [('n',n),('e',e)]
+                    , is_subkey = True
+                    , v3_days_of_validity = Nothing
+                    }
+
+decodeBlob cert =
+    if 0 /= (bs `L.index` 0) .&. 0x10
+     then bs
+     else let (keypos0,bs') = L.splitAt 2 bs
+              keypos :: Word16
+              keypos = decode keypos0
+              ds = GZip.decompress bs'
+              (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
+           in prekey <> key <> postkey
+ where
+    bs = pcertBlob cert
+    key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
+
+extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
+extractRSAKeyFields kvs = do
+    let kvs' = mapMaybe  (\(k,v) -> (k,) <$> parseField v) kvs
+    n <- lookup "Modulus" kvs'
+    e <- lookup "PublicExponent" kvs'
+    d <- lookup "PrivateExponent" kvs'
+    p <- lookup "Prime1" kvs' -- p
+    q <- lookup "Prime2" kvs' -- q
+    dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
+    dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
+    u <- lookup "Coefficient" kvs'
+    {-
+    case (d,p,dmodp1) of
+        (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
+        _ -> error "dmodp fail!"
+    case (d,q,dmodqminus1) of
+        (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
+        _ -> error "dmodq fail!"
+    -}
+    return $ RSAPrivateKey
+        { rsaN = n
+        , rsaE = e
+        , rsaD = d
+        , rsaP = p
+        , rsaQ = q
+        , rsaDmodP1 = dmodp1
+        , rsaDmodQminus1 = dmodqminus1
+        , rsaCoefficient = u }
+ where
+    parseField blob = MPI <$> m
+     where m = bigendian <$> Base64.decode (Char8.unpack blob)
+
+    bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
+     where
+        nlen = length bs
+
+rsaToPGP stamp rsa = SecretKeyPacket
+                { version = 4
+                , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
+                , key_algorithm = RSA
+                , key = [ -- public fields...
+                         ('n',rsaN rsa)
+                        ,('e',rsaE rsa)
+                        -- secret fields
+                        ,('d',rsaD rsa)
+                        ,('p',rsaQ rsa) -- Note: p & q swapped
+                        ,('q',rsaP rsa) -- Note: p & q swapped
+                        ,('u',rsaCoefficient rsa)
+                        ]
+                -- , ecc_curve = def
+                , s2k_useage = 0
+                , s2k = S2K 100 ""
+                , symmetric_algorithm = Unencrypted
+                , encrypted_data = ""
+                , is_subkey = True
+                }
+
+readSecretDNSFile :: InputFile -> IO Packet
+readSecretDNSFile fname = do
+    let ctx = InputFileContext "" ""
+    stamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
+                  . Char8.break (==':'))
+               $ Char8.lines input
+        alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
+        parseAlg spec = case Char8.words spec of
+                            nstr:_ -> case read (Char8.unpack nstr) :: Int of
+                                            2 -> DH
+                                            3 -> DSA -- SHA1
+                                            5 -> RSA -- SHA1
+                                            6 -> DSA -- NSEC3-SHA1 (RFC5155)
+                                            7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
+                                            8 -> RSA -- SHA256
+                                            10 -> RSA -- SHA512 (RFC5702)
+                                            -- 12 -> GOST
+                                            13 -> ECDSA -- P-256 SHA256 (RFC6605)
+                                            14 -> ECDSA -- P-384 SHA384 (RFC6605)
+                            _ -> RSA
+    case alg of
+        RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
+
+
+readSecretPEMFile :: InputFile -> IO [SecretPEMData]
+readSecretPEMFile fname = do
+    -- warn $ fname ++ ": reading ..."
+    let ctx = InputFileContext "" ""
+    -- Note: The key's timestamp is included in it's fingerprint.
+    --       Therefore, we should attempt to preserve it.
+    stamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
+        pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
+                    $ pemParser $ Just "RSA PRIVATE KEY"
+        cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
+                    $ pemParser $ Just "CERTIFICATE"
+        parseRSAPrivateKey dta = do
+           let e = decodeASN1 DER dta
+           asn1 <- either (const $ mzero) return e
+           rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
+           let _ = rsa :: RSAPrivateKey
+           return $ PEMPacket $ rsaToPGP stamp rsa
+        dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
+        mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
+        mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
+            where key' = if tm < fromTime (timestamp key)
+                            then key { timestamp = fromTime tm }
+                            else key
+        mergeDate (tm,_) (Right mb) = (tm,mb)
+    return $ dta
+
+doImport
+  :: (MappedPacket -> IO (KikiCondition Packet))
+     -> Map.Map KeyKey KeyData
+     -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
+doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
+    flip (maybe $ return CannotImportMasterKey)
+         subspec $ \tag -> do
+    (certs,keys) <- case typ of
+        PEMFile -> do
+            ps <- readSecretPEMFile (ArgFile fname)
+            let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
+                    = partition (isJust . spemCert) ps
+            return (certs,keys)
+        DNSPresentation -> do
+            p <- readSecretDNSFile (ArgFile fname)
+            return ([],[p])
+    -- TODO Probably we need to move to a new design where signature
+    -- packets are merged into the database in one phase with null
+    -- signatures, and then the signatures are made in the next phase.
+    -- This would let us merge annotations (like certificates) from
+    -- seperate files.
+    foldM (importKey tag certs) (KikiSuccess (db,[])) keys
+ where
+    importKey tag certs prior key = do
+        try prior $ \(db,report) -> do
+        let (m0,tailms) = splitAt 1 ms
+        if (not (null tailms) || null m0)
+            then return $ AmbiguousKeySpec fname
+            else do
+                let kk = keykey key
+                    cs = filter (\c -> kk==keykey (pcertKey c)) certs
+                    blobs = map mkCertNotation $ nub $ map pcertBlob cs
+                    mkCertNotation bs = NotationDataPacket
+                        { human_readable = False
+                        , notation_name = "x509cert@"
+                        , notation_value = Char8.unpack bs }
+                    datedKey = key { timestamp = fromTime $ minimum dates }
+                    dates = fromTime (timestamp key) : map pcertTimestamp certs
+                r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
+                try r $ \(db',report') -> do
+                return $ KikiSuccess (db',report++report')
+
+doImportG
+  :: (MappedPacket -> IO (KikiCondition Packet))
+     -> Map.Map KeyKey KeyData
+     -> [KeyKey] -- m0,  only head is used
+     -> [SignatureSubpacket] -- tags
+     -> FilePath
+     -> Packet
+     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
+doImportG doDecrypt db m0 tags fname key = do
+    let kk = head m0
+        Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
+    kdr <- insertSubkey doDecrypt kk kd tags fname key
+    try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
+
+insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
+    let 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 = 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 ( KeyData top topsigs uids' subs'
+                                 , 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 -- we need to create a new sig
+        Just (True,sig)  -> -- we can deduce is_new == False
+                            -- we may need to add a tor id
+                            return $ KikiSuccess ( KeyData top topsigs uids' subs'
+                                                 , report )
+        Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
+
+isCryptoCoinKey :: Packet -> Bool
+isCryptoCoinKey p =
+    and [ isKey p
+        , key_algorithm p == ECDSA
+        , lookup 'c' (key p) == Just (MPI secp256k1_id)
+        ]
+
+getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork
+getCryptoCoinTag p | isSignaturePacket p = do
+    -- CryptoCoins.secret
+    let sps = hashed_subpackets p ++ unhashed_subpackets p
+    u <- listToMaybe $ mapMaybe usage sps
+    CryptoCoins.lookupNetwork CryptoCoins.network_name u
+getCryptoCoinTag _ = Nothing
+
+
+coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)]
+coinKeysOwnedBy db wk = do
+    wk <- maybeToList wk
+    let kk = keykey wk
+    KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
+    (subkk,SubKey mp sigs) <- Map.toList subs
+    let sub = packet mp
+    guard $ isCryptoCoinKey sub
+    tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
+    return (tag,mp)
+
+walletImportFormat :: Word8 -> Packet -> String
+walletImportFormat idbyte k = secret_base58_foo
+ where
+    -- isSecret (SecretKeyPacket {}) = True
+    -- isSecret _                    = False
+    secret_base58_foo = base58_encode seckey
+    Just d = lookup 'd' (key k)
+    (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
+    seckey = S.cons idbyte bigendian
+
+writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writeWalletKeys krd db wk = do
+    let cs = db `coinKeysOwnedBy` wk
+    -- export wallet keys
+        isMutableWallet (fill -> KF_None)      = False
+        isMutableWallet (typ -> WalletFile {}) = True
+        isMutableWallet _                      = False
+        files pred = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (pred stream)
+            resolveInputFile (InputFileContext "" "") f
+    let writeWallet report n = do
+        let cs' = do
+            (nw,mp) <- cs
+            -- let fns = Map.keys (locations mp)
+            -- trace ("COIN KEY: "++show fns) $ return ()
+            guard . not $ Map.member n (locations mp)
+            let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
+            return (CryptoCoins.network_name nw,wip)
+        handleIO_ (return report) $ do
+        -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based
+        -- to InputFile-based.
+        withFile n AppendMode $ \fh -> do
+        rs <- forM cs' $ \(net,wip) -> do
+            hPutStrLn fh wip
+            return (n, NewWalletKey net)
+        return (report ++ rs)
+    report <- foldM writeWallet [] (files isMutableWallet)
+    return $ KikiSuccess report
+
+ifSecret :: Packet -> t -> t -> t
+ifSecret (SecretKeyPacket {}) t f = t
+ifSecret _                    t f = f
+
+showPacket :: Packet -> String
+showPacket p | isKey p   = (if is_subkey p
+                              then showPacket0 p
+                              else ifSecret p "----Secret-----" "----Public-----")
+                           ++ " "++show (key_algorithm p)++" "++fingerprint p
+             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
+             | otherwise = showPacket0 p
+showPacket0 p = concat . take 1 $ words (show p)
+
+
+-- | returns Just True so as to indicate that
+-- the public portions of keys will be imported
+importPublic :: Maybe Bool
+importPublic = Just True
+
+-- | returns False True so as to indicate that
+-- the public portions of keys will be imported
+importSecret :: Maybe Bool
+importSecret = Just False
+
+
+-- TODO: Do we need to memoize this?
+guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe ()
+guardAuthentic rt keydata = guard (isauth rt keydata)
+
+isauth :: KeyRingRuntime -> KeyData -> Bool
+isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
+          where wk = workingKey (rtGrip rt) (rtKeyDB rt)
+                dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
+                                                   $ locations p
+                has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
+                 where
+                    goodsig (uidstr,(sigs,_)) = not . null $ do
+                        sig0 <- fmap (packet . fst) sigs
+                        pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0])
+                        signatures_over $ verify (Message [wk]) pre_ov
+
+                workingKey grip use_db = listToMaybe $ do
+                            fp <- maybeToList grip
+                            elm <- Map.elems use_db
+                            guard $ matchSpec (KeyGrip fp) elm
+                            return $ keyPacket elm
+
+writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
+                    -> [(FilePath,KikiReportAction)]
+                {-
+                ->  KeyDB -> Maybe Packet
+                -> FilePath -> FilePath
+                -}
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
+    let isring (KeyRingFile {}) = True
+        isring _                = False
+        db = rtKeyDB rt
+        secring = rtSecring rt
+        pubring = rtPubring rt
+        ctx = InputFileContext secring pubring
+    let s = do
+        (f,f0,stream) <- do
+            (f0,stream) <- Map.toList (opFiles krd)
+            guard (isring $ typ stream)
+            f <- resolveInputFile ctx f0
+            return (f,f0,stream)
+        let db' = fromMaybe db $ do
+                    msg <- Map.lookup f0 unspilled
+                    return $ merge db f0 msg
+            x = do
+                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
+                    wantedForFill acc KF_None       = importByExistingMaster
+                        -- Note the KF_None case is almost irrelevent as it will be
+                        -- filtered later when isMutable returns False.
+                        -- We use importByExistingMaster in order to generate
+                        -- MissingPacket warnings.  To disable those warnings, use
+                        -- const Nothing instead.
+                    wantedForFill acc (KF_Match {}) = importByExistingMaster
+                    wantedForFill acc KF_Subkeys    = importByExistingMaster
+                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
+                                                                importByAccess acc kd
+                    wantedForFill acc KF_All        = importByAccess acc
+                    importByAccess Pub kd = importPublic
+                    importByAccess Sec kd = importSecret
+                    importByAccess AutoAccess kd =
+                        mplus (importByExistingMaster kd)
+                              (error $ f ++ ": write public or secret key to file?")
+                    importByExistingMaster kd@(KeyData p _ _ _) =
+                        fmap originallyPublic $ Map.lookup f $ locations p
+                d <- sortByHint f keyMappedPacket (Map.elems db')
+                acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
+                only_public <- maybeToList $ wantedForFill acc (fill stream) d
+                guard $ only_public || isSecretKey (keyPacket d)
+                case fill stream of
+                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
+                                         flattenTop f only_public
+                                            $ filterNewSubs f (parseSpec grip usage) d
+                    _              -> flattenTop f only_public d
+            new_packets = filter isnew x
+                where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
+            -- TODO: We depend on an exact string match between the reported
+            -- file origin of the deleted packet and the path of the file we are
+            -- writing.  Verify that this is a safe assumption.
+            isdeleted (f',DeletedPacket _) = f'==f
+            isdeleted _                    = False
+        guard (not (null new_packets) || any isdeleted report_manips)
+        return ((f0,isMutable stream),(new_packets,x))
+    let (towrites,report) = (\f -> foldl f ([],[]) s) $
+         \(ws,report) ((f,mutable),(new_packets,x)) ->
+            if mutable
+                then
+                     let rs = flip map new_packets
+                                $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c))
+                     in (ws++[(f,x)],report++rs)
+                else
+                     let rs = flip map new_packets
+                                $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c)))
+                     in (ws,report++rs)
+    forM_ towrites $ \(f,x) -> do
+        let m = Message $ map packet x
+        -- warn $ "writing "++f
+        writeInputFileL ctx f (encode m)
+    return $ KikiSuccess report
+
+
+{-
+getSubkeysForExport kk subspec db = do
+    kd <- maybeToList $ Map.lookup kk db
+    subkeysForExport subspec kd
+-}
+
+-- | If provided Nothing for the first argument, this function returns the
+-- master key of the given identity.  Otherwise, it returns all the subkeys of
+-- the given identity which have a usage tag that matches the first argument.
+subkeysForExport :: Maybe String -> KeyData -> [MappedPacket]
+subkeysForExport subspec (KeyData key _ _ subkeys) = do
+    let subs tag = do
+            e <- Map.elems subkeys
+            guard $ doSearch key tag e
+            return $ subkeyMappedPacket e
+    maybe [key] subs subspec
+ where
+    doSearch key tag (SubKey sub_mp sigtrusts) =
+        let (_,v,_) = findTag [mkUsage tag]
+                          (packet key)
+                          (packet sub_mp)
+                          sigtrusts
+        in fmap fst v==Just True
+
+writePEM :: String -> String -> String
+writePEM typ dta = pem
+ where
+    pem = unlines . concat $
+            [ ["-----BEGIN " <> typ <> "-----"]
+            , split64s dta
+            , ["-----END " <> typ <> "-----"] ]
+    split64s :: String -> [String]
+    split64s "" = []
+    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
+
+    -- 64 byte lines
+
+rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
+rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
+    -- public fields...
+    n <- lookup 'n' $ key pkt
+    e <- lookup 'e' $ key pkt
+    -- secret fields
+    MPI d <- lookup 'd' $ key pkt
+    MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
+    MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
+
+    -- Note: Here we fail if 'u' key is missing.
+    -- Ideally, it would be better to compute (inverse q) mod p
+    -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
+    --     (package constructive-algebra)
+    coefficient <- lookup 'u' $ key pkt
+
+    let dmodp1 = MPI $ d `mod` (p - 1)
+        dmodqminus1 = MPI $ d `mod` (q - 1)
+    return $ RSAPrivateKey
+        { rsaN = n
+        , rsaE = e
+        , rsaD = MPI d
+        , rsaP = MPI p
+        , rsaQ = MPI q
+        , rsaDmodP1 = dmodp1
+        , rsaDmodQminus1 = dmodqminus1
+        , rsaCoefficient = coefficient }
+rsaPrivateKeyFromPacket _ = Nothing
+
+secretPemFromPacket packet = pemFromPacket Sec packet
+
+pemFromPacket Sec packet =
+    case key_algorithm packet of
+     RSA -> do
+        rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
+        let asn1 = toASN1 rsa []
+            bs = encodeASN1 DER asn1
+            dta = Base64.encode (L.unpack bs)
+            output = writePEM "RSA PRIVATE KEY" dta
+        Just output
+     algo -> Nothing
+pemFromPacket Pub packet =
+    case key_algorithm packet of
+     RSA -> do
+        rsa <- rsaKeyFromPacket packet
+        let asn1 = toASN1 (pkcs8 rsa) []
+            bs = encodeASN1 DER asn1
+            dta = Base64.encode (L.unpack bs)
+            output = writePEM "PUBLIC KEY" dta
+        Just output
+     algo -> Nothing
+pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p
+pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p
+pemFromPacket AutoAccess _ = Nothing
+
+writeKeyToFile ::
+  Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
+writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do
+    case pemFromPacket (access stream) packet of
+     Just output -> do
+        let stamp = toEnum . fromEnum $ timestamp packet
+        handleIO_ (return [(fname, FailedFileWrite)]) $ do
+            saved_mask <- setFileCreationMask 0o077
+            -- Note: The key's timestamp is included in it's fingerprint.
+            --       Therefore, we should attempt to preserve it.
+            writeStamped (InputFileContext "" "") fname stamp output
+            setFileCreationMask saved_mask
+            return [(fname, ExportedSubkey)]
+     Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]
+
+writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do
+    case key_algorithm packet of
+     RSA -> do
+        flip (maybe (return []))
+             (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
+            $ \rsa -> do
+        let -- asn1 = toASN1 rsa []
+            -- bs = encodeASN1 DER asn1
+            -- dta = Base64.encode (L.unpack bs)
+            b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
+             where
+                MPI i = ac rsa
+                i2bs_unsized :: Integer -> S.ByteString
+                i2bs_unsized 0 = S.singleton 0
+                i2bs_unsized i = S.reverse $ S.unfoldr go i
+                 where go i' = if i' <= 0 then Nothing
+                                          else Just (fromIntegral i', (i' `shiftR` 8))
+            output = unlines
+                [ "Private-key-format: v1.2"
+                , "Algorithm: 8 (RSASHA256)"
+                , "Modulus: " ++ b64 rsaN rsa
+                , "PublicExponent: " ++ b64 rsaE rsa
+                , "PrivateExponent: " ++ b64 rsaD rsa
+                , "Prime1: " ++ b64 rsaP rsa
+                , "Prime2: " ++ b64 rsaQ rsa
+                , "Exponent1: " ++ b64 rsaDmodP1 rsa
+                , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
+                , "Coefficient: " ++ b64 rsaCoefficient rsa
+                ]
+            stamp = toEnum . fromEnum $ timestamp packet
+        handleIO_ (return [(fname, FailedFileWrite)]) $ do
+            saved_mask <- setFileCreationMask 0o077
+            -- Note: The key's timestamp is included in it's fingerprint.
+            --       Therefore, we should attempt to preserve it.
+            writeStamped (InputFileContext "" "") fname stamp output
+            setFileCreationMask saved_mask
+            return [(fname, ExportedSubkey)]
+     algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
+
+writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
+                -> KeyDB
+                -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writePEMKeys doDecrypt db exports = do
+    ds <- mapM decryptKeys exports
+    let ds' = map functorToEither ds
+    if null (lefts ds')
+        then do
+            rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p)
+                       (rights ds')
+            return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
+        else do
+            return (head $ lefts ds')
+ where
+    decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
+        = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
+    decryptKeys (fname,subspec,[p],stream) = do
+        pun <- doDecrypt p
+        try pun $ \pun -> do
+        return $ KikiSuccess (fname,stream,pun)
+
+makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+                        -> Map.Map KeyKey MappedPacket
+                        -> IO (MappedPacket -> IO (KikiCondition Packet))
+makeMemoizingDecrypter operation ctx keys =
+   if null chains then  do
+    -- (*) Notice we do not pass ctx to resolveForReport.
+    -- This is because the merge function does not currently use a context
+    -- and the pws map keys must match the MappedPacket locations.
+    -- TODO: Perhaps these should both be of type InputFile rather than
+    -- FilePath?
+    -- pws :: Map.Map FilePath (IO S.ByteString)
+    {-
+    pws <-
+        Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
+                         (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
+                            $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
+    -}
+        let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
+        pws2 <- 
+            Traversable.mapM (cachedContents prompt ctx)
+             $ Map.fromList $ mapMaybe
+                    (\spec -> (,passSpecPassFile spec) `fmap` do
+                        guard $ isNothing $ passSpecKeySpec spec
+                        passSpecRingFile spec)
+                    passspecs
+        defpw <- do
+            Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
+             $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
+                                            && isNothing (passSpecKeySpec sp))
+                                        $ opPassphrases operation
+        unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
+        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
+    else let PassphraseMemoizer f = head chains
+         in return f
+ where
+    (chains,passspecs) = partition isChain $ opPassphrases operation
+                            where isChain (PassphraseMemoizer {}) = True
+                                  isChain _ = False
+    doDecrypt :: IORef (Map.Map KeyKey Packet)
+                -> Map.Map FilePath (IO S.ByteString)
+                -> Maybe (IO S.ByteString)
+                -> MappedPacket
+                -> IO (KikiCondition Packet)
+    doDecrypt unkeysRef pws defpw mp0 = do
+        unkeys <- readIORef unkeysRef
+        let mp = fromMaybe mp0 $ do
+                    k <- Map.lookup kk keys
+                    return $ mergeKeyPacket "decrypt" mp0 k
+            wk = packet mp0
+            kk = keykey wk
+            fs = Map.keys $ locations mp
+
+            decryptIt [] = return BadPassphrase
+            decryptIt (getpw:getpws) = do
+                -- TODO: This function should use mergeKeyPacket to 
+                --  combine the packet with it's unspilled version before
+                --  attempting to decrypt it.
+                pw <- getpw
+                let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
+                case symmetric_algorithm wkun of
+                    Unencrypted -> do
+                        writeIORef unkeysRef (Map.insert kk wkun unkeys)
+                        return $ KikiSuccess wkun
+                    _ -> decryptIt getpws
+
+            getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
+
+        case symmetric_algorithm wk of
+            Unencrypted -> return (KikiSuccess wk)
+            _ -> maybe (decryptIt getpws)
+                       (return . KikiSuccess)
+                    $ Map.lookup kk unkeys
+
+performManipulations ::
+                (MappedPacket -> IO (KikiCondition Packet))
+                -> KeyRingRuntime
+                -> Maybe MappedPacket
+                -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
+                -> IO (KikiCondition (KeyRingRuntime,KikiReport))
+performManipulations doDecrypt rt wk manip = do
+    let db = rtKeyDB rt
+        performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
+    r <- Traversable.mapM performAll db
+    try (sequenceA r) $ \db -> do
+    return $ KikiSuccess (rt { rtKeyDB =  fmap fst db }, concatMap snd $ Map.elems db)
+ where
+    perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
+    perform kd (InducerSignature uid subpaks) = do
+        try kd $ \(kd,report) -> do
+        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
+        wkun' <- doDecrypt wk'
+        try wkun' $ \wkun -> do    
+        let flgs = if keykey (keyPacket kd) == keykey wkun
+                    then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
+                    else []
+            sigOver = makeInducerSig (keyPacket kd)
+                                     wkun
+                                     (UserIDPacket uid)
+                                     $ flgs ++ subpaks
+            om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
+            toMappedPacket om p = (mappedPacket "" p) {locations=om}
+            selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
+                                   . (== keykey whosign)
+                                   . keykey)) vs
+            keys = map keyPacket $ Map.elems (rtKeyDB rt)
+            overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
+            vs :: [ ( Packet -- signature
+                   , Maybe SignatureOver -- Nothing means non-verified
+                   , Packet ) -- key who signed
+                 ]
+            vs = do
+                   x <- maybeToList $ Map.lookup uid (keyUids kd)
+                   sig <- map (packet . fst) (fst x)
+                   o <- overs sig
+                   k <- keys
+                   let ov = verify (Message [k]) $ o
+                   signatures_over ov
+                   return (sig,Just ov,k)
+            additional new_sig = do
+                new_sig <- maybeToList new_sig
+                guard (null $ selfsigs)
+                signatures_over new_sig
+        sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
+        let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
+            f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
+                  , om `Map.union` snd x )
+        -- XXX: Shouldn't this signature generation show up in the KikiReport ?
+        return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
+
+    perform kd (SubKeyDeletion topk subk) = do
+        try kd $ \(kd,report) -> do
+        let kk = keykey $ packet $ keyMappedPacket kd
+            kd' | kk /= topk = kd
+                | otherwise  = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
+            pred k _ = k /= subk
+            ps = concat $ maybeToList $ do
+                SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
+                return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
+            ctx = InputFileContext (rtSecring rt) (rtPubring rt)
+            rings = [HomeSec, HomePub] >>= resolveInputFile ctx
+        return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
+
+initializeMissingPEMFiles ::
+    KeyRingOperation
+      -> InputFileContext
+      -> Maybe String
+      -> Maybe MappedPacket
+      -> (MappedPacket -> IO (KikiCondition Packet))
+      -> KeyDB
+      -> IO (KikiCondition ( (KeyDB,[( FilePath
+                                     , Maybe String
+                                     , [MappedPacket]
+                                     , StreamInfo )])
+                           , [(FilePath,KikiReportAction)]))
+initializeMissingPEMFiles operation ctx grip mwk 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
+                let internalInitializer StreamInfo
+                        { initializer = Internal _
+                        , spill       = KF_Match tag } = Just tag
+                    internalInitializer _              = Nothing
+                    mutableTag
+                        | isMutable stream = usageFromFilter (fill stream)
+                        | otherwise        = Nothing
+                usage <- maybeToList $ internalInitializer stream `mplus` mutableTag
+                -- TODO: Report error if generating without specifying usage tag.
+                let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
+                    -- ms will contain duplicates if a top key has multiple matching
+                    -- subkeys.  This is intentional.
+                    -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
+                    -- ms = filterMatches topspec $ Map.toList db
+                    ns = do
+                       (kk,kd) <- filterMatches topspec $ Map.toList db
+                       return (kk , subkeysForExport subspec kd)
+                return (fname,subspec,ns,stream)
+            (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
+                                             notmissing
+            exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0
+
+            ambiguity (f,topspec,subspec,_) = do
+               return $ AmbiguousKeySpec f
+
+            ifnotnull (x:xs) f g = f x
+            ifnotnull _      f g = g
+
+        ifnotnull ambiguous ambiguity $ do
+
+        -- create nonexistent files via external commands
+        do
+           let cmds = mapMaybe getcmd missing
+                 where
+                   getcmd (fname,subspec,ms,stream) = do
+                       cmd <- case initializer stream of
+                                External str -> Just str
+                                _            -> Nothing
+                       return (fname,subspec,ms,stream,cmd)
+           rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
+               e <- systemEnv [ ("file",fname)
+                              , ("usage",fromMaybe "" subspec) ]
+                              cmd
+               case e of
+                 ExitFailure num -> return (tup,FailedExternal num)
+                 ExitSuccess     -> return (tup,ExternallyGeneratedFile)
+
+           v <- foldM (importSecretKey decrypt)
+                      (KikiSuccess (db,[])) $ do
+                    ((f,subspec,ms,stream,cmd),r) <- rs
+                    guard $ case r of
+                       ExternallyGeneratedFile -> True
+                       _ -> False
+                    return (f,subspec,map fst ms,stream,cmd)
+
+           try v $ \(db,import_rs) -> do
+
+           -- generateInternals
+           let internals = mapMaybe getParams missing
+                where
+                    getParams (fname,subspec,ms,stream) =
+                        case initializer stream of
+                            Internal p -> Just (p, stream)
+                            _          -> Nothing
+           v <- generateInternals decrypt mwk db internals
+
+           try v $ \(db,internals_rs) -> do
+
+           return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
+                                     ++ import_rs ++ internals_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
+                                                   wk
+                                                   decrypt
+                                                   db
+        try' externals_ret $ \((db,exports),report_externals) -> do
+
+        let rt = KeyRingRuntime
+                       { rtPubring = homepubPath ctx
+                       , rtSecring = homesecPath ctx
+                       , rtGrip = grip
+                       , rtWorkingKey = fmap packet wk
+                       , rtKeyDB = db
+                       , rtRingAccess = accs
+                       , rtPassphrases = decrypt
+                       }
+
+        r <- performManipulations decrypt
+                                  rt
+                                  wk
+                                  (combineTransforms $ opTransforms operation)
+        try' r $ \(rt,report_manips) -> do
+
+        r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
+        try' r $ \report_wallets -> do
+
+        r <- writeRingKeys operation rt unspilled report_manips
+        try' r $ \report_rings -> do
+
+        r <- writePEMKeys decrypt (rtKeyDB rt) exports
+        try' r $ \report_pems -> do
+        
+        import_hosts <- writeHostsFiles operation ctx hs
+
+        return $ KikiResult (KikiSuccess rt)
+                   $ concat [ report_imports
+                            , report_externals
+                            , report_manips
+                            , report_wallets
+                            , report_rings
+                            , report_pems ]
+
+    forM_ lked $ \(Just lk, fname) -> dotlock_release lk
+
+    return ret
+
+parseOptionFile :: FilePath -> IO [String]
+parseOptionFile fname = do
+    xs <- fmap lines (readFile fname)
+    let ys = filter notComment xs
+        notComment ('#':_) = False
+        notComment cs      = not (all isSpace cs)
+    return ys
+
+-- | returns ( home directory
+--           , path to secret ring
+--           , path to public ring
+--           , fingerprint of working key
+--           )
+getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
+getHomeDir protohome = do
+        homedir <- envhomedir protohome
+        flip (maybe (return CantFindHome))
+             homedir $ \homedir -> do
+        -- putStrLn $ "homedir = " ++show homedir
+        let secring = homedir ++ "/" ++ "secring.gpg"
+            pubring = homedir ++ "/" ++ "pubring.gpg"
+        -- putStrLn $ "secring = " ++ show secring
+        workingkey <- getWorkingKey homedir
+        return $ KikiSuccess (homedir,secring,pubring,workingkey)
+ where
+    envhomedir opt = do
+        gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
+        homed <- fmap (mfilter (/="") . Just) getHomeDirectory
+        let homegnupg = (++('/':(appdir home))) <$> homed
+        let val = (opt `mplus` gnupghome `mplus` homegnupg)
+        return $ val
+
+    -- TODO: rename this to getGrip
+    getWorkingKey homedir = do
+        let o = Nothing
+            h = Just homedir
+        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
+                let optfiles = map (second ((h++"/")++))
+                                   (maybe optfile_alts' (:[]) o')
+                    optfile_alts' = zip (False:repeat True) (optfile_alts home)
+                    o' = fmap (False,) o
+                in filterM (doesFileExist . snd) optfiles
+        args <- flip (maybe $ return []) ofile $
+            \(forgive,fname) -> parseOptionFile fname
+        let config = map (topair . words) args
+                        where topair (x:xs) = (x,xs)
+        return $ lookup "default-key" config >>= listToMaybe
+
+#if MIN_VERSION_base(4,6,0)
+#else
+lookupEnv :: String -> IO (Maybe String) 
+lookupEnv var =
+    handleIO_ (return Nothing) $ fmap Just (getEnv var)
+#endif
+
+isKey :: Packet -> Bool
+isKey (PublicKeyPacket {}) = True
+isKey (SecretKeyPacket {}) = True
+isKey _                    = False
+
+isUserID :: Packet -> Bool
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isTrust :: Packet -> Bool
+isTrust (TrustPacket {}) = True
+isTrust _                = False
+
+sigpackets ::
+  Monad m =>
+  Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
+sigpackets typ hashed unhashed = return $
+    signaturePacket
+        4 -- version
+        typ -- 0x18 subkey binding sig, or 0x19 back-signature
+        RSA
+        SHA1
+        hashed
+        unhashed
+        0 -- Word16 -- Left 16 bits of the signed hash value
+        [] -- [MPI]
+
+secretToPublic :: Packet -> Packet
+secretToPublic pkt@(SecretKeyPacket {}) =
+    PublicKeyPacket { version = version pkt
+                    , timestamp = timestamp pkt
+                    , key_algorithm = key_algorithm pkt
+                    -- , ecc_curve = ecc_curve pkt
+                    , key = let seckey = key pkt
+                                pubs = public_key_fields (key_algorithm pkt)
+                            in filter (\(k,v) -> k `elem` pubs) seckey
+                    , is_subkey = is_subkey pkt
+                    , v3_days_of_validity = Nothing
+                    }
+secretToPublic pkt = pkt
+
+
+
+slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
+slurpWIPKeys stamp "" = ([],[])
+slurpWIPKeys stamp cs =
+    let (b58,xs) = Char8.span (`elem` base58chars) cs
+        mb        = decode_btc_key stamp (Char8.unpack b58)
+    in if L.null b58
+        then let (ys,xs') = Char8.break (`elem` base58chars) cs
+                 (ks,js)  = slurpWIPKeys stamp xs'
+             in (ks,ys:js)
+        else let (ks,js) = slurpWIPKeys stamp xs
+             in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
+
+
+decode_btc_key ::
+  Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
+decode_btc_key timestamp str = do
+    (network_id,us) <- base58_decode str
+    return . (network_id,) $ Message $ do
+        let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
+            {-
+            xy = secp256k1_G `pmul` d
+            x = getx xy
+            y = gety xy
+            -- y² = x³ + 7 (mod p)
+            y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            -}
+            secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
+            ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
+            -- pub = cannonical_eckey x y
+            -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
+            -- address = base58_encode hash
+            -- pubstr = concatMap (printf "%02x") $ pub
+            -- _ = pubstr :: String
+        return $ {- trace (unlines ["pub="++show pubstr
+                                ,"add="++show address
+                                ,"y  ="++show y
+                                ,"y' ="++show y'
+                                ,"y''="++show y'']) -}
+            SecretKeyPacket
+            { version = 4
+            , timestamp = toEnum (fromEnum timestamp)
+            , key_algorithm = ECDSA
+            , key = [ -- public fields...
+                     ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
+                    ,('l',MPI 256)
+                    ,('x',MPI x)
+                    ,('y',MPI y)
+                    -- secret fields
+                    ,('d',MPI d)
+                    ]
+            , s2k_useage = 0
+            , s2k = S2K 100 ""
+            , symmetric_algorithm = Unencrypted
+            , encrypted_data = ""
+            , is_subkey = True
+            }
+
+rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
+rsaKeyFromPacket p | isKey p = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
+
+rsaKeyFromPacket _ = Nothing
+
+
+readPacketsFromWallet ::
+    Maybe Packet
+    -> InputFile
+    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+readPacketsFromWallet wk fname = do
+    let ctx = InputFileContext "" ""
+    timestamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let (ks,_) = slurpWIPKeys timestamp input
+    unless (null ks) $ do
+        -- decrypt wk
+        -- create sigs
+        -- return key/sig pairs
+        return ()
+    return $ do
+        wk <- maybeToList wk
+        guard (not $ null ks)
+        let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
+                                where tag = CryptoCoins.nameFromSecretByte tagbyte
+        (wk,MarkerPacket,(MarkerPacket,Map.empty))
+         :map prep ks
+
+readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
+readPacketsFromFile ctx fname = do
+    -- warn $ fname ++ ": reading..."
+    input <- readInputFileL ctx fname
+#if MIN_VERSION_binary(0,7,0)
+    return $
+      case decodeOrFail input of
+        Right (_,_,msg ) -> msg
+        Left  (_,_,_)    ->
+          -- FIXME
+          -- trace (fname++": read fail") $
+          Message []
+#else
+    return $ decode input
+#endif
+
+-- | Get the time stamp of a signature.
+--
+-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
+-- the hashed section.  TODO: change this?
+--
+signature_time :: SignatureOver -> Word32
+signature_time ov = case (if null cs then ds else cs) of
+                                [] -> minBound
+                                xs -> maximum xs
+          where
+            ps = signatures_over ov
+            ss = filter isSignaturePacket ps
+            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
+            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
+            creationTime (SignatureCreationTimePacket t) = [t]
+            creationTime _                               = []
+
+splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
+splitAtMinBy comp xs = minimumBy comp' xxs
+ where
+    xxs = zip (inits xs) (tails xs)
+    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
+    compM (Just a) (Just b) = comp a b
+    compM Nothing  mb       = GT
+    compM _        _        = LT
+
+
+
+-- | Given list of subpackets, a master key, one of its subkeys and a
+-- list of signatures on that subkey, yields:
+--
+--   * preceding list of signatures
+--
+--   * The most recent valid signature made by the master key along with a
+--   flag that indicates whether or not all of the supplied subpackets occur in
+--   it or, if no valid signature from the working key is present, Nothing.
+--
+--   * following list of signatures
+--
+findTag ::
+  [SignatureSubpacket]
+  -> Packet
+  -> Packet
+  -> [(MappedPacket, b)]
+  -> ([(MappedPacket, b)],
+      Maybe (Bool, (MappedPacket, b)),
+      [(MappedPacket, b)])
+findTag tag topk subkey subsigs = (xs',minsig,ys')
+         where
+            vs = map (\sig ->
+                          (sig, do
+                                sig <- Just (packet . fst $ sig)
+                                guard (isSignaturePacket sig)
+                                guard $ flip isSuffixOf
+                                             (fingerprint topk)
+                                        . fromMaybe "%bad%" 
+                                        . signature_issuer
+                                        $ sig
+                                listToMaybe $
+                                  map (signature_time . verify (Message [topk]))
+                                      (signatures $ Message [topk,subkey,sig])))
+                     subsigs
+            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
+            xs' = map fst xs
+            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
+            minsig = do
+                (sig,ov) <- listToMaybe ys
+                ov
+                let hshed = hashed_subpackets $ packet $ fst sig
+                return ( null $ tag \\ hshed, sig)
+
+mkUsage :: String -> SignatureSubpacket
+mkUsage tag = NotationDataPacket
+                { human_readable = True
+                , notation_name = "usage@"
+                , notation_value = tag
+                }
+
+makeSig ::
+  (MappedPacket -> IO (KikiCondition Packet))
+  -> MappedPacket
+  -> [Char]
+  -> MappedPacket
+  -> [SignatureSubpacket]
+  -> Maybe (MappedPacket, Map.Map k a)
+  -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
+makeSig doDecrypt top fname subkey_p tags mbsig = do
+    let wk = packet top
+    wkun <- doDecrypt top
+    try wkun $ \wkun -> do
+    let grip = fingerprint wk
+        addOrigin new_sig =
+            flip (maybe $ return FailedToMakeSignature)
+                 (new_sig >>= listToMaybe . signatures_over)
+                 $ \new_sig -> do
+            let mp' = mappedPacket fname new_sig
+            return $ KikiSuccess (mp', Map.empty)
+        parsedkey = [packet subkey_p]
+        hashed0 = KeyFlagsPacket
+                    { certify_keys = False
+                    , sign_data = False
+                    , encrypt_communication = False
+                    , encrypt_storage = False
+                    , split_key = False
+                    , authentication = True
+                    , group_key = False }
+                    : tags
+                    -- implicitly added:
+                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
+        subgrip = fingerprint (head parsedkey)
+
+    back_sig <- pgpSign (Message parsedkey)
+                        (SubkeySignature wk
+                                         (head parsedkey)
+                                         (sigpackets 0x19
+                                                     hashed0
+                                                     [IssuerPacket subgrip]))
+                        (if key_algorithm (head parsedkey)==ECDSA
+                            then SHA256
+                            else SHA1)
+                        subgrip
+    let iss = IssuerPacket (fingerprint wk)
+        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
+        unhashed0 = maybe [iss] cons_iss back_sig
+
+    new_sig <- pgpSign (Message [wkun])
+                       (SubkeySignature wk
+                                        (head parsedkey)
+                                        (sigpackets 0x18
+                                                   hashed0
+                                                   unhashed0))
+                      SHA1
+                      grip
+    let newSig = do
+            r <- addOrigin new_sig
+            return $ fmap (,[]) r
+    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
+    let sig = packet mp
+        isCreation (SignatureCreationTimePacket {}) = True
+        isCreation _ = False
+        isExpiration (SignatureExpirationTimePacket {}) = True
+        isExpiration _ = False
+        (cs,ps) = partition isCreation (hashed_subpackets sig)
+        (es,qs) = partition isExpiration ps
+        stamp = listToMaybe . sortBy (comparing Down) $
+                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
+        exp = listToMaybe $ sort $
+                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
+        expires = liftA2 (+) stamp exp
+    timestamp <- now
+    if fmap ( (< timestamp) . fromIntegral) expires == Just True then
+        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
+    else do
+        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
+                        $ maybeToList $ do
+                            e <- expires
+                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
+            sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
+        new_sig <- pgpSign (Message [wkun])
+                           (SubkeySignature wk
+                                            (packet subkey_p)
+                                            [sig'] )
+                           SHA1
+                           (fingerprint wk)
+        newsig <- addOrigin new_sig
+        return $ fmap (,[]) newsig
+
+
+
+data OriginFlags = OriginFlags {
+        originallyPublic :: Bool,
+        originalNum :: Int
+    }
+    deriving Show
+type OriginMap = Map.Map FilePath OriginFlags
+data MappedPacket = MappedPacket
+        { packet :: Packet
+        , locations :: OriginMap
+        } deriving Show
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
+
+type KeyKey = [ByteString]
+data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
+
+-- | This is a GPG Identity which includes a master key and all its UIDs and
+-- subkeys and associated signatures.
+data KeyData = KeyData { keyMappedPacket :: MappedPacket    -- main key
+                       , keySigAndTrusts :: [SigAndTrust]  -- sigs on main key
+                       , keyUids :: (Map.Map String ([SigAndTrust],OriginMap))  -- uids
+                       , keySubKeys :: (Map.Map KeyKey SubKey)    -- subkeys
+                       } deriving Show
+
+type KeyDB = Map.Map KeyKey KeyData
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket :: FilePath -> Packet -> MappedPacket
+mappedPacket filename p = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
+keykey :: Packet -> KeyKey
+keykey key =
+    -- Note: The key's timestamp is normally included in it's fingerprint.
+    --       This is undesirable for kiki because it causes the same
+    --       key to be imported multiple times and show as apparently
+    --       distinct keys with different fingerprints.
+    --       Thus, we will remove the timestamp.
+    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
+
+uidkey :: Packet -> String
+uidkey (UserIDPacket str) = str
+
+merge :: KeyDB -> InputFile -> Message -> KeyDB
+merge db inputfile (Message ps) = merge_ db filename qs
+ where
+    filename = resolveForReport Nothing inputfile
+
+    qs = scanPackets filename ps
+
+    scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+    scanPackets filename [] = []
+    scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
+     where
+        ret p = (p,Map.empty)
+        doit (top,sub,prev) p =
+            case p of
+                _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
+                _ | isKey p && is_subkey p       -> (top,p,ret p)
+                _ | isUserID p                   -> (top,p,ret p)
+                _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
+                _                                -> (top,sub,ret p)
+
+        updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
+
+
+{-
+onionName :: KeyData -> (SockAddr,L.ByteString)
+onionName kd = (addr,name)
+ where
+    (addr,(name:_,_)) = getHostnames kd
+-}
+keyCompare :: String -> Packet -> Packet -> Ordering
+keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+keyCompare what a b | keykey a==keykey b = EQ
+keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
+                              , fingerprint a
+                              , PP.ppShow a
+                              , fingerprint b
+                              , PP.ppShow b
+                              ]
+
+mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
+mergeKeyPacket what key p = 
+    key { packet = minimumBy (keyCompare what) [packet key,packet p]
+        , locations = Map.union (locations key) (locations p)
+        }
+
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    asMapped n p = mappedPacketWithHint filename p n
+    asSigAndTrust n (p,tm) = (asMapped n p,tm)
+    emptyUids = Map.empty
+    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
+    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
+     where
+        -- NOTE:
+        --  if a keyring file has both a public key packet and a secret key packet
+        --  for the same key, then only one of them will survive, which ever is
+        --  later in the file.
+        --
+        --  This is due to the use of statements like
+        --      (Map.insert filename (origin p n) (locations key))
+        --
+        update :: Maybe KeyData -> Maybe KeyData
+        update v | isKey p && not (is_subkey p)
+          = case v of
+             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
+                     -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
+                                       sigs
+                                       uids
+                                       subkeys
+             _       -> error . concat $ ["Unexpected master key merge error: "
+                                         ,show (fingerprint top, fingerprint p)]
+        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
+          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
+        update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
+                                    subkeys
+        update (Just (KeyData key sigs uids subkeys))
+          = case sub of
+             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
+             UserIDPacket {} -> Just $ KeyData key
+                                               sigs
+                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               subkeys
+             _  | isKey sub  -> Just $ KeyData key
+                                               sigs
+                                               uids
+                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
+             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
+        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
+
+    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
+
+    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
+    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
+    mergeSubkey n p (Just (SubKey key sigs)) = Just $
+        SubKey (mergeKeyPacket "subs" key $ asMapped n p)
+               sigs
+
+    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
+    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
+    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
+    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
+
+    whatP (a,_) = concat . take 1 . words . show $ a
+
+
+    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
+    mergeSig n sig sigs =
+      let (xs,ys) = break (isSameSig sig) sigs
+      in if null ys
+          then sigs++[first (asMapped n) sig]
+          else let y:ys'=ys
+               in xs ++ (mergeSameSig n sig y : ys')
+     where
+        isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
+            a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
+        isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
+
+        mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
+        mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
+          | isSignaturePacket a && isSignaturePacket b =
+                ( m { packet = b { unhashed_subpackets =
+                                      union (unhashed_subpackets b) (unhashed_subpackets a)
+                                 }
+                   , locations = Map.insert filename (origin a n) locs }
+                -- TODO: when merging items, we should delete invalidated origins
+                -- from the orgin map.
+                , tb `Map.union` ta )
+
+        mergeSameSig n a b = b -- trace ("discarding dup "++show a) b
+
+    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
+    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
+
+    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
+    mergeSubSig n sig Nothing = error $
+        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
+
+unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
+unsig fname isPublic (sig,trustmap) =
+    sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
+  where
+    f n _ = n==fname -- && trace ("fname=n="++show n) True
+    asMapped n p = let m = mappedPacket fname p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
+
+concatSort ::
+  FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
+concatSort fname getp f = concat . sortByHint fname getp . map f
+
+sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
+sortByHint fname f = sortBy (comparing gethint)
+  where
+    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
+    defnum = -1
+
+flattenKeys :: Bool -> KeyDB -> Message
+flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
+ where
+    prefilter = if isPublic then id else filter isSecret
+                 where
+                  isSecret (_,(KeyData
+                                  (MappedPacket { packet=(SecretKeyPacket {})})
+                                  _
+                                  _
+                                  _)) = True
+                  isSecret _          = False
+
+
+flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
+flattenTop fname ispub (KeyData key sigs uids subkeys) =
+    unk ispub key :
+            ( flattenAllUids fname ispub uids
+             ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
+
+flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
+flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
+
+unk :: Bool -> MappedPacket -> MappedPacket
+unk isPublic = if isPublic then toPacket secretToPublic else id
+                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
+
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
+flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
+flattenUid fname ispub (str,(sigs,om)) =
+    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
+
+getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
+getCrossSignedSubkeys topk subs tag = do
+        SubKey k sigs <- Map.elems subs
+        let subk = packet k
+        let sigs' = do
+                torsig <- filter (has_tag tag) $ 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)) ]
+
+
+-- |
+-- Returns (ip6 fingerprint address,(onion names,other host names))
+--
+-- Requires a validly cross-signed tor key for each onion name returned.
+-- (Signature checks are performed.)
+getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
+getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
+ where
+    othernames = do
+        mp <- flattenAllUids "" True uids
+        let p = packet mp
+        guard $ isSignaturePacket p
+        uh <- unhashed_subpackets p
+        case uh of
+            NotationDataPacket True "hostname@" v
+              -> return $ Char8.pack v
+            _ -> mzero
+
+    addr = fingerdress topk
+    -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
+    topk = packet topmp
+    torkeys = getCrossSignedSubkeys topk subs "tor"
+
+    -- subkeyPacket (SubKey k _ ) = k
+    onames :: [L.ByteString]
+    onames = map ( (<> ".onion")
+                 . Char8.pack
+                 . take 16
+                 . torhash )
+                 torkeys
+
+hasFingerDress :: KeyDB -> SockAddr -> Bool
+hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
+hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
+ where
+    (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
+    g' = map toUpper g
+
+-- We return into IO in case we want to make a signature here.
+setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
+setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
+    -- TODO: we are removing the origin from the UID OriginMap,
+    --       when we should be removing origins from the locations
+    --       field of the sig's MappedPacket records.
+    -- Call getHostnames and compare to see if no-op.
+    if not (pred addr) || names0 == names \\ onions 
+        then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                             , "                   file: "++show (map Char8.unpack names)
+                             , "                   pred: "++show (pred addr)]) -}
+                    (return kd)
+        else do
+    -- We should be sure to remove origins so that the data is written
+    --   (but only if something changed).
+    -- Filter all hostnames present in uids
+    -- Write notations into first uid
+    {-
+    trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                   , "                    file: "++show (map Char8.unpack names) ]) $ do
+    -}
+    return $ KeyData topmp topsigs uids1 subs
+ where
+    topk = packet topmp
+    addr = fingerdress topk
+    names :: [Char8.ByteString]
+    names = Hosts.namesForAddress addr hosts
+    (_,(onions,names0)) = getHostnames kd
+    notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
+    isName (NotationDataPacket True "hostname@" _) = True
+    isName _ = False
+    uids0 = fmap zapIfHasName uids
+    fstuid = head $ do
+        p <- map packet $ flattenAllUids "" True uids
+        guard $ isUserID p
+        return $ uidkey p
+    uids1 = Map.adjust addnames fstuid uids0
+    addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
+     where
+        (ss,ts) = splitAt 1 sigs
+        f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
+                                                       else (sig, tm)
+         where p' = (packet sig) { unhashed_subpackets=uh }
+               uh = unhashed_subpackets (packet sig) ++ notations
+    zapIfHasName (sigs,om) = if or bs then (sigs',om)  -- XXX: removed om=Map.empty to preserve UserID origin
+                                      else (sigs,om)
+     where
+        (bs, sigs') = unzip $ map unhash sigs
+
+        unhash (sig,tm) = ( not (null ns)
+                          , ( sig { packet = p', locations = Map.empty }
+                            , tm ) )
+         where
+            psig = packet sig
+            p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
+                                           else psig
+            uh = unhashed_subpackets psig
+            (ns,ps) = partition isName uh
+
+fingerdress :: Packet -> SockAddr
+fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
+ where
+    zero = SockAddrInet 0 0
+    addr_str = colons $  "fd" ++ drop 10 (map toLower $ fingerprint topk)
+    colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
+    colons xs                 = xs
+
+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
+    case getHostnames contact of
+        (_,(name:_,_)) -> Just $ Char8.unpack name
+        _              -> Nothing