3 files changed, 2400 insertions, 183 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 1aed50e..244f880 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -24,98 +24,7 @@
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE LambdaCase #-}
-module KeyRing
-    (
-    -- * Error Handling
-      KikiResult(..)
-    , KikiCondition(..)
-    , KikiReportAction(..)
-    , errorString
-    , reportString
-    -- * Manipulating Keyrings
-    , runKeyRing
-    , KeyRingOperation(..)
-    , PassphraseSpec(..)
-    , Transform(..)
-    -- , PacketUpdate(..)
-    -- , guardAuthentic
-    -- * Describing File Operations
-    , StreamInfo(..)
-    , Access(..)
-    , FileType(..)
-    , InputFile(..)
-    , Initializer(..)
-    , KeyFilter(..)
-    -- * Results of a KeyRing Operation
-    , KeyRingRuntime(..)
-    , OriginMapped(..)
-    , MappedPacket
-    , KeyDB
-    , KeyData(..)
-    , SubKey(..)
-    , keyflags
-    -- * Miscelaneous Utilities
-    , isKey
-    , isSecretKey
-    , derRSA
-    , derToBase32
-    , backsig
-    , filterMatches
-    , flattenKeys
-    , flattenTop
-    , Hosts.Hosts
-    , isCryptoCoinKey
-    , matchpr
-    , parseSpec
-    , Spec
-    , parseUID
-    , UserIDRecord(..)
-    , pkcs8
-    , RSAPublicKey(..)
-    , PKCS8_RSAPublicKey(..)
-    , rsaKeyFromPacket
-    , secretToPublic
-    , selectPublicKey
-    , selectSecretKey
-    , usage
-    , usageString
-    , walletImportFormat
-    , writePEM
-    , getBindings
-    , accBindings
-    , isSubkeySignature
-    , torhash
-    , torUIDFromKey
-    , ParsedCert(..)
-    , parseCertBlob
-    , packetFromPublicRSAKey
-    , decodeBlob
-    , selectPublicKeyAndSigs
-    , x509cert
-    , getHomeDir
-    , unconditionally
-    , SecretPEMData(..)
-    , readSecretPEMFile
-    , writeInputFileL
-    , InputFileContext(..)
-    , onionNameForContact
-    , keykey
-    , keyPacket
-    , KeySpec(..)
-    , MatchingField(..)
-    , SpecError(..)
-    , SingleKeySpec(..)
-    , parseSpec3
-    , getHostnames
-    , secretPemFromPacket
-    , SubkeyStatus(..)
-    , getSubkeys
-    , writeKeyToFile
-    , resolveForReport
-    , KeyKey -- needed for Type sigs
-    , makeMemoizingDecrypter
-    , showPacket
-    ) where
+module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB)
 
 import System.Environment
 import Control.Monad
@@ -214,6 +123,35 @@ import FunctorToMaybe
 import DotLock
 import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
 import GnuPGAgent as Agent
+import           KeyRing.BuildKeyDB         (accBindings, backsig, buildKeyDB,
+                                             combineTransforms, concatSort,
+                                             derRSA, derToBase32, filterMatches,
+                                             findTag, fingerdress,
+                                             flattenAllUids, flattenKeys,
+                                             flattenSub, flattenTop,
+                                             generateInternals, getBindings,
+                                             getHostnames, getSubkeys,
+                                             importSecretKey, insertSubkey,
+                                             isKey, isSecretKey,
+                                             isSubkeySignature, isUserID,
+                                             keyFlags0, keyPacket, keyflags,
+                                             keykey, mappedPacket, matchSpec,
+                                             matchpr, merge, mergeKeyPacket,
+                                             mkUsage, origin,
+                                             packetFromPublicRSAKey,
+                                             parseCertBlob, parseSingleSpec,
+                                             parseSpec, parseUID,
+                                             performManipulations,
+                                             readInputFileL, readSecretPEMFile,
+                                             resolveForReport, resolveInputFile,
+                                             rsaKeyFromPacket, secp256k1_id,
+                                             secretToPublic, seek_key,
+                                             selectKey0, selectPublicKey,
+                                             showPacket, sortByHint,
+                                             subkeyMappedPacket, torhash, try,
+                                             usage, usageFromFilter,
+                                             usageString)
+
 import Types
 import PacketTranscoder
 import Transforms
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
new file mode 100644
index 0000000..1c2a5aa
--- /dev/null
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -0,0 +1,2275 @@
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE DeriveFunctor            #-}
+{-# LANGUAGE DoAndIfThenElse          #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE PatternGuards            #-}
+{-# LANGUAGE TupleSections            #-}
+{-# LANGUAGE ViewPatterns             #-}
+module KeyRing.BuildKeyDB where
+import qualified Codec.Binary.Base32        as Base32
+import qualified Codec.Binary.Base64        as Base64
+import           Control.Applicative        (liftA2)
+import           Control.Arrow              (first, second)
+import           Control.Exception          (catch)
+import           Control.Monad
+import           ControlMaybe               (handleIO_)
+import           Data.ASN1.BinaryEncoding   (DER (..))
+import           Data.ASN1.Encoding         (decodeASN1, encodeASN1)
+
+import           Data.ASN1.Types            (fromASN1, toASN1)
+import           Data.Binary
+import           Data.Bits                  ((.&.), (.|.))
+import           Data.Bits                  (Bits)
+import qualified Data.ByteString            as S (ByteString, breakSubstring,
+                                                  concat, drop, hGetContents,
+                                                  hPutStr, length, null,
+                                                  readFile, spanEnd, unpack)
+import           Data.ByteString.Lazy       (ByteString)
+import qualified Data.ByteString.Lazy       as L (ByteString, concat, empty,
+                                                  fromChunks, hGetContents,
+                                                  null, readFile, toChunks)
+import           Data.Char
+import           Data.List
+import qualified Data.Map                   as Map
+import           Data.Maybe
+import           Data.Monoid
+import           Data.OpenPGP
+import           Data.OpenPGP.Util          (GenerateKeyParams (..),
+                                             decryptSecretKey, fingerprint,
+                                             generateKey, pgpSign, verify)
+import           Data.Ord
+import           Data.Text.Encoding         (encodeUtf8)
+import           Data.Time.Clock            (UTCTime)
+import           Data.Time.Clock.POSIX      (utcTimeToPOSIXSeconds)
+import           System.Directory           (doesFileExist)
+
+import           System.IO.Error            (isDoesNotExistError)
+import           Text.Show.Pretty           as PP (ppShow)
+#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 qualified Crypto.PubKey.ECC.Types    as ECC
+import           Data.ByteArray             (convert)
+#endif
+import qualified Codec.Compression.GZip     as GZip
+import qualified Crypto.PubKey.RSA          as RSA
+import qualified Data.Text                  as T (break, drop, dropAround,
+                                                  length, pack, reverse, strip,
+                                                  unpack)
+import qualified Data.X509                  as X509
+import           System.Posix.Files         (getFdStatus, getFileStatus,
+                                             modificationTime)
+
+
+import qualified System.Posix.Types         as Posix
+#if MIN_VERSION_x509(1,5,0)
+import           Data.Hourglass
+#endif
+#if MIN_VERSION_unix(2,7,0)
+import           Foreign.C.Types            (CTime (..))
+#else
+import           Foreign.C.Error            (throwErrnoIfMinus1_)
+import           Foreign.C.Types            (CInt (..), CLong, CTime (..))
+import           Foreign.Marshal.Array      (withArray)
+import           Foreign.Ptr
+import           Foreign.Storable
+#endif
+import           Data.IORef
+import           Data.Traversable           (sequenceA)
+import qualified Data.Traversable           as Traversable
+import           System.IO                  (stderr)
+
+import           System.Posix.IO            (fdToHandle)
+#if ! MIN_VERSION_base(4,6,0)
+import           GHC.Exts                   (Down (..))
+#endif
+#if MIN_VERSION_binary(0,7,0)
+#endif
+import           Compat                     ()
+import qualified Data.ByteString.Lazy.Char8 as Char8
+import           Network.Socket
+
+import           Base58
+import qualified CryptoCoins
+import           FunctorToMaybe
+import qualified Hosts
+import           PEM
+import           ScanningParser
+import           TimeUtil
+
+import           KeyRing.Types
+
+-- | buildKeyDB
+--
+--   merge all keyrings, PEM files, and wallets into process memory.
+--
+buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
+              -> IO (KikiCondition (({- db        -} KeyDB
+                                    ,{- grip      -} Maybe String
+                                    ,{- wk        -} Maybe MappedPacket
+                                    ,{- hs        -} ({- hostdbs0 -}[Hosts.Hosts],
+                                                      {- hostdbs  -}[Hosts.Hosts],
+                                                      {- u1       -}Hosts.Hosts,
+                                                      {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
+                                                      {- outgoing_names -}[SockAddr])
+                                    ,{- accs      -} Map.Map InputFile Access
+                                    ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet)
+                                    ,{- unspilled -} Map.Map InputFile Message
+                                    )
+                                   ,{- report_imports -} [(FilePath,KikiReportAction)]))
+buildKeyDB ctx grip0 keyring = do
+    let
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles keyring)
+            guard (istyp $ typ stream)
+            resolveInputFile ctx f
+
+        ringMap0 = Map.filter (isring . typ) $ opFiles keyring
+        (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
+            where
+                isgen (Generate _ _) _ = True
+                isgen _              _ = False
+
+        readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message)
+        readp f stream = fmap readp0 $ readPacketsFromFile ctx f
+         where
+          readp0 ps = (stream { access = acc' }, ps)
+           where acc' = case access stream of
+                            AutoAccess ->
+                                case ps of
+                                    Message ((PublicKeyPacket {}):_) -> Pub
+                                    Message ((SecretKeyPacket {}):_) -> Sec
+                                    _                                -> AutoAccess
+                            acc -> acc
+
+        readw wk n = fmap (n,) (readPacketsFromWallet wk (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
+            --    ring packets with info available for export
+            -- | unspilled
+            --    the rest
+            (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
+
+            -- | keys
+            -- process ringPackets, and get a map of fingerprint info to
+            -- to a packet, remembering it's original file, access.
+            keys :: Map.Map KeyKey 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
+            -- | mwk
+            -- first master key matching the provided grip
+            -- (the m is for "MappedPacket", wk for working key)
+            mwk :: Maybe MappedPacket
+            mwk = 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
+            -- file access(Sec | Pub) lookup table
+            accs :: Map.Map InputFile Access
+            accs = fmap (access . fst) ringPackets
+        return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
+
+    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
+                             }
+    -- autosigns and deletes
+    transformed0 <- do
+        let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
+            trans f (info,ps) = do
+                let manip = combineTransforms (transforms info)
+                    rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
+                    acc = Just Sec /= Map.lookup f accs
+                r <- performManipulations doDecrypt rt1 mwk manip
+                try r $ \(rt2,report) -> do
+                  return $ KikiSuccess (report,rtKeyDB rt2)
+#if MIN_VERSION_containers(0,5,0)
+        fmap sequenceA $ Map.traverseWithKey trans spilled
+#else
+        fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
+#endif
+    try transformed0 $ \transformed -> do
+      let -- | db_rings - all keyrings combined into one
+          db_rings :: Map.Map KeyKey KeyData
+          db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
+                      where
+                        mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData  db dbtrans
+          -- | reportTrans
+          -- events, indexed by file
+          reportTrans :: [(FilePath, KikiReportAction)]
+          reportTrans = concat $ Map.elems $ fmap fst transformed
+
+    -- Wallets
+      let importWalletKey wk db' (top,fname,sub,tag) = do
+              try db' $ \(db',report0) -> do
+                r <- doImportG 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?
+                -- TODO: parseSpec3
+                let (topspec,subspec) = parseSpec grip usage
+                    ms = map fst $ filterMatches topspec (Map.toList db)
+                    cmd = initializer stream
+                return (n,subspec,ms,stream, cmd)
+
+        imports <- filterM (\(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 )
+
+
+resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
+resolveInputFile ctx = resolve
+ where
+    resolve HomeSec     = return (homesecPath ctx)
+    resolve HomePub     = return (homepubPath ctx)
+    resolve (ArgFile f) = return f
+    resolve _           = []
+
+isring :: FileType -> Bool
+isring (KeyRingFile {}) = True
+isring _                = False
+
+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
+
+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
+
+spillable :: StreamInfo -> Bool
+spillable (spill -> KF_None) = False
+spillable _                  = True
+
+isSecretKey :: Packet -> Bool
+isSecretKey (SecretKeyPacket {}) = True
+isSecretKey _                    = False
+
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
+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
+
+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?
+
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+--
+-- matchpr fp = Data.List.Extra.takeEnd (length fp)
+--
+matchpr :: String -> Packet -> String
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+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
+
+-- | combineTransforms
+-- remove rundant transforms, and compile the rest to PacketUpdate(s)
+--
+-- eqivalent to:
+-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd
+combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+combineTransforms trans rt kd = updates
+ where
+    updates = -- kManip operation rt kd ++
+              concatMap (\t -> resolveTransform t rt kd) sanitized
+    sanitized = group (sort trans) >>= take 1
+
+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
+
+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])
+
+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
+
+mergeKeyData :: KeyData -> KeyData -> KeyData
+mergeKeyData (KeyData atop asigs auids asubs)
+             (KeyData btop  bsigs buids bsubs)
+    = KeyData top sigs uids subs
+ where
+    mergeMapped a b =
+        MappedPacket { packet = packet a
+                     , locations = Map.union (locations a) (locations b)
+                     }
+
+    top = mergeMapped atop btop
+
+    sigs = foldl' (flip mergeSig) asigs bsigs
+
+    uids = Map.unionWith mergeUIDSigs auids buids
+    subs = Map.unionWith mergeSub asubs bsubs
+
+    mergeSub :: SubKey -> SubKey -> SubKey
+    mergeSub (SubKey a as) (SubKey b bs) =
+        SubKey (mergeMapped a b)
+               (foldl' (flip mergeSig) as bs)
+
+    mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
+                    -> ([SigAndTrust],OriginMap)
+    mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
+
+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)
+
+mkUsage :: String -> SignatureSubpacket
+mkUsage tag
+  | Just flags <- lookup tag specials =
+    KeyFlagsPacket
+    { certify_keys = fromEnum flags .&. 0x1 /= 0
+    , sign_data = fromEnum flags .&. 0x2 /= 0
+    , encrypt_communication = fromEnum flags .&. 0x4 /= 0
+    , encrypt_storage = fromEnum flags .&. 0x8 /= 0
+    , split_key = False
+    , authentication = False
+    , group_key = False
+    }
+  where
+    flagsets = [Special .. VouchSignEncrypt]
+    specials = map (\f -> (usageString f, f)) flagsets
+
+mkUsage tag = NotationDataPacket
+                { human_readable = True
+                , notation_name = "usage@"
+                , notation_value = tag
+                }
+
+iswallet :: FileType -> Bool
+iswallet (WalletFile {}) = True
+iswallet _               = False
+
+isSecretKeyFile :: FileType -> Bool
+isSecretKeyFile PEMFile         = True
+isSecretKeyFile DNSPresentation = True
+isSecretKeyFile _               = False
+
+usageFromFilter :: MonadPlus m => KeyFilter -> m String
+usageFromFilter (KF_Match usage) = return usage
+usageFromFilter _                = mzero
+
+-- | 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
+
+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)
+
+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,[])
+
+mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
+     -> IO
+          (KikiCondition
+             ( ( Map.Map [Char8.ByteString] KeyData
+               , ( [Hosts.Hosts]
+                 , [Hosts.Hosts]
+                 , Hosts.Hosts
+                 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
+                 , [SockAddr]))
+             , [(FilePath,KikiReportAction)]))
+mergeHostFiles krd db ctx = do
+    let hns = files ishosts
+        ishosts Hosts = True
+        ishosts _     = False
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (istyp $ typ stream)
+            return f
+
+        readInputFileL' ctx f =
+            readInputFileL ctx f
+                `catch` \e -> do when (not $ isDoesNotExistError e) $ do
+                                   return () -- todo report problem
+                                 return L.empty
+
+    hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
+
+    let gpgnames = map getHostnames $ Map.elems db
+        os = do
+            (addr,(ns,_)) <- gpgnames
+            n <- ns
+            return (addr,n)
+        setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
+        -- we ensure .onion names are set properly
+        hostdbs = map setOnions hostdbs0
+        outgoing_names = do
+            (addr,(_,gns)) <- gpgnames
+            guard . not $ null gns
+            guard $ all (null . Hosts.namesForAddress addr) hostdbs0
+            return addr
+    -- putStrLn $ "hostdbs = " ++ show hostdbs
+
+    -- 1. let U = union all the host dbs
+    --     preserving whitespace and comments of the first
+    let u0 = foldl' Hosts.plus Hosts.empty hostdbs
+        -- we filter U to be only finger-dresses
+        u1 = Hosts.filterAddrs (hasFingerDress db) u0
+
+    -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
+    {-
+    putStrLn $ "_  = {\n" ++ show (head hostdbs) ++ "}"
+    putStrLn $ "--> " ++ show (nf (head hostdbs))
+    putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
+    putStrLn $ "--> " ++ show (nf u0)
+    putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
+    putStrLn $ "--> " ++ show (nf u1)
+    -}
+
+    -- 2. replace gpg annotations with those in U
+    -- forM use_db
+    db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
+
+    return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
+
+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
+
+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
+
+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
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> 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
+
+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)
+        }
+
+-- | resolveTransform
+resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
+ where
+    ops = map (\u -> InducerSignature u []) us
+    us = filter torStyle $ Map.keys umap
+    torStyle str = and [ uid_topdomain parsed == "onion"
+                        , uid_realname parsed `elem` ["","Anonymous"]
+                        , uid_user parsed == "root"
+                        , fmap (match . fst) (lookup (packet k) torbindings)
+                            == Just True ]
+      where parsed = parseUID str
+            match =  (==subdom) . take (fromIntegral len)
+            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
+            subdom = Char8.unpack subdom0
+            len = T.length (uid_subdomain parsed)
+            torbindings = getTorKeys (map packet $ flattenTop "" True kd)
+            getTorKeys pub = do
+                xs <- groupBindings pub
+                (_,(top,sub),us,_,_) <- xs
+                guard ("tor" `elem` us)
+                let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
+                return (top,(torhash,sub))
+
+            groupBindings pub = gs
+             where (_,bindings) = getBindings pub
+                   bindings' = accBindings bindings
+                   code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
+                   ownerkey (_,(a,_),_,_,_) = a
+                   sameMaster (ownerkey->a) (ownerkey->b)
+                        = fingerprint_material a==fingerprint_material b
+                   gs = groupBy sameMaster (sortBy (comparing code) bindings')
+
+
+-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
+ where
+    topk = keykey $ packet k -- key to master of key to be deleted
+    subk = do
+        (k,sub) <- Map.toList submap
+        guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
+        return k
+
+-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
+ where
+    topk = keykey $ packet k -- key to master of key to be deleted
+    subk = do
+        (k,SubKey p sigs) <- Map.toList submap
+        take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
+        return k
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
+    mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
+      where
+        update Nothing   = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
+        update (Just kd) = dbInsertPacket kd filename adding
+    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
+
+    whatP (a,_) = concat . take 1 . words . show $ a
+
+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
+
+keyPacket :: KeyData -> Packet
+keyPacket (KeyData k _ _ _) = packet k
+
+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
+
+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]
+
+insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
+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
+
+mappedPacket :: FilePath -> Packet -> MappedPacket
+mappedPacket filename p = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+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 :: Show a => a -> [Char]
+showPacket0 p = concat . take 1 $ words (show p)
+
+mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
+mergeSig sig sigs =
+      let (xs,ys) = break (isSameSig (first packet sig)) sigs
+      in if null ys
+          then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig]
+          else let y:ys'=ys
+               in xs ++ (mergeSameSig sig y : ys')
+     where
+        isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
+            a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
+        isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
+
+        mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
+        mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
+          | isSignaturePacket (packet a) && isSignaturePacket b =
+                ( m { packet = b { unhashed_subpackets =
+                                      union (unhashed_subpackets b) (unhashed_subpackets $ packet a)
+                                 }
+                   , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs }
+                -- TODO: when merging items, we should delete invalidated origins
+                -- from the orgin map.
+                , tb `Map.union` ta )
+
+        mergeSameSig a b = b -- trace ("discarding dup "++show a) b
+
+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"
+
+parseSingleSpec :: String -> SingleKeySpec
+parseSingleSpec "*"              = AnyMatch
+parseSingleSpec "-"              = WorkingKeyMatch
+parseSingleSpec ""               = EmptyMatch
+parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
+parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
+parseSingleSpec ('c':':':tag)    = SubstringMatch (Just GroupIDField) tag
+parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
+parseSingleSpec str
+    | is40digitHex str = FingerprintMatch str
+    | otherwise        = SubstringMatch Nothing str
+
+is40digitHex :: [Char] -> Bool
+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
+
+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
+
+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')
+
+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
+
+-- |
+-- 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
+    topk = packet topmp
+    torkeys = getSubkeys CrossSigned topk subs "tor"
+
+    -- subkeyPacket (SubKey k _ ) = k
+    onames :: [L.ByteString]
+    onames = map ( (<> ".onion")
+                 . Char8.pack
+                 . take 16
+                 . torhash )
+                 torkeys
+
+hasFingerDress :: KeyDB -> SockAddr -> Bool
+hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
+hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
+ where
+    (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
+    g' = map toUpper g
+
+-- We return into IO in case we want to make a signature here.
+setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
+setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
+    -- TODO: we are removing the origin from the UID OriginMap,
+    --       when we should be removing origins from the locations
+    --       field of the sig's MappedPacket records.
+    -- Call getHostnames and compare to see if no-op.
+    if not (pred addr) || gotNonOnions == namesWithoutGotOnions
+        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
+    (_, (gotOnions, gotNonOnions)) = getHostnames kd
+    namesWithoutGotOnions          = names \\ gotOnions
+    notations                      = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions
+    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
+
+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
+            }
+
+-- 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
+-}
+
+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
+
+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
+                              ]
+
+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
+
+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))
+
+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 [])
+
+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)
+
+-- 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)
+
+subkeyMappedPacket :: SubKey -> MappedPacket
+subkeyMappedPacket (SubKey k _ ) = k
+
+has_tag :: String -> Packet -> Bool
+has_tag tag p = isSignaturePacket p
+                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
+                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
+
+dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
+dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
+ where
+    asMapped n p = mappedPacketWithHint filename p n
+    asSigAndTrust n (p,tm) = (asMapped n p,tm)
+
+    -- NOTE:
+    --  if a keyring file has both a public key packet and a secret key packet
+    --  for the same key, then only one of them will survive, which ever is
+    --  later in the file.
+    --
+    --  This is due to the use of statements like
+    --      (Map.insert filename (origin p n) (locations key))
+    --
+    update :: Maybe KeyData -> Maybe KeyData
+    update v | isKey p && not (is_subkey p)
+          = case v of
+             Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
+                     -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
+                                       sigs
+                                       uids
+                                       subkeys
+             _       -> error . concat $ ["Unexpected master key merge error: "
+                                         ,show (fingerprint top, fingerprint p)]
+    update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
+          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
+    update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
+                                    subkeys
+    update (Just (KeyData key sigs uids subkeys))
+          = case sub of
+             MarkerPacket    -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
+             UserIDPacket {} -> Just $ KeyData key
+                                               sigs
+                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               subkeys
+             _  | isKey sub  -> Just $ KeyData key
+                                               sigs
+                                               uids
+                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
+             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
+    update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
+
+    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
+    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
+    mergeSubkey n p (Just (SubKey key sigs)) = Just $
+        SubKey (mergeKeyPacket "subs" key $ asMapped n p)
+               sigs
+
+    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
+    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
+    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
+    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
+
+    whatP (a,_) = concat . take 1 . words . show $ a
+
+
+    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m)
+    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
+
+    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs)
+    mergeSubSig n sig Nothing = error $
+        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
+
+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
+
+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]
+
+usage :: SignatureSubpacket -> Maybe String
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+torhash :: Packet -> String
+torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
+
+keyFlags :: t -> [Packet] -> [SignatureSubpacket]
+keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
+
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
+-- | 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)
+
+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
+          | any isFlagsPacket tags = tags
+          | otherwise =
+            KeyFlagsPacket
+            { certify_keys = False
+            , sign_data = False
+            , encrypt_communication = False
+            , encrypt_storage = False
+            , split_key = False
+            , authentication = True
+            , group_key = False
+            } :
+            tags
+                    -- implicitly added:
+                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
+        isFlagsPacket (KeyFlagsPacket {}) = True
+        isFlagsPacket _                   = False
+        subgrip = fingerprint (head parsedkey)
+    back_sig <-
+      pgpSign
+        (Message parsedkey)
+        (SubkeySignature
+           wk
+           (head parsedkey)
+           (sigpackets 0x19 hashed0 [IssuerPacket subgrip]))
+        (if key_algorithm (head parsedkey) == ECDSA
+           then SHA256
+           else SHA1)
+        subgrip
+    let iss = IssuerPacket (fingerprint wk)
+        cons_iss back_sig =
+          iss : map EmbeddedSignaturePacket (signatures_over back_sig)
+        unhashed0 = maybe [iss] cons_iss back_sig
+    new_sig <-
+      pgpSign
+        (Message [wkun])
+        (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0))
+        SHA1
+        grip
+    let newSig = do
+          r <- addOrigin new_sig
+          return $ fmap (, []) r
+    flip (maybe newSig) mbsig $ \(mp, trustmap) -> do
+      let sig = packet mp
+          isCreation (SignatureCreationTimePacket {}) = True
+          isCreation _                                = False
+          isExpiration (SignatureExpirationTimePacket {}) = True
+          isExpiration _                                  = False
+          (cs, ps) = partition isCreation (hashed_subpackets sig)
+          (es, qs) = partition isExpiration ps
+          stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs
+            where
+              unwrap (SignatureCreationTimePacket x) = x
+          exp = listToMaybe $ sort $ map unwrap es
+            where
+              unwrap (SignatureExpirationTimePacket x) = x
+          expires = liftA2 (+) stamp exp
+      timestamp <- now
+      if fmap ((< timestamp) . fromIntegral) expires == Just True
+        then return $
+             KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature])
+        else do
+          let times =
+                (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $
+                maybeToList $ do
+                  e <- expires
+                  return $
+                    SignatureExpirationTimePacket (e - fromIntegral timestamp)
+              sig' = sig {hashed_subpackets = times ++ (qs `union` tags)}
+          new_sig <-
+            pgpSign
+              (Message [wkun])
+              (SubkeySignature wk (packet subkey_p) [sig'])
+              SHA1
+              (fingerprint wk)
+          newsig <- addOrigin new_sig
+          return $ fmap (, []) newsig
+
+ifSecret :: Packet -> t -> t -> t
+ifSecret (SecretKeyPacket {}) t f = t
+ifSecret _                    t f = f
+
+uidkey :: Packet -> String
+uidkey (UserIDPacket str) = str
+
+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
+
+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
+
+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
+
+spemPacket :: SecretPEMData -> Maybe Packet
+spemPacket (PEMPacket p) = Just p
+spemPacket _             = Nothing
+
+spemCert :: SecretPEMData -> Maybe ParsedCert
+spemCert (PEMCertificate p) = Just p
+spemCert _                  = Nothing
+
+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
+
+getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
+getSubkeys ck topk subs tag = do
+        SubKey k sigs <- Map.elems subs
+        let subk = packet k
+        let sigs' = do
+                -- require tag
+                torsig <- filter (has_tag tag) $ map (packet . fst) sigs
+
+                -- require parent's signature
+                when (ck > Unsigned) $ do
+                    sig <- (signatures $ Message [topk,subk,torsig])
+                    let v = verify (Message [topk]) sig
+                    -- Require parent's signature
+                    guard (not . null $ signatures_over v)
+
+                -- require child's back signature
+                when (ck == CrossSigned ) $ do
+                    let unhashed = unhashed_subpackets torsig
+                        subsigs = mapMaybe backsig unhashed
+                        -- This should consist only of 0x19 values
+                        -- subtypes = map signature_type subsigs
+                    -- subtyp <- subtypes
+                    -- guard (subtyp == 0x19)
+                    sig' <- signatures . Message $ [topk,subk]++subsigs
+                    let v' = verify (Message [subk]) sig'
+                    -- Require subkey's signature
+                    guard . not . null $ signatures_over v'
+                return torsig
+        guard (not $ null sigs')
+        return subk
+
+socketFamily :: SockAddr -> Family
+socketFamily (SockAddrInet _ _) = AF_INET
+socketFamily (SockAddrInet6 {}) = AF_INET6
+socketFamily (SockAddrUnix _)   = AF_UNIX
+
+selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
+
+isBracket :: Char -> Bool
+isBracket '<' = True
+isBracket '>' = True
+isBracket _   = False
+
+unk :: Bool -> MappedPacket -> MappedPacket
+unk isPublic = if isPublic then toPacket secretToPublic else id
+                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
+
+concatSort ::
+  FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
+concatSort fname getp f = concat . sortByHint fname getp . map f
+
+flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
+flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
+
+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
+
+disjoint_fp :: [Packet] -> [[Packet]]
+disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
+ where
+    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
+    samepr a b = smallpr a == smallpr b
+
+    {-
+    -- useful for testing
+    group2 :: [a] -> [[a]]
+    group2 (x:y:ys) = [x,y]:group2 ys
+    group2 [x]      = [[x]]
+    group2 []       = []
+    -}
+
+verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
+verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
+ where
+    verified = do
+        sig <- signatures (Message nonkeys)
+        let v = verify (Message keys) sig
+        guard (not . null $ signatures_over v)
+        return v
+    (top,othersigs) = partition isSubkeySignature verified
+    embedded = do
+        sub <- top
+        let sigover = signatures_over sub
+            unhashed = sigover >>= unhashed_subpackets
+            subsigs = mapMaybe backsig unhashed
+            -- This should consist only of 0x19 values
+            -- subtypes = map signature_type subsigs
+        -- trace ("subtypes = "++show subtypes) (return ())
+        -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
+        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
+        let v = verify (Message [subkey sub]) sig
+        guard (not . null $ signatures_over v)
+        return v
+
+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
+
+-- | 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
+
+parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert
+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
+
+rsaToPGP :: TimeUtil.IsUTC a => a -> RSAPrivateKey -> Packet
+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
+                }
+
+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
+
+backsig :: SignatureSubpacket -> Maybe Packet
+backsig (EmbeddedSignaturePacket s) = Just s
+backsig _                           = Nothing
+
+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
+
+sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
+sortByHint fname f = sortBy (comparing gethint)
+  where
+    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
+    defnum = -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) }
+
+smallpr :: Packet -> [Char]
+smallpr k = drop 24 $ fingerprint k
+
+isSubkeySignature :: SignatureOver -> Bool
+isSubkeySignature (SubkeySignature {}) = True
+isSubkeySignature _                    = False
+
+toStrict :: L.ByteString -> S.ByteString
+toStrict = foldr1 (<>) . L.toChunks
+
+packetFromPublicRSAKey :: UTCTime -> MPI -> MPI -> Packet
+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
+                    }
+
+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
+
+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 _                = ""
+
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index a683a91..27ebbcd 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,50 +1,51 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Kiki where
 
-import Control.Applicative
-import Control.Arrow
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Data.ASN1.BinaryEncoding
-import Data.ASN1.Encoding
-import Data.ASN1.Types
-import Data.Binary
-import Data.Char
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.OpenPGP
-import Data.OpenPGP.Util
-import Data.Ord
-import System.Directory
-import System.FilePath.Posix as FilePath
-import System.IO
-import System.IO.Temp
-import System.IO.Error
-import System.Posix.IO as Posix (createPipe)
-import System.Posix.User
-import System.Process
-import System.Posix.Files
-import qualified Data.Traversable as T (mapM)
+import           Control.Applicative
+import           Control.Arrow
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad
+import           Data.ASN1.BinaryEncoding
+import           Data.ASN1.Encoding
+import           Data.ASN1.Types
+import           Data.Binary
+import           Data.Bool
+import           Data.Char
+import           Data.List
+import           Data.Maybe
+import           Data.Monoid
+import           Data.OpenPGP
+import           Data.OpenPGP.Util
+import           Data.Ord
+import qualified Data.Traversable           as T (mapM)
+import           System.Directory
+import           System.FilePath.Posix      as FilePath
+import           System.IO
+import           System.IO.Error
+import           System.IO.Temp
+import           System.Posix.Files
+import           System.Posix.IO            as Posix (createPipe)
+import           System.Posix.User
+import           System.Process
 #if defined(VERSION_memory)
-import qualified Data.ByteString.Char8 as S8
-import Data.ByteArray.Encoding
+import           Data.ByteArray.Encoding
+import qualified Data.ByteString.Char8      as S8
 #elif defined(VERSION_dataenc)
-import qualified Codec.Binary.Base64 as Base64
+import qualified Codec.Binary.Base64        as Base64
 #endif
-import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy       as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
-import qualified Data.Map.Strict as Map
-import qualified SSHKey as SSH
-import Network.Socket -- (SockAddr)
-import ProcessUtils
+import qualified Data.Map.Strict            as Map
+import           Network.Socket
+import           ProcessUtils
+import qualified SSHKey                     as SSH
 
-import GnuPGAgent (Query(..))
-import CommandLine
-import KeyRing
-import DotLock
+import           CommandLine
+import           DotLock
+import           GnuPGAgent                 (Query (..))
+import           KeyRing
 
 withAgent :: [PassphraseSpec] -> [PassphraseSpec]
 withAgent [] = [PassphraseAgent]
@@ -97,7 +98,7 @@ refresh root homepass = do
                     pth -> Just pth
     case r of
         KikiSuccess rt -> refreshCache rt mroot
-        _ -> return () -- XXX: silent fail?
+        _              -> return () -- XXX: silent fail?
 
 data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
 
@@ -145,15 +146,12 @@ outputReport report = do
 
 importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO ()
 importAndRefresh root cmn cipher = do
-    let rootdir = do guard (root "x" /= "x")
-                     Just $ root ""
-
-    me <- getEffectiveUserID
-
-    let noChrootArg = rootdir == Nothing
-        bUnprivileged = (me/=0) && noChrootArg
-    if rootdir==Just "" then error "--chroot requires an argument" else do
-
+  let rootdir = do guard (root "x" /= "x")
+                   Just $ root ""
+  me <- getEffectiveUserID
+  let noChrootArg = rootdir == Nothing
+      bUnprivileged = (me/=0) && noChrootArg
+  bool id (error "--chroot requires an argument") (rootdir==Just "") $ do
     let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn)
                          (fmap (++"/root/.gnupg") rootdir)
         sshkeygen size = Just $ concat [ "mkdir -p \"$(dirname $file)\" && "
@@ -173,10 +171,7 @@ importAndRefresh root cmn cipher = do
 
     let passfd = cap_passfd cmn
 
-    (torgen,pwds) <-
-     if gotsec
-      then return (Generate 0 $ GenRSA $ 1024 `div` 8, [])
-      else do
+    (torgen,pwds) <- bool id (const $ return (Generate 0 $ GenRSA $ 1024 `div` 8, [])) $ do
         {-  ssh-keygen to create master key...
         let mkpath = home ++ "/master-key"
         mkdirFor mkpath
@@ -255,30 +250,38 @@ importAndRefresh root cmn cipher = do
 
     -- First, we ensure that the tor key exists and is imported
     -- so that we know where to put the strongswan key.
-    let strm = StreamInfo { typ = KeyRingFile
-                          , fill = KF_None
-                          , spill = KF_All
-                          , access = AutoAccess
-                          , initializer = NoCreate
-                          , transforms = [] }
-        buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp
-                                               , fill = rtyp
-                                               , spill = KF_All
-                                               , access = AutoAccess
-                                               , initializer = NoCreate
-                                               , transforms = [] }
+    let strm =
+          StreamInfo
+          { typ = KeyRingFile
+          , fill = KF_None
+          , spill = KF_All
+          , access = AutoAccess
+          , initializer = NoCreate
+          , transforms = []
+          }
+        buildStreamInfo rtyp ftyp =
+          StreamInfo
+          { typ = ftyp
+          , fill = rtyp
+          , spill = KF_All
+          , access = AutoAccess
+          , initializer = NoCreate
+          , transforms = [] }
         peminfo bits usage =
-                  StreamInfo { typ = PEMFile
-                             , fill = KF_None -- KF_Match usage
-                             , spill = KF_Match usage
-                             , access = Sec
-                             , initializer = Internal (GenRSA $ bits `div` 8)
-                             , transforms = []
-                             }
+          StreamInfo
+          { typ = PEMFile
+          , fill = KF_None -- KF_Match usage
+          , spill = KF_Match usage
+          , access = Sec
+          , initializer = Internal (GenRSA $ bits `div` 8)
+          , transforms = []
+          }
         sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
         sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
-        op = KeyRingOperation
-             { opFiles = Map.fromList $
+        op =
+          KeyRingOperation
+          { opFiles =
+              Map.fromList $
                 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
                 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
                 , ( torgen , case torgen of
@@ -295,18 +298,19 @@ importAndRefresh root cmn cipher = do
                 , ( Generate 2 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "encrypt" })
                 , ( Generate 3 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "sign" })
                 ]
-             , opPassphrases = withAgent $ pwds ++ do pfd <- maybeToList passfd
-                                                      return $ PassphraseSpec Nothing Nothing pfd
-             , opHome = homespec
-             , opTransforms = []
-             }
+          , opPassphrases = withAgent $ pwds ++ do pfd <- maybeToList passfd
+                                                   return $ PassphraseSpec Nothing Nothing pfd
+          , opHome = homespec
+          , opTransforms = []
+          }
         -- doNothing = return ()
-        nop = KeyRingOperation
-            { opFiles = Map.empty
-            , opPassphrases = withAgent $ do pfd <- maybeToList passfd
-                                             return $ PassphraseSpec Nothing Nothing pfd
-            , opHome=homespec, opTransforms = []
-            }
+        nop =
+          KeyRingOperation
+          { opFiles = Map.empty
+          , opPassphrases = withAgent $ do pfd <- maybeToList passfd
+                                           return $ PassphraseSpec Nothing Nothing pfd
+          , opHome=homespec, opTransforms = []
+          }
     -- if bUnprivileged then doNothing else mkdirFor torpath
     KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
     outputReport report
@@ -656,16 +660,16 @@ slash ""     ('/':xs) = '/':xs
 slash ""     xs       = '/':xs
 slash (y:ys) xs       = y:slash ys xs
 
-opt_chroot :: Args (FilePath -> FilePath)
-opt_chroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
+dashdashChroot :: Args (FilePath -> FilePath)
+dashdashChroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
 
-opt_homedir :: Args CommonArgsParsed
-opt_homedir = CommonArgsParsed
+dashdashHomedir :: Args CommonArgsParsed
+dashdashHomedir = CommonArgsParsed
                 <$> optional (arg "--homedir")
                 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
 
-opt_cipher :: Args SymmetricAlgorithm
-opt_cipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher")
+dashdashCipher :: Args SymmetricAlgorithm
+dashdashCipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher")
 
 kikiOptions :: ( [(String,Int)], [String] )
 kikiOptions = ( ss, ps )