Refactored build of executable and library.

14 files changed, 5856 insertions, 0 deletions

diff --git a/lib/Base58.hs b/lib/Base58.hs
new file mode 100644
index 0000000..3c1a113
--- /dev/null
+++ b/lib/Base58.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE CPP #-}
+module Base58 where
+
+#if !defined(VERSION_cryptonite)
+import qualified Crypto.Hash.SHA256 as SHA256
+#else
+import Crypto.Hash
+import Data.ByteArray (convert)
+#endif
+import qualified Data.ByteString      as S
+import Data.Maybe
+import Data.List
+import Data.Word ( Word8 )
+import Control.Monad
+
+base58chars :: [Char]
+base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
+
+base58digits :: [Char] -> Maybe [Int]
+base58digits str = sequence mbs
+ where
+    mbs = map (flip elemIndex base58chars) str
+    
+-- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ
+base58_decode :: [Char] -> Maybe (Word8,[Word8])
+base58_decode str = do
+    ds <- base58digits str
+    let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] )
+        rbytes = unfoldr getbyte n
+        getbyte d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 256
+            return (fromIntegral b,q)
+    
+    let (rcksum,rpayload) = splitAt 4 $ rbytes
+        a_payload = reverse rpayload
+#if !defined(VERSION_cryptonite)
+        hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload
+#else
+        hash_result = S.take 4 . convert $ digest
+          where digest = hash (S.pack a_payload) :: Digest SHA256
+#endif
+        expected_hash = S.pack $ reverse rcksum
+        (network_id,payload) = splitAt 1 a_payload
+    
+    network_id <- listToMaybe network_id
+    guard (hash_result==expected_hash)
+    return (network_id,payload)
+
+base58_encode :: S.ByteString -> String
+base58_encode hsh = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits)
+  where
+    zcount = S.length . S.takeWhile (==0) $ hsh
+#if !defined(VERSION_cryptonite)
+    cksum = S.take 4 . SHA256.hash . SHA256.hash $ hsh
+#else
+    cksum = S.take 4 (convert digest2 :: S.ByteString)
+      where digest2 = hash ( convert digest1 :: S.ByteString) :: Digest SHA256
+            digest1 = hash hsh :: Digest SHA256
+#endif
+    n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hsh, cksum]
+    asInteger x = fromIntegral x :: Integer
+    rdigits = unfoldr getdigit n
+     where
+        getdigit d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 58
+            return (fromIntegral b,q)
+
+
diff --git a/lib/Compat.hs b/lib/Compat.hs
new file mode 100644
index 0000000..3b77851
--- /dev/null
+++ b/lib/Compat.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+module Compat where
+
+import Data.Bits
+import Data.Word
+import Data.ASN1.Types
+import Data.ASN1.Encoding
+import Data.ASN1.BinaryEncoding
+import Crypto.PubKey.RSA as RSA
+
+#if defined(VERSION_cryptonite)
+
+instance ASN1Object PublicKey where
+    toASN1 pubKey = \xs -> Start Sequence
+                         : IntVal (public_n pubKey)
+                         : IntVal (public_e pubKey)
+                         : End Sequence
+                         : xs
+    fromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) =
+        Right (PublicKey { public_size = calculate_modulus modulus 1
+                         , public_n    = modulus
+                         , public_e    = pubexp
+                         }
+              , xs)
+        where calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1)
+              -- some bad implementation will not serialize ASN.1 integer properly, leading
+              -- to negative modulus. if that's the case, we correct it.
+              modulus = toPositive smodulus
+    fromASN1 ( Start Sequence
+             : IntVal 0
+             : Start Sequence
+             : OID [1, 2, 840, 113549, 1, 1, 1]
+             : Null
+             : End Sequence
+             : OctetString bs
+             : xs
+             ) = let inner = either strError fromASN1 $ decodeASN1' BER bs
+                     strError = Left .
+                                ("fromASN1: RSA.PublicKey: " ++) . show
+                 in either Left (\(k, _) -> Right (k, xs)) inner
+    fromASN1 _ =
+        Left "fromASN1: RSA.PublicKey: unexpected format"
+
+#endif
+
+toPositive :: Integer -> Integer
+toPositive int
+    | int < 0   = uintOfBytes $ bytesOfInt int
+    | otherwise = int
+  where uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0
+        bytesOfInt :: Integer -> [Word8]
+        bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints
+          where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n)
+                plusOne []     = [1]
+                plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs
+                bytesOfUInt x = reverse (list x)
+                  where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8)
+
diff --git a/lib/ControlMaybe.hs b/lib/ControlMaybe.hs
new file mode 100644
index 0000000..659dab7
--- /dev/null
+++ b/lib/ControlMaybe.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module ControlMaybe where
+
+-- import GHC.IO.Exception (IOException(..))
+import Control.Exception as Exception (IOException(..),catch)
+
+
+withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
+withJust (Just x) f = f x
+withJust Nothing  f = return ()
+
+whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
+whenJust acn f = do
+    x <- acn
+    withJust x f
+
+
+catchIO_ :: IO a -> IO a -> IO a
+catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
+
+catchIO :: IO a -> (IOException -> IO a)  -> IO a
+catchIO body handler = Exception.catch body handler
+
+handleIO_ :: IO a -> IO a -> IO a
+handleIO_ = flip catchIO_
+
+
+handleIO :: (IOException -> IO a) -> IO a -> IO a
+handleIO = flip catchIO
diff --git a/lib/CryptoCoins.hs b/lib/CryptoCoins.hs
new file mode 100644
index 0000000..f417036
--- /dev/null
+++ b/lib/CryptoCoins.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE ViewPatterns #-}
+module CryptoCoins where
+
+import Numeric
+import Data.Word
+import Data.Maybe
+
+data CoinNetwork = CoinNetwork
+    { network_name :: String
+    , public_byte_id :: Word8
+    , private_byte_id :: Word8
+    , source_code_uri :: String
+    }
+ deriving (Show,Read)
+
+-- For forks of bitcoin, grep sources for PUBKEY_ADDRESS
+-- That value + 0x80 will be the private_byte_id.
+-- information source: https://raw.github.com/zamgo/PHPCoinAddress/master/README.md
+coin_networks :: [CoinNetwork]
+coin_networks =
+   [ CoinNetwork "bitcoin"        0x00 0x80 "https://github.com/bitcoin/bitcoin"
+   , CoinNetwork "litecoin"       0x30 0xB0 "https://github.com/litecoin-project/litecoin"
+   , CoinNetwork "peercoin"       0x37 0xB7 "https://github.com/ppcoin/ppcoin" -- AKA: ppcoin
+   , CoinNetwork "namecoin"       0x34 0xB4 "https://github.com/namecoin/namecoin"
+   , CoinNetwork "bbqcoin"        0x05 0xD5 "https://github.com/overware/BBQCoin"
+   , CoinNetwork "bitbar"         0x19 0x99 "https://github.com/aLQ/bitbar"
+   , CoinNetwork "bytecoin"       0x12 0x80 "https://github.com/bryan-mills/bytecoin"
+   , CoinNetwork "chncoin"        0x1C 0x9C "https://github.com/CHNCoin/CHNCoin"
+   , CoinNetwork "devcoin"        0x00 0x80 "http://sourceforge.net/projects/galacticmilieu/files/DeVCoin"
+   , CoinNetwork "feathercoin"    0x0E 0x8E "https://github.com/FeatherCoin/FeatherCoin"
+   , CoinNetwork "freicoin"       0x00 0x80 "https://github.com/freicoin/freicoin"
+   , CoinNetwork "junkcoin"       0x10 0x90 "https://github.com/js2082/JKC"
+   , CoinNetwork "mincoin"        0x32 0xB2 "https://github.com/SandyCohen/mincoin"
+   , CoinNetwork "novacoin"       0x08 0x88 "https://github.com/CryptoManiac/novacoin"
+   , CoinNetwork "onecoin"        0x73 0xF3 "https://github.com/cre8r/onecoin"
+   , CoinNetwork "smallchange"    0x3E 0xBE "https://github.com/bfroemel/smallchange"
+   , CoinNetwork "terracoin"      0x00 0x80 "https://github.com/terracoin/terracoin"
+   , CoinNetwork "yacoin"         0x4D 0xCD "https://github.com/pocopoco/yacoin"
+   , CoinNetwork "bitcoin-t"      0x6F 0xEF ""
+   , CoinNetwork "bbqcoin-t"      0x19 0x99 ""
+   , CoinNetwork "bitbar-t"       0x73 0xF3 ""
+   ]
+   -- fairbrix          -    - https://github.com/coblee/Fairbrix
+   -- ixcoin            -    - https://github.com/ixcoin/ixcoin
+   -- royalcoin         -    - http://sourceforge.net/projects/royalcoin/
+
+lookupNetwork :: Eq a => (CoinNetwork -> a) -> a -> Maybe CoinNetwork
+lookupNetwork f b = listToMaybe $ filter (\n->f n==b) coin_networks
+
+nameFromSecretByte :: Word8 -> String
+nameFromSecretByte b = maybe (defaultName b) network_name (lookupNetwork private_byte_id b)
+ where
+    defaultName b = "?coin?"++hexit b
+      where
+        hexit b = pad0 $ showHex b "" 
+            where pad0 [c] = '0':c:[]
+                  pad0 cs  = take 2 cs
+
+publicByteFromName :: String -> Word8
+publicByteFromName n = maybe (secretByteFromName n - 0x80) 
+                             -- exceptions to the above: bbqcoin, bytecoin
+                             public_byte_id
+                             (lookupNetwork network_name n)
+
+secretByteFromName :: String -> Word8
+secretByteFromName n = maybe (defaultID n) private_byte_id (lookupNetwork network_name n)
+ where
+    defaultID ('?':'c':'o':'i':'n':'?':(readHex->((x,_):_))) 
+                = x
+    defaultID _ = 0x00
diff --git a/lib/DotLock.hs b/lib/DotLock.hs
new file mode 100644
index 0000000..af05f5d
--- /dev/null
+++ b/lib/DotLock.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module DotLock 
+    ( DotLock
+    , Flags
+    , dotlock_init
+    , dotlock_create
+    , dotlock_take
+    , dotlock_release
+    , dotlock_destroy
+    , dotlock_remove_lockfiles
+    , dotlock_set_fd
+    , dotlock_get_fd
+    , dotlock_disable
+    ) where
+
+import System.Posix.Types (Fd(..))
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.Ptr
+
+newtype DotLock = DotLockPtr (Ptr ())
+type Flags = Int
+
+foreign import ccall "dotlock_create" _dotlock_create_ptr :: Ptr Char -> Flags -> IO (Ptr ())
+
+foreign import ccall "dotlock_create" _dotlock_create :: CString -> Flags -> IO (Ptr ())
+
+dotlock_init :: IO ()
+dotlock_init = do
+    null_ptr <- _dotlock_create_ptr nullPtr 0
+    return ()
+
+dotlock_create :: FilePath -> Flags -> IO (Maybe DotLock)
+dotlock_create file flags = do
+    ptr <- withCString file (flip _dotlock_create flags)
+    if ptr == nullPtr then return Nothing else return (Just $ DotLockPtr ptr)
+      
+
+foreign import ccall "dotlock_take" dotlock_take :: DotLock -> CLong -> IO CInt
+foreign import ccall "dotlock_release" dotlock_release :: DotLock -> IO CInt
+foreign import ccall "dotlock_destroy" dotlock_destroy :: DotLock -> IO ()
+foreign import ccall "dotlock_remove_lockfiles" dotlock_remove_lockfiles ::DotLock -> IO ()
+foreign import ccall "dotlock_set_fd" dotlock_set_fd :: DotLock -> Fd -> IO ()
+foreign import ccall "dotlock_get_fd" dotlock_get_fd :: DotLock -> IO Fd
+foreign import ccall "dotlock_disable" dotlock_disable :: IO ()
diff --git a/lib/FunctorToMaybe.hs b/lib/FunctorToMaybe.hs
new file mode 100644
index 0000000..658b024
--- /dev/null
+++ b/lib/FunctorToMaybe.hs
@@ -0,0 +1,69 @@
+---------------------------------------------------------------------------
+-- |
+-- Module      :  FunctorToMaybe
+--
+-- Maintainer  :  joe@jerkface.net
+-- Stability   :  experimental
+--
+-- Motivation: When parsing a stream of events, it is often desirable to
+-- let certain control events pass-through to the output stream without
+-- interrupting the parse.  For example, the conduit package uses 
+-- <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- which adds a special command to a stream and the blaze-builder-conduit 
+-- package has <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#g:2 conduits> that treat the nullary constructor with special significance.
+--
+-- But for other intermediary conduits, the nullary @Flush@ constructor may 
+-- be noise that they should politely preserve in case it is meaningul downstream.
+-- If <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to
+-- seperate the noise from the work-product.
+--
+{-# LANGUAGE CPP #-}
+module FunctorToMaybe where
+
+#if MIN_VERSION_base(4,6,0)
+#else
+import Control.Monad.Instances()
+#endif
+
+-- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the
+-- there may be multiple null elements. 
+--
+-- Instances of 'FunctorToMaybe' should satisfy the following laws:
+--
+-- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g)
+--
+class Functor g => FunctorToMaybe g where
+    functorToMaybe :: g a -> Maybe a
+
+
+instance FunctorToMaybe Maybe where
+    functorToMaybe = id
+instance FunctorToMaybe (Either a) where
+    functorToMaybe (Right x) = Just x
+    functorToMaybe _         = Nothing
+
+
+-- | 'functorToEither' is a null-preserving cast.
+--
+-- If @functorToMaybe g == Nothing@, then a casted value is returned with Left.
+-- If @functorToMaybe g == Just a@, then @Right a@ is returned.
+--
+-- Returning to our <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- example, if we define
+--
+-- > instance Flush where 
+-- >   functorToMaybe Flush     = Nothing
+-- >   functorToMaybe (Chunk a) = Just a
+--
+-- Now stream processors can use 'functorToEither' to transform any nullary constructors while
+-- while doing its work to transform the data before forwarding it into 
+-- <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#v:builderToByteStringFlush builderToByteStringFlush>.
+--
+functorToEither :: FunctorToMaybe f => f a -> Either (f b) a
+functorToEither ga =
+    maybe (Left $ uncast ga)
+          Right
+          (functorToMaybe ga)
+ where
+    uncast = fmap (error "bad FunctorToMaybe instance")
diff --git a/lib/Hosts.hs b/lib/Hosts.hs
new file mode 100644
index 0000000..5f09de1
--- /dev/null
+++ b/lib/Hosts.hs
@@ -0,0 +1,314 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings   #-}
+#if ! MIN_VERSION_network(2,4,0)
+{-# LANGUAGE StandaloneDeriving  #-}
+#endif
+module Hosts
+    ( Hosts
+    , assignName
+    , assignName'
+    , assignNewName
+    , removeName
+    , inet_pton
+    , inet_ntop 
+    , empty
+    , hasName
+    , hasAddr
+    , encode
+    , decode
+    , diff
+    , plus
+    , filterAddrs
+    , namesForAddress
+    ) where
+
+import Data.Maybe
+import Data.Monoid ( (<>) )
+import Data.List as List (foldl', (\\) )
+import Data.Ord
+import Data.Char (isSpace)
+import qualified Data.Map as Map
+import           Data.Map (Map)
+import qualified Data.ByteString.Lazy.Char8 as L
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Applicative ( (<$>), (<*>) )
+import Control.Monad (mplus)
+import Network.Socket
+import ControlMaybe ( handleIO_ )
+
+#if ! MIN_VERSION_network(2,4,0)
+deriving instance Ord SockAddr
+#endif
+
+inet_pton :: String -> Maybe SockAddr
+inet_pton p = n
+ where
+    n = unsafePerformIO $ do
+            handleIO_ (return Nothing) $ do
+            info <- getAddrInfo safe_hints (Just p) Nothing
+            return $ fmap addrAddress $ listToMaybe info
+    safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] }
+
+inet_ntop :: SockAddr -> String
+inet_ntop n = p
+ where
+    p = case show n of
+            '[':xs ->  fst $ break (==']') xs
+            xs     ->  fst $ break (==':') xs
+
+
+data Hosts = Hosts
+    { lineCount :: Int
+    , numline :: Map Int L.ByteString
+    , namenum :: Map L.ByteString [Int]
+    , addrnum :: Map SockAddr Int
+    }
+
+instance Show Hosts where
+    show = L.unpack . encode
+
+encode :: Hosts -> L.ByteString
+encode = L.unlines . map snd . Map.assocs . numline
+
+parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString])
+parseLine s = (addr,names)
+ where
+    (addr0,names) = splitAt 1 $ L.words (uncom s)
+    addr = do
+        a <- fmap L.unpack $ listToMaybe addr0
+        n <- inet_pton a
+        return $ n -- inet_ntop n
+        
+    uncom s = fst $ L.break (=='#') s
+
+empty :: Hosts
+empty = Hosts { lineCount = 0
+              , numline = Map.empty
+              , addrnum = Map.empty
+              , namenum = Map.empty
+              } 
+
+{-
+parseHosts fname = do
+    input <- L.readFile fname
+    return $ decode input
+-}
+
+decode :: L.ByteString -> Hosts
+decode input = 
+    let ls = L.lines input
+        ans = map (\l->(parseLine l,l)) ls
+        hosts = foldl' upd empty ans
+        upd hosts ((addr,names),line) = hosts
+            { lineCount = count
+            , numline = Map.insert count line (numline hosts)
+            , addrnum = maybeInsert (addrnum hosts) addr
+            , namenum = foldl' (\m x->Map.alter (cons count) x m)
+                               (namenum hosts)
+                               names
+            }
+          where count = lineCount hosts + 1
+                cons v xs = Just $ maybe [v] (v:) xs
+                maybeInsert m x = maybe m
+                                        (\x->Map.insert x count m)
+                                        x
+    in hosts
+
+
+hasName :: L.ByteString -> Hosts -> Bool
+hasName name hosts = Map.member name $ namenum hosts
+
+hasAddr :: SockAddr -> Hosts -> Bool
+hasAddr addr hosts = Map.member addr $ addrnum hosts
+
+scrubName ::
+  ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString
+scrubName f line = line'
+ where
+    (x,ign) = L.break (=='#') line
+    ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
+                        where oo = (.) . (.)
+    (a,ws') = splitAt 2 ws
+    ws'' = f ws'
+    line' = if null ws'' 
+                then if length a==2 then "" -- "# " <> L.concat a <> ign
+                                    else line
+                else if length a==2 
+                    then L.concat (a ++ ws'') <> ign
+                    else let vs  = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace
+                                                                              $ L.tail ign
+                                                 where oo = (.) . (.)
+                             (a',vs') = splitAt 2 vs
+                             vs'' = L.concat vs'
+                             vs''' = if L.take 1 vs'' `elem` ["#",""] 
+                                        then vs''
+                                        else "# " <> vs''
+                         in L.concat (a'++ws'') <> vs'''
+
+assignName :: SockAddr -> L.ByteString -> Hosts -> Hosts
+assignName addr name hosts = assignName' False addr name hosts
+
+chaddr :: Int -> SockAddr -> Hosts -> Hosts
+chaddr n addr hosts =
+    hosts { addrnum = Map.insert addr n (addrnum hosts)
+          , numline = Map.adjust re n (numline hosts) }
+ where
+    re line = if length a==2
+                then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign
+                else line
+        where (x,ign) = L.break (=='#') line
+              ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
+                                  where oo = (.) . (.)
+              (a,ws') = splitAt 2 ws
+
+isLonerName line = length ws' <= 2
+        where (x,_) = L.break (=='#') line
+              ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
+                                  where oo = (.) . (.)
+              (_,ws') = splitAt 2 ws
+
+scrubTrailingEmpties :: Hosts -> Hosts
+scrubTrailingEmpties hosts =
+    hosts { lineCount = cnt'
+          , numline = foldl' (flip Map.delete) (numline hosts) es
+          }
+ where
+    cnt = lineCount hosts
+    es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "")
+            $ [cnt,cnt-1..]
+    cnt' = cnt - length es
+
+cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString
+cannonizeName name line = scrubName f line
+ where
+    f ws = [name," "] ++ pre ++ drop 2 rst
+      where
+        (pre,rst) = break (==name) ws
+
+removeName name hosts = hosts'
+ where
+    hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns)
+    ns = Map.lookup name (namenum hosts) 
+
+        
+removeName0 name hosts nums = hosts 
+    { namenum = Map.delete name (namenum hosts)
+    , numline = foldl' scrub (numline hosts) nums
+    }
+    where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m
+
+assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts
+assignName' iscannon addr name hosts = hosts'
+ where
+    ns = Map.lookup name (namenum hosts) 
+    a = Map.lookup addr (addrnum hosts)
+    canonize numline n = Map.adjust (cannonizeName name) n numline
+    hosts' = do
+        if (== Just True) $ elem <$> a <*> ns
+         then if not iscannon then hosts -- address already has name, nothing to do
+                              else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns}
+         else 
+            let hosts0 = -- remove name if it's present
+                         scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns
+                ns' = fmap (filter $
+                                isLonerName
+                                . fromJust
+                                . (\n -> Map.lookup n (numline hosts)))
+                            ns
+                        >>= listToMaybe
+                hosts1 = -- insert name, or add new line
+                         maybe (maybe (newLine hosts0)
+                                      (\n -> chaddr n addr $ appendName iscannon name hosts0 n)
+                                      ns')
+                               (appendName iscannon name hosts0)
+                               a
+            in hosts1
+    newLine hosts = hosts
+        { lineCount = cnt
+        , numline = Map.insert cnt line $ numline hosts
+        , addrnum = Map.insert addr cnt $ addrnum hosts
+        , namenum = Map.alter (cons cnt) name $ namenum hosts
+        }
+        where cnt = lineCount hosts + 1
+              line = L.pack (inet_ntop addr) <> " " <> name
+              cons v xs = Just $ maybe [v] (v:) xs
+
+assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts
+assignNewName addr name hosts = 
+    if hasName name hosts then hosts
+                          else assignName' True addr name hosts
+
+appendName :: Bool -> L.ByteString -> Hosts -> Int -> Hosts
+appendName iscannon name hosts num = hosts
+        { numline = Map.adjust (scrubName f) num (numline hosts)
+        , namenum = Map.alter (cons num) name (namenum hosts)
+        }
+        where f ws = if iscannon 
+                      then [name, " "] ++ ws
+                      else let rs       = reverse ws
+                               (sp,rs') = span (L.any isSpace) rs
+                           in reverse $ sp ++ [name," "] ++ rs'
+              cons v xs = Just $ maybe [v] (v:) xs
+
+-- Returns a list of bytestrings intended to show the
+-- differences between the two host databases.  It is
+-- assumed that no lines are deleted, only altered or
+-- appended.
+diff :: Hosts -> Hosts -> [L.ByteString]
+diff as bs = cs
+ where
+    [as',bs'] = map (L.lines . Hosts.encode) [as,bs]
+    ext xs = map Just xs ++ repeat Nothing
+    ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs')
+    es = filter (uncurry (/=)) ds
+    cs = do
+        (a,b) <- es
+        [a,b] <- return $ map maybeToList [a,b]
+        fmap ("- " <>) a ++ fmap ("+ " <>) b
+
+namesForAddress :: SockAddr -> Hosts -> [L.ByteString]
+namesForAddress addr hosts = snd $ _namesForAddress addr hosts
+
+_namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString])
+_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns
+ where
+    ns = maybe (-1,[]) id $ do
+        n <- Map.lookup addr addrnum
+        line <- Map.lookup n numline
+        return (n, snd $ parseLine line)
+
+
+plus :: Hosts -> Hosts -> Hosts
+plus a b = Map.foldlWithKey' mergeAddr a (addrnum b)
+ where
+    mergeAddr a addr bnum = a'
+     where
+        (anum,ns) = _namesForAddress addr a
+        bs = maybe [] (List.\\ ns) $ do
+                 line <- Map.lookup bnum (numline b)
+                 return . snd $ parseLine line
+        a' = if anum/=(-1) then foldl' app a $ reverse bs
+                           else newLine a
+        app a b = appendName True b a anum -- True to allow b to reassign cannonical name
+        newLine hosts = hosts
+            { lineCount = cnt
+            , numline = Map.insert cnt line $ numline hosts
+            , addrnum = Map.insert addr cnt $ addrnum hosts
+            , namenum = foldl' updnamenum (namenum hosts) bs
+            }
+            where cnt = lineCount hosts + 1
+                  line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs
+                  cons v xs = Just $ maybe [v] (v:) xs
+                  updnamenum m name = Map.alter (cons cnt) name m
+
+filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts
+filterAddrs pred hosts = hosts'
+ where
+    als = Map.toList (addrnum hosts)
+    nl  = foldl' f (numline hosts) als
+    f m (addr,num) = if pred addr
+                        then m
+                        else Map.adjust (scrubName $ const []) num m
+    lines = L.unlines . Map.elems $ nl
+    hosts' = decode lines
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
new file mode 100644
index 0000000..0fbf2c2
--- /dev/null
+++ b/lib/KeyRing.hs
@@ -0,0 +1,3505 @@
+---------------------------------------------------------------------------
+-- |
+-- Module      :  KeyRing
+--
+-- Maintainer  :  joe@jerkface.net
+-- Stability   :  experimental
+--
+-- kiki is a command-line utility for manipulating GnuPG's keyring files.  This
+-- module is the programmer-facing API it uses to do that.
+--
+-- Note: This is *not* a public facing API. I (the author) consider this
+-- library to be internal to kiki and subject to change at my whim.
+--
+-- Typically, a client to this module would prepare a 'KeyRingOperation'
+-- describing what he wants done, and then invoke 'runKeyRing' to make it
+-- happen.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE NoPatternGuards #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+module KeyRing
+    (
+    -- * Error Handling
+      KikiResult(..)
+    , KikiCondition(..)
+    , KikiReportAction(..)
+    , errorString
+    , reportString
+    -- * Manipulating Keyrings
+    , runKeyRing
+    , KeyRingOperation(..)
+    , PassphraseSpec(..)
+    , Transform(..)
+    -- , PacketUpdate(..)
+    -- , guardAuthentic
+    -- * Describing File Operations
+    , StreamInfo(..)
+    , Access(..)
+    , FileType(..)
+    , InputFile(..)
+    , KeyFilter(..)
+    -- * Results of a KeyRing Operation
+    , KeyRingRuntime(..)
+    , MappedPacket(..)
+    , KeyDB
+    , KeyData(..)
+    , SubKey(..)
+    , packet
+    , locations
+    , keyflags
+    -- * Miscelaneous Utilities
+    , isKey
+    , derRSA
+    , derToBase32
+    , backsig
+    , filterMatches
+    , flattenKeys
+    , flattenTop
+    , Hosts.Hosts
+    , isCryptoCoinKey
+    , matchpr
+    , parseSpec
+    , parseUID
+    , UserIDRecord(..)
+    , pkcs8
+    , RSAPublicKey(..)
+    , PKCS8_RSAPublicKey(..)
+    , rsaKeyFromPacket
+    , secretToPublic
+    , selectPublicKey
+    , selectSecretKey
+    , usage
+    , usageString
+    , walletImportFormat
+    , writePEM
+    , getBindings
+    , accBindings
+    , isSubkeySignature
+    , torhash
+    , ParsedCert(..)
+    , parseCertBlob
+    , packetFromPublicRSAKey
+    , decodeBlob
+    , selectPublicKeyAndSigs
+    , x509cert
+    , getHomeDir
+    , unconditionally
+    , SecretPEMData(..)
+    , readSecretPEMFile
+    , writeInputFileL
+    , InputFileContext(..)
+    , onionNameForContact
+    , keykey
+    , keyPacket
+    , KeySpec(..)
+    , getHostnames
+    , secretPemFromPacket
+    , getCrossSignedSubkeys
+    ) where
+
+import System.Environment
+import Control.Monad
+import Data.Maybe
+import Data.Either
+import Data.Char
+import Data.Ord
+import Data.List
+import Data.OpenPGP
+import Data.Functor
+import Data.Monoid
+import Data.Tuple             ( swap )
+import Data.Bits              ( (.|.), (.&.) )
+import Control.Applicative    ( Applicative, pure, liftA2, (<*>) )
+import System.Directory       ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
+import Control.Arrow          ( first, second )
+import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
+import Data.ByteString.Lazy   ( ByteString )
+import Text.Show.Pretty as PP ( ppShow )
+import Data.Binary {- decode, decodeOrFail -}
+import ControlMaybe ( handleIO_ )
+import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
+       , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
+import Data.ASN1.BitArray ( BitArray(..), toBitArray )
+import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
+import Data.ASN1.BinaryEncoding ( DER(..) )
+import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
+import Data.Time.Clock ( UTCTime )
+import Data.Bits ( Bits, shiftR )
+import Data.Text.Encoding ( encodeUtf8 )
+import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
+        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
+        , index, break, pack )
+import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse )
+import qualified Codec.Binary.Base32 as Base32
+import qualified Codec.Binary.Base64 as Base64
+#if !defined(VERSION_cryptonite)
+import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Crypto.Types.PubKey.ECC as ECC
+#else
+import qualified Crypto.Hash as Vincent
+import Data.ByteArray (convert)
+import qualified Crypto.PubKey.ECC.Types as ECC
+#endif
+import qualified Data.X509 as X509
+import qualified Crypto.PubKey.RSA as RSA
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.Text as T ( Text, unpack, pack,
+        strip, reverse, drop, break, dropAround, length )
+import qualified System.Posix.Types as Posix
+import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
+        , setFileCreationMask, setFileTimes )
+#if MIN_VERSION_x509(1,5,0)
+import Data.Hourglass.Types
+import Data.Hourglass
+#endif
+#if MIN_VERSION_unix(2,7,0)
+import System.Posix.Files ( setFdTimesHiRes )
+import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
+#else
+import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
+import Foreign.Marshal.Array ( withArray )
+import Foreign.Ptr
+import Foreign.C.Error ( throwErrnoIfMinus1_ )
+import Foreign.Storable
+#endif
+import System.FilePath ( takeDirectory )
+import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
+import Data.IORef
+import System.Posix.IO ( fdToHandle )
+import qualified Data.Traversable as Traversable
+import Data.Traversable ( sequenceA )
+#if ! MIN_VERSION_base(4,6,0)
+import GHC.Exts ( Down(..) )
+#endif
+#if MIN_VERSION_binary(0,7,0)
+import Debug.Trace
+#endif
+import Network.Socket -- (SockAddr)
+import qualified Data.ByteString.Lazy.Char8 as Char8
+import Compat
+
+import TimeUtil
+import PEM
+import ScanningParser
+import qualified Hosts
+import qualified CryptoCoins
+import Base58
+import FunctorToMaybe
+import DotLock
+import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
+
+-- DER-encoded elliptic curve ids
+-- nistp256_id  = 0x2a8648ce3d030107
+secp256k1_id :: Integer
+secp256k1_id = 0x2b8104000a
+-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
+{-     OID                  Curve description              Curve name
+    ----------------------------------------------------------------   
+    1.2.840.10045.3.1.7  NIST Curve P-256 [FIPS 186-2]  "NIST P-256"
+    1.3.132.0.34         NIST Curve P-384 [FIPS 186-2]  "NIST P-384"  
+    1.3.132.0.35         NIST Curve P-521 [FIPS 186-2]  "NIST P-521"  
+
+    Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
+    P-521".  The hexadecimal representation used in the public and
+    private key encodings are:
+
+    Curve Name   Len  Hexadecimal representation of the OID
+    ----------------------------------------------------------------   
+    "NIST P-256"  8   0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 
+    "NIST P-384"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x22            
+    "NIST P-521"  6   0x05, 0x2B, 0x81, 0x04, 0x00, 0x23          
+-}
+
+data HomeDir =
+    HomeDir { homevar :: String
+            , appdir :: String
+            , optfile_alts :: [String]
+            }
+
+home :: HomeDir
+home = HomeDir
+    { homevar = "GNUPGHOME"
+    , appdir  = ".gnupg"
+    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
+    }
+
+data InputFile = HomeSec
+               -- ^ A file named secring.gpg located in the home directory.
+               -- See 'opHome'.
+               | HomePub
+               -- ^ A file named pubring.gpg located in the home directory.
+               -- See 'opHome'.
+               | ArgFile FilePath
+               -- ^ Contents will be read or written from the specified path.
+               | FileDesc Posix.Fd
+               -- ^ Contents will be read or written from the specified file
+               -- descriptor.
+               | Pipe Posix.Fd Posix.Fd
+               -- ^ Contents will be read from the first descriptor and updated
+               -- content will be writen to the second. Note: Don't use Pipe
+               -- for 'Wallet' files. (TODO: Wallet support)
+ deriving (Eq,Ord,Show)
+
+-- type UsageTag = String
+type Initializer = String
+
+data FileType = KeyRingFile
+              | PEMFile
+              | WalletFile
+              | DNSPresentation
+              | Hosts
+ deriving (Eq,Ord,Enum,Show)
+
+-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
+-- to contain secret or public PGP key packets.  Note that it is not supported
+-- to mix both in the same file and that the secret key packets include all of
+-- the information contained in their corresponding public key packets.
+data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
+                         --   (see 'rtRingAccess')
+            | Sec        -- ^ secret information
+            | Pub        -- ^ public information
+ deriving (Eq,Ord,Show)
+
+-- | Note that the documentation here is intended for when this value is
+-- assigned to 'fill'.  For other usage, see 'spill'.
+data KeyFilter = KF_None -- ^ No keys will be imported.
+               | KF_Match String -- ^ Only the key that matches the spec will be imported.
+               | KF_Subkeys   -- ^ Subkeys will be imported if their owner key is
+                              -- already in the ring.  TODO: Even if their signatures
+                              -- are bad?
+               | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
+                              -- identity (signed or self-authenticating).
+               | KF_All -- ^ All keys will be imported.
+  deriving (Eq,Ord,Show)
+
+-- | This type describes how 'runKeyRing' will treat a file.
+data StreamInfo = StreamInfo
+    { access :: Access
+    -- ^ Indicates whether the file is allowed to contain secret information.
+    , typ :: FileType
+    -- ^ Indicates the format and content type of the file.
+    , fill :: KeyFilter
+    -- ^ This filter controls what packets will be inserted into a file.
+    , spill :: KeyFilter
+    --
+    -- ^ Use this to indicate whether or not a file's contents should be
+    -- available for updating other files.  Note that although its type is
+    -- 'KeyFilter', it is usually interpretted as a boolean flag.  Details
+    -- depend on 'typ' and are as follows:
+    --
+    -- 'KeyRingFile':
+    --
+    --  * 'KF_None' - The file's contents will not be shared.
+    --
+    --  * otherwise - The file's contents will be shared.
+    --
+    -- 'PEMFile':
+    --
+    --  * 'KF_None'  - The file's contents will not be shared.
+    --
+    --  * 'KF_Match' - The file's key will be shared with the specified owner
+    --  key and usage tag.  If 'fill' is also a 'KF_Match', then it must be
+    --  equal to this value; changing the usage or owner of a key is not
+    --  supported via the fill/spill mechanism.
+    --
+    --  * otherwise  - Unspecified.  Do not use.
+    --
+    -- 'WalletFile':
+    --
+    --  * The 'spill' setting is ignored and the file's contents are shared.
+    --  (TODO)
+    --
+    -- 'Hosts': 
+    --
+    --  * The 'spill' setting is ignored and the file's contents are shared.
+    --  (TODO)
+    --
+    , initializer :: Maybe String
+    -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is
+    -- interpretted as a shell command that may be used to create the key if it
+    -- does not exist.
+    , transforms :: [Transform] 
+    -- ^ Per-file transformations that occur before the contents of a file are
+    -- spilled into the common pool.
+    }
+ deriving (Eq,Show)
+
+
+spillable :: StreamInfo -> Bool
+spillable (spill -> KF_None) = False
+spillable _                  = True
+
+isMutable :: StreamInfo -> Bool
+isMutable (fill -> KF_None) = False
+isMutable _                 = True
+
+isring :: FileType -> Bool
+isring (KeyRingFile {}) = True
+isring _                = False
+
+isSecretKeyFile :: FileType -> Bool
+isSecretKeyFile PEMFile         = True
+isSecretKeyFile DNSPresentation = True
+isSecretKeyFile _               = False
+
+{-
+pwfile :: FileType -> Maybe InputFile
+pwfile (KeyRingFile f) = f
+pwfile _               = Nothing
+-}
+
+iswallet :: FileType -> Bool
+iswallet (WalletFile {}) = True
+iswallet _               = False
+
+usageFromFilter :: MonadPlus m => KeyFilter -> m String
+usageFromFilter (KF_Match usage) = return usage
+usageFromFilter _                = mzero
+
+data KeyRingRuntime = KeyRingRuntime
+                        { rtPubring :: FilePath
+                        -- ^ Path to the file represented by 'HomePub'
+                        , rtSecring :: FilePath
+                        -- ^ Path to the file represented by 'HomeSec'
+                        , rtGrip :: Maybe String
+                        -- ^ Fingerprint or portion of a fingerprint used
+                        -- to identify the working GnuPG identity used to
+                        -- make signatures.
+                        , rtWorkingKey :: Maybe Packet
+                        -- ^ The master key of the working GnuPG identity.
+                        , rtKeyDB :: KeyDB
+                        -- ^ The common information pool where files spilled
+                        -- their content and from which they received new
+                        -- content.
+                        , rtRingAccess :: Map.Map InputFile Access
+                        -- ^ The 'Access' values used for files of type
+                        -- 'KeyRingFile'.  If 'AutoAccess' was specified
+                        -- for a file, this 'Map.Map' will indicate the
+                        -- detected value that was used by the algorithm.
+                        , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet)
+                        }
+
+-- | Roster-entry level actions
+data PacketUpdate = InducerSignature String [SignatureSubpacket]
+                  | SubKeyDeletion KeyKey KeyKey
+
+-- | This type is used to indicate where to obtain passphrases.
+data PassphraseSpec = PassphraseSpec
+    { passSpecRingFile :: Maybe FilePath
+    -- ^ If not Nothing, the passphrase is to be used for packets
+    -- from this file.
+    , passSpecKeySpec :: Maybe String
+    -- ^ Non-Nothing value reserved for future use.
+    -- (TODO: Use this to implement per-key passphrase associations).
+    , passSpecPassFile :: InputFile
+    -- ^ The passphrase will be read from this file or file descriptor.
+    }
+    -- | Use this to carry pasphrases from a previous run.
+    | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
+
+instance Show PassphraseSpec where
+    show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
+    show (PassphraseMemoizer _) = "PassphraseMemoizer"
+instance Eq PassphraseSpec where
+    PassphraseSpec a b c == PassphraseSpec d e f
+        = and [a==d,b==e,c==f]
+    _ == _
+        = False
+
+
+
+data Transform =
+        Autosign
+        -- ^ This operation will make signatures for any tor-style UID
+        -- that matches a tor subkey and thus can be authenticated without
+        -- requring the judgement of a human user.
+        --
+        -- A tor-style UID is one of the following form:
+        --
+        -- > Anonymous <root@HOSTNAME.onion>
+        | DeleteSubKey String
+        -- ^ Delete the subkey specified by the given fingerprint and any
+        -- associated signatures on that key.
+ deriving (Eq,Ord,Show)
+
+-- | This type describes an idempotent transformation (merge or import) on a
+-- set of GnuPG keyrings and other key files.
+data KeyRingOperation = KeyRingOperation
+    { opFiles :: Map.Map InputFile StreamInfo
+    -- ^ Indicates files to be read or updated.
+    , opPassphrases :: [PassphraseSpec]
+    -- ^ Indicates files or file descriptors where passphrases can be found.
+    , opTransforms :: [Transform]
+    -- ^ Transformations to be performed on the key pool after all files have
+    -- been read and before any have been written.
+    , opHome :: Maybe FilePath
+    -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
+    -- files reside.  Otherwise, the evironment variable $GNUPGHOME is consulted
+    -- and if that is not set, it falls back to $HOME/.gnupg.
+    }
+ deriving (Eq,Show)
+
+resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
+resolveInputFile ctx = resolve
+ where
+    resolve HomeSec = return (homesecPath ctx)
+    resolve HomePub = return (homepubPath ctx)
+    resolve (ArgFile f) = return f
+    resolve _ = []
+
+resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
+resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
+ where str = case (fdr,fdw) of
+                (0,1) -> "-"
+                _     -> "&pipe" ++ show (fdr,fdw)
+resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
+ where str = "&" ++ show fd
+resolveForReport mctx f = concat $ resolveInputFile ctx f
+ where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
+
+filesToLock ::
+  KeyRingOperation -> InputFileContext -> [FilePath]
+filesToLock k ctx = do
+    (f,stream) <- Map.toList (opFiles k)
+    case fill stream of
+        KF_None -> []
+        _       -> resolveInputFile ctx f
+
+
+-- kret :: a -> KeyRingOperation a
+-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
+
+data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
+data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
+
+pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
+pkcs8 (RSAKey n e) = RSAKey8 n e
+
+instance ASN1Object RSAPublicKey where
+    -- PKCS #1 RSA Public Key
+    toASN1 (RSAKey (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : IntVal n
+                         : IntVal e
+                         : End Sequence
+                         : xs
+    fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
+        Right (RSAKey (MPI n) (MPI e), xs)
+
+    fromASN1 _ = 
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+instance ASN1Object PKCS8_RSAPublicKey where
+
+    -- PKCS #8 Public key data
+    toASN1 (RSAKey8 (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : Start Sequence
+                         : OID [1,2,840,113549,1,1,1]
+                         : Null -- Doesn't seem to be neccessary, but i'm adding it
+                                -- to match PEM files I see in the wild.
+                         : End Sequence
+                         : BitString (toBitArray bs 0)
+                         : End Sequence
+                         : xs
+        where
+            pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
+            bs = encodeASN1' DER pubkey
+
+    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
+        Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
+    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) =
+        case decodeASN1' DER bs of
+            Right as -> fromASN1 as
+            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
+      where
+        BitArray _ bs = b
+    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
+        case decodeASN1' DER bs of
+            Right as -> fromASN1 as
+            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
+      where
+        BitArray _ bs = b
+
+    fromASN1 _ =
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+{-
+RSAPrivateKey ::= SEQUENCE {
+  version           Version,
+  modulus           INTEGER,  -- n
+  publicExponent    INTEGER,  -- e
+  privateExponent   INTEGER,  -- d
+  prime1            INTEGER,  -- p
+  prime2            INTEGER,  -- q
+  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
+  exponent2         INTEGER,  -- d mod (q-1)
+  coefficient       INTEGER,  -- (inverse of q) mod p
+  otherPrimeInfos   OtherPrimeInfos OPTIONAL
+  }
+-}
+data RSAPrivateKey = RSAPrivateKey
+    { rsaN :: MPI
+    , rsaE :: MPI
+    , rsaD :: MPI
+    , rsaP :: MPI
+    , rsaQ :: MPI
+    , rsaDmodP1 :: MPI
+    , rsaDmodQminus1 :: MPI
+    , rsaCoefficient :: MPI
+    }
+ deriving Show
+
+instance ASN1Object RSAPrivateKey where
+    toASN1 rsa@(RSAPrivateKey {})
+        = \xs -> Start Sequence
+               : IntVal 0
+               : mpiVal rsaN
+               : mpiVal rsaE
+               : mpiVal rsaD
+               : mpiVal rsaP
+               : mpiVal rsaQ
+               : mpiVal rsaDmodP1
+               : mpiVal rsaDmodQminus1
+               : mpiVal rsaCoefficient
+               : End Sequence
+               : xs
+                  where mpiVal f = IntVal x where MPI x = f rsa
+
+    fromASN1 ( Start Sequence
+             : IntVal _ -- version
+             : IntVal n
+             : IntVal e
+             : IntVal d
+             : IntVal p
+             : IntVal q
+             : IntVal dmodp1
+             : IntVal dmodqminus1
+             : IntVal coefficient
+             : ys) =
+        Right ( privkey, tail $ dropWhile notend ys)
+         where
+            notend (End Sequence) = False
+            notend _              = True
+            privkey = RSAPrivateKey
+                { rsaN = MPI n
+                , rsaE = MPI e
+                , rsaD = MPI d
+                , rsaP = MPI p
+                , rsaQ = MPI q
+                , rsaDmodP1 = MPI dmodp1
+                , rsaDmodQminus1 = MPI dmodqminus1
+                , rsaCoefficient = MPI coefficient
+                }
+    fromASN1 _ =
+        Left "fromASN1: RSAPrivateKey: unexpected format"
+
+
+
+-- | This type is used to indicate success or failure
+-- and in the case of success, return the computed object.
+-- The 'FunctorToMaybe' class is implemented to facilitate
+-- branching on failture.
+data KikiCondition a = KikiSuccess a
+    | FailedToLock [FilePath]
+    | BadPassphrase
+    | FailedToMakeSignature
+    | CantFindHome
+    | AmbiguousKeySpec FilePath
+    | CannotImportMasterKey
+    | NoWorkingKey
+ deriving ( Functor, Show )
+
+instance FunctorToMaybe KikiCondition where
+    functorToMaybe (KikiSuccess a) = Just a
+    functorToMaybe _               = Nothing
+
+instance Applicative KikiCondition where
+    pure a  = KikiSuccess a
+    f <*> a =
+        case functorToEither f of
+            Right f  -> case functorToEither a of
+                            Right a  -> pure (f a)
+                            Left err -> err
+            Left err -> err
+
+-- | This type is used to describe events triggered by 'runKeyRing'.  In
+-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
+-- non-fatal IO exceptions (e.g. 'FailedExternal').  Because a
+-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
+-- many inputs and outputs, an operation may be partially (or even mostly)
+-- successful even when I/O failures occured.  In this situation, the files may
+-- not have all the information they were intended to store, but they will be
+-- in a valid format for GnuPG or kiki to operate on in the future.
+data KikiReportAction =
+        NewPacket String
+        | MissingPacket String
+        | ExportedSubkey
+        | GeneratedSubkeyFile
+        | NewWalletKey String
+        | YieldSignature
+        | YieldSecretKeyPacket String
+        | UnableToUpdateExpiredSignature
+        | WarnFailedToMakeSignature
+        | FailedExternal Int
+        | ExternallyGeneratedFile
+        | UnableToExport KeyAlgorithm String
+        | FailedFileWrite
+        | HostsDiff ByteString
+        | DeletedPacket String
+ deriving Show
+
+uncamel :: String -> String
+uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
+  where
+    (.:) = fmap . fmap
+    ( firstWord  ,
+      otherWords ) = splitAt 1 ws
+    ws             = camel >>= groupBy (\_ c -> isLower c)
+    ( camel, args) = splitAt 1 $ words str
+
+reportString :: KikiReportAction -> String
+reportString x = uncamel $ show x
+
+errorString :: KikiCondition a -> String
+errorString (KikiSuccess {}) = "success"
+errorString e = uncamel . show $ fmap (const ()) e
+
+-- | Errors in kiki are indicated by the returning of this record.
+data KikiResult a = KikiResult
+    { kikiCondition :: KikiCondition a
+    -- ^ The result or a fatal error condition.
+    , kikiReport :: KikiReport
+    -- ^ A list of non-fatal warnings and informational messages
+    -- along with the files that triggered them.
+    }
+
+type KikiReport = [ (FilePath, KikiReportAction) ]
+
+keyPacket :: KeyData -> Packet
+keyPacket (KeyData k _ _ _) = packet k
+
+subkeyMappedPacket :: SubKey -> MappedPacket
+subkeyMappedPacket (SubKey k _ ) = k
+
+
+usage :: SignatureSubpacket -> Maybe String
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
+x509cert (NotationDataPacket
+        { human_readable = False
+        , notation_name  = "x509cert@"
+        , notation_value = u
+        }) = Just (Char8.pack u)
+x509cert _    = Nothing
+
+makeInducerSig
+  :: Packet
+     -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
+-- torsig g topk wkun uid timestamp extras = todo
+makeInducerSig topk wkun uid extras
+    = CertificationSignature (secretToPublic topk)
+                             uid
+                             (sigpackets 0x13
+                                         subpackets
+                                         subpackets_unh)
+   where
+    subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
+                 tsign
+                 ++ extras
+    subpackets_unh = [IssuerPacket (fingerprint wkun)]
+    tsign = if keykey wkun == keykey topk
+             then [] -- tsign doesnt make sense for self-signatures
+             else [ TrustSignaturePacket 1 120
+                  , RegularExpressionPacket regex]
+    -- <[^>]+[@.]asdf\.nowhere>$
+    regex = "<[^>]+[@.]"++hostname++">$"
+    -- regex = username ++ "@" ++ hostname
+    -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
+    hostname = subdomain' pu ++ "\\." ++ topdomain' pu
+    pu = parseUID uidstr where UserIDPacket uidstr = uid
+    subdomain' = escape . T.unpack . uid_subdomain
+    topdomain' = escape . T.unpack . uid_topdomain
+    escape s = concatMap echar s
+      where
+        echar '|' = "\\|"
+        echar '*' = "\\*"
+        echar '+' = "\\+"
+        echar '?' = "\\?"
+        echar '.' = "\\."
+        echar '^' = "\\^"
+        echar '$' = "\\$"
+        echar '\\' = "\\\\"
+        echar '[' = "\\["
+        echar ']' = "\\]"
+        echar c = [c]
+
+
+keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
+keyflags flgs@(KeyFlagsPacket {}) =
+    Just . toEnum $
+        (   bit 0x1 certify_keys
+        .|. bit 0x2 sign_data
+        .|. bit 0x4 encrypt_communication
+        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
+    -- other flags:
+    --  split_key
+    --  authentication (ssh-client)
+    --  group_key
+ where
+    bit v f = if f flgs then v else 0
+keyflags _ = Nothing
+
+
+data PGPKeyFlags =
+    Special
+    | Vouch -- Signkey
+    | Sign
+    | VouchSign
+    | Communication
+    | VouchCommunication
+    | SignCommunication
+    | VouchSignCommunication
+    | Storage
+    | VouchStorage
+    | SignStorage
+    | VouchSignStorage
+    | Encrypt
+    | VouchEncrypt
+    | SignEncrypt
+    | VouchSignEncrypt
+ deriving (Eq,Show,Read,Enum)
+
+
+usageString :: PGPKeyFlags -> String
+usageString flgs =
+ case flgs of
+    Special -> "special"
+    Vouch -> "vouch" -- signkey
+    Sign -> "sign"
+    VouchSign -> "vouch-sign"
+    Communication -> "communication"
+    VouchCommunication -> "vouch-communication"
+    SignCommunication -> "sign-communication"
+    VouchSignCommunication -> "vouch-sign-communication"
+    Storage -> "storage"
+    VouchStorage -> "vouch-storage"
+    SignStorage -> "sign-storage"
+    VouchSignStorage -> "vouch-sign-storage"
+    Encrypt -> "encrypt"
+    VouchEncrypt -> "vouch-encrypt"
+    SignEncrypt -> "sign-encrypt"
+    VouchSignEncrypt -> "vouch-sign-encrypt"
+
+
+
+
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+matchpr :: String -> Packet -> String
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+keyFlags :: t -> [Packet] -> [SignatureSubpacket]
+keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
+
+keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
+keyFlags0 wkun uidsigs = concat
+                      [ keyflags
+                      , preferredsym
+                      , preferredhash
+                      , preferredcomp
+                      , features ]
+
+ where
+    subs = concatMap hashed_subpackets uidsigs
+    keyflags = filterOr isflags subs $
+               KeyFlagsPacket { certify_keys = True
+                              , sign_data = True
+                              , encrypt_communication = False
+                              , encrypt_storage = False
+                              , split_key = False
+                              , authentication = False
+                              , group_key = False
+                              }
+    preferredsym = filterOr ispreferedsym subs $
+               PreferredSymmetricAlgorithmsPacket
+                              [ AES256
+                              , AES192
+                              , AES128
+                              , CAST5
+                              , TripleDES
+                              ]
+    preferredhash = filterOr ispreferedhash subs $
+               PreferredHashAlgorithmsPacket
+                              [ SHA256
+                              , SHA1
+                              , SHA384
+                              , SHA512
+                              , SHA224
+                              ]
+    preferredcomp = filterOr ispreferedcomp subs $
+               PreferredCompressionAlgorithmsPacket
+                              [ ZLIB
+                              , BZip2
+                              , ZIP
+                              ]
+    features = filterOr isfeatures subs $
+               FeaturesPacket { supports_mdc = True
+                              }
+
+    filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
+
+    isflags (KeyFlagsPacket {}) = True
+    isflags _ = False
+    ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
+    ispreferedsym _ = False
+    ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
+    ispreferedhash _ = False
+    ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
+    ispreferedcomp _ = False
+    isfeatures (FeaturesPacket {}) = True
+    isfeatures _ = False
+
+
+matchSpec :: KeySpec -> KeyData -> Bool
+matchSpec (KeyGrip grip) (KeyData p _ _ _)
+    | matchpr grip (packet p)==grip = True
+    | otherwise                     = False
+
+matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
+ where
+    ps = map (packet .fst) sigs
+    match p = isSignaturePacket p
+                && has_tag tag p
+                && has_issuer key p
+    has_issuer key p = isJust $ do
+        issuer <- signature_issuer p
+        guard $ matchpr issuer key == issuer
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
+  where
+    us = filter (isInfixOf pat) $ Map.keys uids
+
+data UserIDRecord = UserIDRecord {
+    uid_full :: String,
+    uid_realname :: T.Text,
+    uid_user :: T.Text,
+    uid_subdomain :: T.Text,
+    uid_topdomain :: T.Text
+}
+ deriving Show
+
+parseUID :: String -> UserIDRecord
+parseUID str = UserIDRecord {
+                    uid_full = str,
+                    uid_realname = realname,
+                    uid_user = user,
+                    uid_subdomain = subdomain,
+                    uid_topdomain = topdomain
+                }
+ where
+    text = T.pack str
+    (T.strip-> realname, T.dropAround isBracket-> email)
+                              = T.break (=='<') text
+    (user, T.drop 1-> hostname) = T.break (=='@') email
+    ( T.reverse            -> topdomain,
+      T.reverse . T.drop 1 -> subdomain)
+                              = T.break (=='.') . T.reverse $ hostname
+isBracket :: Char -> Bool
+isBracket '<' = True
+isBracket '>' = True
+isBracket _   = False
+
+
+
+
+data KeySpec =
+      KeyGrip String       -- fp:
+    | KeyTag Packet String -- fp:????/t:
+    | KeyUidMatch String   -- u:
+ deriving Show
+
+data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum)
+data SingleKeySpec = FingerprintMatch String
+                   | SubstringMatch (Maybe MatchingField) String
+                   | EmptyMatch
+                   | AnyMatch
+                   | WorkingKeyMatch
+ deriving (Show,Eq,Ord)
+
+-- A pair of specs.  The first specifies an identity and the second
+-- specifies a specific key (possibly master) associated with that
+-- identity.
+--
+-- When no slash is specified, context will decide whether the SingleKeySpec
+-- is specifying an identity or a key belonging to the working identity.
+type Spec = (SingleKeySpec,SingleKeySpec)
+
+parseSingleSpec :: String -> SingleKeySpec
+parseSingleSpec "*"              = AnyMatch
+parseSingleSpec "-"              = WorkingKeyMatch
+parseSingleSpec ""               = EmptyMatch
+parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
+parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
+parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
+parseSingleSpec str
+    | is40digitHex str = FingerprintMatch str
+    | otherwise        = SubstringMatch Nothing str
+
+is40digitHex xs = ys == xs && length ys==40
+      where
+        ys = filter ishex xs
+        ishex c | '0' <= c && c <= '9' = True
+                | 'A' <= c && c <= 'F' = True
+                | 'a' <= c && c <= 'f' = True
+        ishex c = False
+
+
+  --  t:tor                                    -- (FingerprintMatch "", SubstringMatch "tor")
+  --  u:joe                                    -- (SubstringMatch "joe", FingerprintMatch "")
+  --  u:joe/                                   -- (SubstringMatch "joe", FingerprintMatch "!")
+  --  fp:4A39F/tor                             -- (FingerprintMatch "4A39F", SubstringMatch "tor")
+  --  u:joe/tor                                -- (SubstringMatch "joe", SubstringMatch "tor")
+  --  u:joe/t:tor                              -- (SubstringMatch "joe", SubstringMatch "tor")
+  --  u:joe/fp:4abf30                          -- (SubstringMatch "joe", FingerprintMatch "4abf30")
+  --  joe/tor                                  -- (SubstringMatch "joe", SubstringMatch "tor")
+
+-- | Parse a key specification.
+-- The first argument is a grip for the default working key.
+parseSpec :: String -> String -> (KeySpec,Maybe String)
+parseSpec wkgrip spec =
+    if not slashed
+        then
+            case prespec of
+                AnyMatch                               -> (KeyGrip "", Nothing)
+                EmptyMatch                             -> error "Bad key spec."
+                WorkingKeyMatch                        -> (KeyGrip wkgrip, Nothing)
+                SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
+                SubstringMatch Nothing str             -> (KeyGrip wkgrip, Just str)
+                SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
+                FingerprintMatch fp                    -> (KeyGrip fp, Nothing)
+        else
+            case (prespec,postspec) of
+                (FingerprintMatch fp, SubstringMatch st t)
+                    | st /= Just UserIDField                -> (KeyGrip fp, Just t)
+                (SubstringMatch mt u, _)
+                    | postspec `elem` [AnyMatch,EmptyMatch]
+                      && mt /= Just KeyTypeField            -> (KeyUidMatch u, Nothing)
+                (SubstringMatch mt u, SubstringMatch st t)
+                    | mt /= Just KeyTypeField
+                      && st /= Just UserIDField             -> (KeyUidMatch u, Just t)
+                (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
+                (_,FingerprintMatch fp)                 -> error "todo: support /fp: spec"
+                (FingerprintMatch fp,_)                 -> error "todo: support fp:/ spec"
+                _                                       -> error "Bad key spec."
+ where
+    (preslash,slashon) = break (=='/') spec
+    slashed = not $ null $ take 1 slashon
+    postslash = drop 1 slashon
+
+    prespec = parseSingleSpec preslash
+    postspec = parseSingleSpec postslash
+
+{-
+ - BUGGY
+parseSpec grip spec = (topspec,subspec)
+ where
+     (topspec0,subspec0) = unprefix '/' spec
+     (toptyp,top) = unprefix ':' topspec0
+     (subtyp,sub) = unprefix ':' subspec0
+     topspec = case () of
+                    _ | null top && or [ subtyp=="fp"
+                                       , null subtyp && is40digitHex sub
+                                       ]
+                                 -> KeyGrip sub
+                    _ | null top && null grip -> KeyUidMatch sub
+                    _ | null top -> KeyGrip grip
+                    _ | toptyp=="fp" || (null toptyp && is40digitHex top)
+                                 -> KeyGrip top
+                    _ | toptyp=="u" -> KeyUidMatch top
+                    _            -> KeyUidMatch top
+     subspec = case subtyp of
+                "t" -> Just sub
+                "fp" | top=="" -> Nothing
+                "" | top=="" && is40digitHex sub -> Nothing
+                "" -> listToMaybe sub >> Just sub
+                _ -> Nothing
+
+     is40digitHex xs = ys == xs && length ys==40
+      where
+        ys = filter ishex xs
+        ishex c | '0' <= c && c <= '9' = True
+                | 'A' <= c && c <= 'F' = True
+                | 'a' <= c && c <= 'f' = True
+        ishex c = False
+
+     -- | Split a string into two at the first occurance of the given
+     -- delimiter.  If the delimeter does not occur, then the first
+     -- item of the returned pair is empty and the second item is the
+     -- input string.
+     unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
+      where p = break (==c) spec
+-}
+
+
+filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
+filterMatches spec ks = filter (matchSpec spec . snd) ks
+
+filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
+filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
+ where
+    matchAll = KeyGrip ""
+
+    subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
+    subkeySpec (topspec,Just mtag)    = (topspec , KeyTag (packet p) mtag)
+
+    match spec mps 
+               = not . null
+               . snd
+               . seek_key spec
+               . map packet
+               $ mps
+
+    old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)
+
+    oldOrMatch spec sub = old sub
+                          || match spec (flattenSub "" True sub)
+
+    subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
+                         then oldOrMatch subspec
+                         else old)
+                       subs
+        where
+            (topspec,subspec) = subkeySpec spec
+
+selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
+
+selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
+
+selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
+selectPublicKeyAndSigs (spec,mtag) db =
+    case mtag of
+        Nothing -> do
+            (kk,r) <- Map.toList $ fmap (findbyspec spec) db
+            (sub,sigs) <- r
+            return (kk,sub,sigs)
+        Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
+ where
+    topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
+
+    findbyspec (KeyGrip g) kd = do
+        filter ismatch $
+            topresult kd
+            : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
+                  (Map.elems $ keySubKeys kd)
+      where
+        ismatch (p,sigs) = matchpr g p ==g
+    findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
+
+    findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
+     where
+        gettag (SubKey sub sigs) = do
+            let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
+            (hastag,_) <- maybeToList mb
+            guard hastag
+            return $ (kk, packet sub, map (packet . fst) sigs)
+
+selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
+selectKey0 wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
+    case ys of
+        y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
+        []    -> Nothing
+
+{-
+selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
+selectAll wantPublic (spec,mtag) db = do
+    let Message ps = flattenKeys wantPublic db
+        ys = snd $ seek_key spec ps
+    y <- take 1 ys
+    case mtag of
+        Nothing -> return (y,Nothing)
+        Just tag ->
+            let search ys1 = do
+                    let zs = snd $ seek_key (KeyTag y tag) ys1
+                    z <- take 1 zs
+                    (y,Just z):search (drop 1 zs)
+            in search (drop 1 ys)
+-}
+
+seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
+seek_key (KeyGrip grip) sec = (pre, subs)
+  where
+    (pre,subs) = break pred sec
+    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
+    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
+    pred _                      = False
+
+seek_key (KeyTag key tag) ps
+    | null bs = (ps, [])
+    | null qs =
+      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
+        (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (\p -> isSignaturePacket p
+                        && has_tag tag p
+                        && isJust (signature_issuer p)
+                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
+                    ps
+    (rs,qs) = break isKey (reverse as)
+
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+seek_key (KeyUidMatch pat) ps
+    | null bs = (ps, [])
+    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
+                    (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (isInfixOf pat . uidStr) ps
+    (rs,qs) = break isKey (reverse as)
+
+    uidStr (UserIDPacket s) = s
+    uidStr _                = ""
+
+
+data InputFileContext = InputFileContext
+    { homesecPath :: FilePath
+    , homepubPath :: FilePath
+    }
+
+readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
+readInputFileS ctx (Pipe fd _)   = fdToHandle fd >>= S.hGetContents
+readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
+readInputFileS ctx inp = do
+    let fname = resolveInputFile ctx inp
+    fmap S.concat $ mapM S.readFile fname
+
+readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
+readInputFileL ctx (Pipe fd _)   = fdToHandle fd >>= L.hGetContents
+readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
+readInputFileL ctx inp = do
+    let fname = resolveInputFile ctx inp
+    fmap L.concat $ mapM L.readFile fname
+
+
+writeInputFileL ctx (Pipe _ fd) bs   = fdToHandle fd >>= (`L.hPut` bs)
+writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs)
+writeInputFileL ctx inp bs = do
+    let fname = resolveInputFile ctx inp
+    mapM_ (`L.writeFile` bs) fname
+
+-- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
+-- writeStamped0 :: InputFileContext -> InputFile
+
+getWriteFD :: InputFile -> Maybe Posix.Fd
+getWriteFD (Pipe _ fd)   = Just fd
+getWriteFD (FileDesc fd) = Just fd
+getWriteFD _             = Nothing
+
+writeStamped0 :: InputFileContext
+    -> InputFile
+    -> Posix.EpochTime
+    -> (Either Handle FilePath -> t -> IO ())
+    -> t
+    -> IO ()
+writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do
+    h <- fdToHandle fd
+    dowrite (Left h) bs
+    handleIO_ (return ())
+     $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp)
+writeStamped0 ctx inp stamp dowrite bs = do
+    let fname = resolveInputFile ctx inp
+    forM_ fname $ \fname -> do
+    createDirectoryIfMissing True $ takeDirectory fname
+    dowrite (Right fname) bs
+    setFileTimes fname stamp stamp
+
+{- This may be useful later.  Commented for now, as it is not used.
+ -
+writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
+writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs
+-}
+
+writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
+writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str
+
+getInputFileTime :: InputFileContext -> InputFile -> IO CTime
+getInputFileTime ctx (Pipe fdr fdw) = do
+    mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
+    maybe tryw return mt
+ where
+    tryw = do
+        handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
+            $ modificationTime <$> getFdStatus fdw
+getInputFileTime ctx (FileDesc fd) = do
+    handleIO_ (error $ "&"++show fd++": modificaiton time?") $
+                    modificationTime <$> getFdStatus fd
+getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
+    handleIO_ (error $ fname++": modificaiton time?") $
+                    modificationTime <$> getFileStatus fname
+
+{-
+ - This may be useful later.  Commented for now as it is not used.
+ -
+doesInputFileExist :: InputFileContext -> InputFile -> IO Bool
+doesInputFileExist ctx f = do
+    case resolveInputFile ctx f of
+        [n] -> doesFileExist n
+        _   -> return True
+-}
+
+
+cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
+cachedContents maybePrompt ctx fd = do
+    ref <- newIORef Nothing
+    return $ get maybePrompt ref fd
+ where
+    trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
+
+    get maybePrompt ref fd = do
+        pw <- readIORef ref
+        flip (flip maybe return) pw $ do
+            if fd == FileDesc 0 then case maybePrompt of
+                                    Just prompt -> S.hPutStr stderr prompt
+                                    Nothing -> return ()
+                               else return ()
+            pw <- fmap trimCR $ readInputFileS ctx fd
+            writeIORef ref (Just pw)
+            return pw
+
+importSecretKey ::
+  (MappedPacket -> IO (KikiCondition Packet))
+  -> KikiCondition
+       (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
+  -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+  -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
+importSecretKey doDecrypt db' tup = do
+            try db' $ \(db',report0) -> do
+            r <- doImport doDecrypt
+                      db'
+                      tup
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+
+
+mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
+     -> IO
+          (KikiCondition
+             ( ( Map.Map [Char8.ByteString] KeyData
+               , ( [Hosts.Hosts]
+                 , [Hosts.Hosts]
+                 , Hosts.Hosts
+                 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
+                 , [SockAddr]))
+             , [(FilePath,KikiReportAction)]))
+mergeHostFiles krd db ctx = do
+    let hns = files ishosts
+        ishosts Hosts = True
+        ishosts _     = False
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (istyp $ typ stream)
+            return f
+
+    hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns
+
+    let gpgnames = map getHostnames $ Map.elems db
+        os = do
+            (addr,(ns,_)) <- gpgnames
+            n <- ns
+            return (addr,n)
+        setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
+        -- we ensure .onion names are set properly
+        hostdbs = map setOnions hostdbs0
+        outgoing_names = do
+            (addr,(_,gns)) <- gpgnames
+            guard . not $ null gns
+            guard $ all (null . Hosts.namesForAddress addr) hostdbs0
+            return addr
+    -- putStrLn $ "hostdbs = " ++ show hostdbs
+
+    -- 1. let U = union all the host dbs 
+    --     preserving whitespace and comments of the first
+    let u0 = foldl' Hosts.plus Hosts.empty hostdbs
+        -- we filter U to be only finger-dresses
+        u1 = Hosts.filterAddrs (hasFingerDress db) u0
+
+    -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
+    {-
+    putStrLn $ "_  = {\n" ++ show (head hostdbs) ++ "}"
+    putStrLn $ "--> " ++ show (nf (head hostdbs))
+    putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
+    putStrLn $ "--> " ++ show (nf u0)
+    putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
+    putStrLn $ "--> " ++ show (nf u1)
+    -}
+    
+    -- 2. replace gpg annotations with those in U
+    -- forM use_db
+    db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
+
+    return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
+
+writeHostsFiles
+  :: KeyRingOperation -> InputFileContext
+     -> ([Hosts.Hosts],
+         [Hosts.Hosts],
+         Hosts.Hosts,
+         [(SockAddr, (t1, [Char8.ByteString]))],
+         [SockAddr])
+     -> IO [(FilePath, KikiReportAction)]
+writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
+    let hns = files isMutableHosts
+        isMutableHosts (fill -> KF_None) = False
+        isMutableHosts (typ -> Hosts)    = True
+        isMutableHosts _                 = False
+        files istyp = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (istyp stream)
+            return f -- resolveInputFile ctx f
+
+    -- 3. add hostnames from gpg for addresses not in U
+    let u = foldl' f u1 ans
+        ans = reverse $ do
+            (addr,(_,ns)) <- gpgnames
+            guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
+            n <- ns
+            return (addr,n)
+        f h (addr,n) = Hosts.assignNewName addr n h
+
+    -- 4. for each host db H, union H with U and write it out as H'
+    --     only if there is a non-empty diff
+    rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do 
+        let h = h1 `Hosts.plus` u
+            d = Hosts.diff h0 h
+            rs = map ((fname,) . HostsDiff) d
+        unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h
+        return $ map (first $ resolveForReport $ Just ctx) rs
+    return $ concat rss
+
+isSecretKey :: Packet -> Bool
+isSecretKey (SecretKeyPacket {}) = True
+isSecretKey _                    = False
+
+buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
+              -> IO (KikiCondition ((KeyDB
+                                    ,Maybe String
+                                    ,Maybe MappedPacket
+                                    ,([Hosts.Hosts],
+                                             [Hosts.Hosts],
+                                             Hosts.Hosts,
+                                             [(SockAddr, (KeyKey, KeyKey))],
+                                             [SockAddr])
+                                    ,Map.Map InputFile Access
+                                    ,MappedPacket -> IO (KikiCondition Packet)
+                                    ,Map.Map InputFile Message
+                                    )
+                                   ,[(FilePath,KikiReportAction)]))
+buildKeyDB ctx grip0 keyring = do
+    let 
+        files isring = do
+            (f,stream) <- Map.toList (opFiles keyring)
+            guard (isring $ typ stream)
+            resolveInputFile ctx f
+
+        ringMap = Map.filter (isring . typ) $ opFiles keyring
+
+        readp f stream = fmap readp0 $ readPacketsFromFile ctx f
+         where
+          readp0 ps = (stream { access = acc' }, ps)
+           where acc' = case access stream of
+                            AutoAccess ->
+                                case ps of
+                                    Message ((PublicKeyPacket {}):_) -> Pub
+                                    Message ((SecretKeyPacket {}):_) -> Sec
+                                    _                                -> AutoAccess
+                            acc -> acc
+
+        readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
+
+    -- KeyRings (todo: KikiCondition reporting?)
+    (spilled,mwk,grip,accs,keys,unspilled) <- do
+#if MIN_VERSION_containers(0,5,0)
+        ringPackets <- Map.traverseWithKey readp ringMap
+#else
+        ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
+#endif
+        let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
+
+        let grip = grip0 `mplus` (fingerprint <$> fstkey)
+              where
+                fstkey = do
+                    (_,Message ps) <- Map.lookup HomeSec ringPackets
+                    listToMaybe ps
+            (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
+            keys :: Map.Map KeyKey MappedPacket
+            keys = Map.foldl slurpkeys Map.empty
+                        $ Map.mapWithKey filterSecrets ringPackets
+                    where
+                          filterSecrets f (_,Message ps) =
+                            filter (isSecretKey . packet)
+                                $ zipWith (mappedPacketWithHint fname) ps [1..]
+                            where fname = resolveForReport (Just ctx) f
+                          slurpkeys m ps = m `Map.union` Map.fromList ps'
+                            where ps' = zip (map (keykey . packet) ps) ps
+            wk = listToMaybe $ do
+                    fp <- maybeToList grip
+                    let matchfp mp = not (is_subkey p) && matchpr fp p == fp
+                            where p = packet mp
+                    Map.elems $ Map.filter matchfp keys
+            accs = fmap (access . fst) ringPackets
+        return (spilled,wk,grip,accs,keys,fmap snd unspilled)
+
+    doDecrypt <- makeMemoizingDecrypter keyring ctx keys
+
+    let wk = fmap packet mwk
+        rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
+                             , rtSecring = homesecPath ctx
+                             , rtGrip = grip
+                             , rtWorkingKey = wk
+                             , rtRingAccess = accs
+                             , rtKeyDB = Map.empty
+                             , rtPassphrases = doDecrypt
+                             }
+    transformed0 <-
+        let trans f (info,ps) = do
+                let manip = combineTransforms (transforms info)
+                    rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
+                    acc = Just Sec /= Map.lookup f accs
+                r <- performManipulations doDecrypt rt1 mwk manip
+                try r $ \(rt2,report) -> do
+                return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2))
+#if MIN_VERSION_containers(0,5,0)
+        in fmap sequenceA $ Map.traverseWithKey trans spilled
+#else
+        in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
+#endif
+    try transformed0 $ \transformed -> do
+    let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
+                    where
+                      mergeIt db f (_,(info,ps)) = merge db f ps
+        reportTrans = concat $ Map.elems $ fmap fst transformed
+
+    -- Wallets
+    let importWalletKey wk db' (top,fname,sub,tag) = do
+            try db' $ \(db',report0) -> do
+            r <- doImportG doDecrypt
+                      db'
+                      (fmap keykey $ maybeToList wk)
+                      [mkUsage tag]
+                      fname
+                      sub
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+
+    wms <- mapM (readw wk) (files iswallet)
+    let wallet_keys = do
+            maybeToList wk
+            (fname,xs) <- wms
+            (_,sub,(_,m)) <- xs
+            (tag,top) <- Map.toList m
+            return (top,fname,sub,tag)
+    db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
+    try db $ \(db,reportWallets) -> do
+
+    -- PEM files
+    let pems = do
+            (n,stream) <- Map.toList $ opFiles keyring
+            grip <- maybeToList grip
+            n <- resolveInputFile ctx n
+            guard $ spillable stream && isSecretKeyFile (typ stream)
+            let us = mapMaybe usageFromFilter [fill stream,spill stream]
+            usage <- take 1 us
+            guard $ all (==usage) $ drop 1 us
+            -- TODO: KikiCondition reporting for spill/fill usage mismatch?
+            let (topspec,subspec) = parseSpec grip usage
+                ms = map fst $ filterMatches topspec (Map.toList db)
+                cmd = initializer stream
+            return (n,subspec,ms,stream, cmd)
+    imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
+    db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
+    try db $ \(db,reportPEMs) -> do
+
+    r <- mergeHostFiles keyring db ctx
+    try r $ \((db,hs),reportHosts) -> do
+
+    return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
+                         , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts )
+
+torhash :: Packet -> String
+torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
+
+derToBase32 :: ByteString -> String
+#if !defined(VERSION_cryptonite)
+derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
+#else
+derToBase32 = map toLower . Base32.encode . S.unpack . sha1
+ where
+   sha1 :: L.ByteString -> S.ByteString
+   sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
+#endif
+
+derRSA :: Packet -> Maybe ByteString
+derRSA rsa = do
+    k <- rsaKeyFromPacket rsa
+    return $ encodeASN1 DER (toASN1 k [])
+
+unconditionally :: IO (KikiCondition a) -> IO a
+unconditionally action = do
+    r <- action
+    case r of
+        KikiSuccess x -> return x
+        e -> error $ errorString e
+
+try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
+try x body =
+    case functorToEither x of
+           Left e -> return e
+           Right x -> body x
+
+
+data ParsedCert = ParsedCert
+    { pcertKey :: Packet
+    , pcertTimestamp :: UTCTime
+    , pcertBlob :: L.ByteString
+    }
+ deriving (Show,Eq)
+data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
+ deriving (Show,Eq)
+
+spemPacket (PEMPacket p) = Just p
+spemPacket _ = Nothing
+
+spemCert (PEMCertificate p) = Just p
+spemCert _ = Nothing
+
+toStrict :: L.ByteString -> S.ByteString
+toStrict = foldr1 (<>) . L.toChunks
+
+-- No instance for (ASN1Object RSA.PublicKey)
+
+parseCertBlob comp bs = do
+    asn1 <- either (const Nothing) Just
+                $ decodeASN1 DER bs
+    let asn1' = drop 2 asn1
+    cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
+    let _ = cert :: X509.Certificate
+        notBefore :: UTCTime
+#if MIN_VERSION_x509(1,5,0)
+        notBefore =  toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
+            where (vincentTime,_) = X509.certValidity cert
+#else
+        (notBefore,_) = X509.certValidity cert
+#endif
+    case X509.certPubKey cert of
+        X509.PubKeyRSA key -> do
+            let withoutkey =
+                    let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
+                        (pre,post) = S.breakSubstring ekey $ toStrict bs
+                        post' = S.drop (S.length ekey) post
+                        len :: Word16
+                        len = if S.null post then maxBound
+                                             else fromIntegral $ S.length pre
+                    in if len < 4096
+                        then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
+                        else bs
+            return
+                ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
+                                                               (MPI $ RSA.public_n key)
+                                                               (MPI $ RSA.public_e key)
+                           , pcertTimestamp = notBefore
+                           , pcertBlob = if comp then withoutkey
+                                                 else bs
+                           }
+        _ -> Nothing
+
+packetFromPublicRSAKey notBefore n e =
+    PublicKeyPacket { version = 4
+                    , timestamp = round $ utcTimeToPOSIXSeconds notBefore
+                    , key_algorithm = RSA
+                    , key = [('n',n),('e',e)]
+                    , is_subkey = True
+                    , v3_days_of_validity = Nothing
+                    }
+
+decodeBlob cert =
+    if 0 /= (bs `L.index` 0) .&. 0x10
+     then bs
+     else let (keypos0,bs') = L.splitAt 2 bs
+              keypos :: Word16
+              keypos = decode keypos0
+              ds = GZip.decompress bs'
+              (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
+           in prekey <> key <> postkey
+ where
+    bs = pcertBlob cert
+    key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
+
+extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
+extractRSAKeyFields kvs = do
+    let kvs' = mapMaybe  (\(k,v) -> (k,) <$> parseField v) kvs
+    n <- lookup "Modulus" kvs'
+    e <- lookup "PublicExponent" kvs'
+    d <- lookup "PrivateExponent" kvs'
+    p <- lookup "Prime1" kvs' -- p
+    q <- lookup "Prime2" kvs' -- q
+    dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
+    dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
+    u <- lookup "Coefficient" kvs'
+    {-
+    case (d,p,dmodp1) of
+        (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
+        _ -> error "dmodp fail!"
+    case (d,q,dmodqminus1) of
+        (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
+        _ -> error "dmodq fail!"
+    -}
+    return $ RSAPrivateKey
+        { rsaN = n
+        , rsaE = e
+        , rsaD = d
+        , rsaP = p
+        , rsaQ = q
+        , rsaDmodP1 = dmodp1
+        , rsaDmodQminus1 = dmodqminus1
+        , rsaCoefficient = u }
+ where
+    parseField blob = MPI <$> m
+     where m = bigendian <$> Base64.decode (Char8.unpack blob)
+
+    bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
+     where
+        nlen = length bs
+
+rsaToPGP stamp rsa = SecretKeyPacket
+                { version = 4
+                , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
+                , key_algorithm = RSA
+                , key = [ -- public fields...
+                         ('n',rsaN rsa)
+                        ,('e',rsaE rsa)
+                        -- secret fields
+                        ,('d',rsaD rsa)
+                        ,('p',rsaQ rsa) -- Note: p & q swapped
+                        ,('q',rsaP rsa) -- Note: p & q swapped
+                        ,('u',rsaCoefficient rsa)
+                        ]
+                -- , ecc_curve = def
+                , s2k_useage = 0
+                , s2k = S2K 100 ""
+                , symmetric_algorithm = Unencrypted
+                , encrypted_data = ""
+                , is_subkey = True
+                }
+
+readSecretDNSFile :: InputFile -> IO Packet
+readSecretDNSFile fname = do
+    let ctx = InputFileContext "" ""
+    stamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
+                  . Char8.break (==':'))
+               $ Char8.lines input
+        alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
+        parseAlg spec = case Char8.words spec of
+                            nstr:_ -> case read (Char8.unpack nstr) :: Int of
+                                            2 -> DH
+                                            3 -> DSA -- SHA1
+                                            5 -> RSA -- SHA1
+                                            6 -> DSA -- NSEC3-SHA1 (RFC5155)
+                                            7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
+                                            8 -> RSA -- SHA256
+                                            10 -> RSA -- SHA512 (RFC5702)
+                                            -- 12 -> GOST
+                                            13 -> ECDSA -- P-256 SHA256 (RFC6605)
+                                            14 -> ECDSA -- P-384 SHA384 (RFC6605)
+                            _ -> RSA
+    case alg of
+        RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
+
+
+readSecretPEMFile :: InputFile -> IO [SecretPEMData]
+readSecretPEMFile fname = do
+    -- warn $ fname ++ ": reading ..."
+    let ctx = InputFileContext "" ""
+    -- Note: The key's timestamp is included in it's fingerprint.
+    --       Therefore, we should attempt to preserve it.
+    stamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
+        pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
+                    $ pemParser $ Just "RSA PRIVATE KEY"
+        cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
+                    $ pemParser $ Just "CERTIFICATE"
+        parseRSAPrivateKey dta = do
+           let e = decodeASN1 DER dta
+           asn1 <- either (const $ mzero) return e
+           rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
+           let _ = rsa :: RSAPrivateKey
+           return $ PEMPacket $ rsaToPGP stamp rsa
+        dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
+        mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
+        mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
+            where key' = if tm < fromTime (timestamp key)
+                            then key { timestamp = fromTime tm }
+                            else key
+        mergeDate (tm,_) (Right mb) = (tm,mb)
+    return $ dta
+
+doImport
+  :: Ord k =>
+     (MappedPacket -> IO (KikiCondition Packet))
+     -> Map.Map k KeyData
+     -> (FilePath, Maybe [Char], [k], StreamInfo, t)
+     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
+    flip (maybe $ return CannotImportMasterKey)
+         subspec $ \tag -> do
+    (certs,keys) <- case typ of
+        PEMFile -> do
+            ps <- readSecretPEMFile (ArgFile fname)
+            let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
+                    = partition (isJust . spemCert) ps
+            return (certs,keys)
+        DNSPresentation -> do
+            p <- readSecretDNSFile (ArgFile fname)
+            return ([],[p])
+    -- TODO Probably we need to move to a new design where signature
+    -- packets are merged into the database in one phase with null
+    -- signatures, and then the signatures are made in the next phase.
+    -- This would let us merge annotations (like certificates) from
+    -- seperate files.
+    foldM (importKey tag certs) (KikiSuccess (db,[])) keys
+ where
+    importKey tag certs prior key = do
+        try prior $ \(db,report) -> do
+        let (m0,tailms) = splitAt 1 ms
+        if (not (null tailms) || null m0)
+            then return $ AmbiguousKeySpec fname
+            else do
+                let kk = keykey key
+                    cs = filter (\c -> kk==keykey (pcertKey c)) certs
+                    blobs = map mkCertNotation $ nub $ map pcertBlob cs
+                    mkCertNotation bs = NotationDataPacket
+                        { human_readable = False
+                        , notation_name = "x509cert@"
+                        , notation_value = Char8.unpack bs }
+                    datedKey = key { timestamp = fromTime $ minimum dates }
+                    dates = fromTime (timestamp key) : map pcertTimestamp certs
+                r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
+                try r $ \(db',report') -> do
+                return $ KikiSuccess (db',report++report')
+
+doImportG
+  :: Ord k =>
+     (MappedPacket -> IO (KikiCondition Packet))
+     -> Map.Map k KeyData
+     -> [k]
+     -> [SignatureSubpacket]
+     -> [Char]
+     -> Packet
+     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+doImportG doDecrypt db m0 tags fname key = do
+    let kk = head m0
+        Just (KeyData top topsigs uids subs) = Map.lookup kk db
+        subkk = keykey key
+        (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
+                                               [])
+                                 ( (False,) . addOrigin )
+                                 (Map.lookup subkk subs)
+                             where
+                                addOrigin (SubKey mp sigs) =
+                                    let mp' = mp
+                                          { locations = Map.insert fname
+                                                             (origin (packet mp) (-1))
+                                                             (locations mp) }
+                                    in SubKey mp' sigs
+        subs' = Map.insert subkk subkey subs
+
+        istor = do
+            guard ("tor" `elem` mapMaybe usage tags)
+            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+
+    uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
+                let has_torid = do
+                     -- TODO: check for omitted real name field
+                     (sigtrusts,om) <- Map.lookup idstr uids
+                     listToMaybe $ do
+                         s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
+                         signatures_over $ verify (Message [packet top]) s
+                flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
+                wkun <- doDecrypt top
+
+                try wkun $ \wkun -> do
+
+                let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
+                    uid = UserIDPacket idstr
+                    -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
+                    tor_ov = makeInducerSig (packet top) wkun uid keyflags
+                sig_ov <- pgpSign (Message [wkun])
+                                  tor_ov
+                                  SHA1
+                                  (fingerprint wkun)
+                flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
+                     (sig_ov >>= listToMaybe . signatures_over)
+                     $ \sig -> do
+                let om = Map.singleton fname (origin sig (-1))
+                    trust = Map.empty
+                return $ KikiSuccess
+                    ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
+                                         , trust)],om) uids
+                    , [] )
+
+    try uids' $ \(uids',report) -> do
+
+    let SubKey subkey_p subsigs = subkey
+        wk = packet top
+        (xs',minsig,ys') = findTag tags wk key subsigs
+        doInsert mbsig db = do
+            -- NEW SUBKEY BINDING SIGNATURE
+            sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
+            try sig' $ \(sig',report) -> do
+            report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
+            let subs' = Map.insert subkk
+                                   (SubKey subkey_p $ xs'++[sig']++ys')
+                                   subs
+            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+                                 , report )
+
+    report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
+                                    else id
+                  s = show (fmap fst minsig,fingerprint key)
+              in return (f report)
+
+    case minsig of
+        Nothing          -> doInsert Nothing db    -- we need to create a new sig
+        Just (True,sig)  -> -- we can deduce is_new == False
+                            -- we may need to add a tor id
+                            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+                                                 , report )
+        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
+
+isCryptoCoinKey :: Packet -> Bool
+isCryptoCoinKey p =
+    and [ isKey p
+        , key_algorithm p == ECDSA
+        , lookup 'c' (key p) == Just (MPI secp256k1_id)
+        ]
+
+getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork
+getCryptoCoinTag p | isSignaturePacket p = do
+    -- CryptoCoins.secret
+    let sps = hashed_subpackets p ++ unhashed_subpackets p
+    u <- listToMaybe $ mapMaybe usage sps
+    CryptoCoins.lookupNetwork CryptoCoins.network_name u
+getCryptoCoinTag _ = Nothing
+
+
+coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)]
+coinKeysOwnedBy db wk = do
+    wk <- maybeToList wk
+    let kk = keykey wk
+    KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
+    (subkk,SubKey mp sigs) <- Map.toList subs
+    let sub = packet mp
+    guard $ isCryptoCoinKey sub
+    tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
+    return (tag,mp)
+
+walletImportFormat :: Word8 -> Packet -> String
+walletImportFormat idbyte k = secret_base58_foo
+ where
+    -- isSecret (SecretKeyPacket {}) = True
+    -- isSecret _                    = False
+    secret_base58_foo = base58_encode seckey
+    Just d = lookup 'd' (key k)
+    (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
+    seckey = S.cons idbyte bigendian
+
+writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writeWalletKeys krd db wk = do
+    let cs = db `coinKeysOwnedBy` wk
+    -- export wallet keys
+        isMutableWallet (fill -> KF_None)      = False
+        isMutableWallet (typ -> WalletFile {}) = True
+        isMutableWallet _                      = False
+        files pred = do
+            (f,stream) <- Map.toList (opFiles krd)
+            guard (pred stream)
+            resolveInputFile (InputFileContext "" "") f
+    let writeWallet report n = do
+        let cs' = do
+            (nw,mp) <- cs
+            -- let fns = Map.keys (locations mp)
+            -- trace ("COIN KEY: "++show fns) $ return ()
+            guard . not $ Map.member n (locations mp)
+            let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
+            return (CryptoCoins.network_name nw,wip)
+        handleIO_ (return report) $ do
+        -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based
+        -- to InputFile-based.
+        withFile n AppendMode $ \fh -> do
+        rs <- forM cs' $ \(net,wip) -> do
+            hPutStrLn fh wip
+            return (n, NewWalletKey net)
+        return (report ++ rs)
+    report <- foldM writeWallet [] (files isMutableWallet)
+    return $ KikiSuccess report
+
+ifSecret :: Packet -> t -> t -> t
+ifSecret (SecretKeyPacket {}) t f = t
+ifSecret _                    t f = f
+
+showPacket :: Packet -> String
+showPacket p | isKey p   = (if is_subkey p
+                              then showPacket0 p
+                              else ifSecret p "----Secret-----" "----Public-----")
+                           ++ " "++show (key_algorithm p)++" "++fingerprint p
+             | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
+             | otherwise = showPacket0 p
+showPacket0 p = concat . take 1 $ words (show p)
+
+
+-- | returns Just True so as to indicate that
+-- the public portions of keys will be imported
+importPublic :: Maybe Bool
+importPublic = Just True
+
+-- | returns False True so as to indicate that
+-- the public portions of keys will be imported
+importSecret :: Maybe Bool
+importSecret = Just False
+
+
+-- TODO: Do we need to memoize this?
+guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe ()
+guardAuthentic rt keydata = guard (isauth rt keydata)
+
+isauth :: KeyRingRuntime -> KeyData -> Bool
+isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
+          where wk = workingKey (rtGrip rt) (rtKeyDB rt)
+                dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
+                                                   $ locations p
+                has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
+                 where
+                    goodsig (uidstr,(sigs,_)) = not . null $ do
+                        sig0 <- fmap (packet . fst) sigs
+                        pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0])
+                        signatures_over $ verify (Message [wk]) pre_ov
+
+                workingKey grip use_db = listToMaybe $ do
+                            fp <- maybeToList grip
+                            elm <- Map.elems use_db
+                            guard $ matchSpec (KeyGrip fp) elm
+                            return $ keyPacket elm
+
+writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
+                    -> [(FilePath,KikiReportAction)]
+                {-
+                ->  KeyDB -> Maybe Packet
+                -> FilePath -> FilePath
+                -}
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
+    let isring (KeyRingFile {}) = True
+        isring _                = False
+        db = rtKeyDB rt
+        secring = rtSecring rt
+        pubring = rtPubring rt
+        ctx = InputFileContext secring pubring
+    let s = do
+        (f,f0,stream) <- do
+            (f0,stream) <- Map.toList (opFiles krd)
+            guard (isring $ typ stream)
+            f <- resolveInputFile ctx f0
+            return (f,f0,stream)
+        let db' = fromMaybe db $ do
+                    msg <- Map.lookup f0 unspilled
+                    return $ merge db f0 msg
+            x = do
+                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
+                    wantedForFill acc KF_None       = importByExistingMaster
+                        -- Note the KF_None case is almost irrelevent as it will be
+                        -- filtered later when isMutable returns False.
+                        -- We use importByExistingMaster in order to generate
+                        -- MissingPacket warnings.  To disable those warnings, use
+                        -- const Nothing instead.
+                    wantedForFill acc (KF_Match {}) = importByExistingMaster
+                    wantedForFill acc KF_Subkeys    = importByExistingMaster
+                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
+                                                                importByAccess acc kd
+                    wantedForFill acc KF_All        = importByAccess acc
+                    importByAccess Pub kd = importPublic
+                    importByAccess Sec kd = importSecret
+                    importByAccess AutoAccess kd =
+                        mplus (importByExistingMaster kd)
+                              (error $ f ++ ": write public or secret key to file?")
+                    importByExistingMaster kd@(KeyData p _ _ _) =
+                        fmap originallyPublic $ Map.lookup f $ locations p
+                d <- sortByHint f keyMappedPacket (Map.elems db')
+                acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
+                only_public <- maybeToList $ wantedForFill acc (fill stream) d
+                guard $ only_public || isSecretKey (keyPacket d)
+                case fill stream of
+                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
+                                         flattenTop f only_public
+                                            $ filterNewSubs f (parseSpec grip usage) d
+                    _              -> flattenTop f only_public d
+            new_packets = filter isnew x
+                where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
+            -- TODO: We depend on an exact string match between the reported
+            -- file origin of the deleted packet and the path of the file we are
+            -- writing.  Verify that this is a safe assumption.
+            isdeleted (f',DeletedPacket _) = f'==f
+            isdeleted _                    = False
+        guard (not (null new_packets) || any isdeleted report_manips)
+        return ((f0,isMutable stream),(new_packets,x))
+    let (towrites,report) = (\f -> foldl f ([],[]) s) $
+         \(ws,report) ((f,mutable),(new_packets,x)) ->
+            if mutable
+                then
+                     let rs = flip map new_packets
+                                $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c))
+                     in (ws++[(f,x)],report++rs)
+                else
+                     let rs = flip map new_packets
+                                $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c)))
+                     in (ws,report++rs)
+    forM_ towrites $ \(f,x) -> do
+        let m = Message $ map packet x
+        -- warn $ "writing "++f
+        writeInputFileL ctx f (encode m)
+    return $ KikiSuccess report
+
+
+{-
+getSubkeysForExport kk subspec db = do
+    kd <- maybeToList $ Map.lookup kk db
+    subkeysForExport subspec kd
+-}
+
+-- | If provided Nothing for the first argument, this function returns the
+-- master key of the given identity.  Otherwise, it returns all the subkeys of
+-- the given identity which have a usage tag that matches the first argument.
+subkeysForExport :: Maybe String -> KeyData -> [MappedPacket]
+subkeysForExport subspec (KeyData key _ _ subkeys) = do
+    let subs tag = do
+            e <- Map.elems subkeys
+            guard $ doSearch key tag e
+            return $ subkeyMappedPacket e
+    maybe [key] subs subspec
+ where
+    doSearch key tag (SubKey sub_mp sigtrusts) =
+        let (_,v,_) = findTag [mkUsage tag]
+                          (packet key)
+                          (packet sub_mp)
+                          sigtrusts
+        in fmap fst v==Just True
+
+writePEM :: String -> String -> String
+writePEM typ dta = pem
+ where
+    pem = unlines . concat $
+            [ ["-----BEGIN " <> typ <> "-----"]
+            , split64s dta
+            , ["-----END " <> typ <> "-----"] ]
+    split64s :: String -> [String]
+    split64s "" = []
+    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
+
+    -- 64 byte lines
+
+rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
+rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
+    -- public fields...
+    n <- lookup 'n' $ key pkt
+    e <- lookup 'e' $ key pkt
+    -- secret fields
+    MPI d <- lookup 'd' $ key pkt
+    MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
+    MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
+
+    -- Note: Here we fail if 'u' key is missing.
+    -- Ideally, it would be better to compute (inverse q) mod p
+    -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
+    --     (package constructive-algebra)
+    coefficient <- lookup 'u' $ key pkt
+
+    let dmodp1 = MPI $ d `mod` (p - 1)
+        dmodqminus1 = MPI $ d `mod` (q - 1)
+    return $ RSAPrivateKey
+        { rsaN = n
+        , rsaE = e
+        , rsaD = MPI d
+        , rsaP = MPI p
+        , rsaQ = MPI q
+        , rsaDmodP1 = dmodp1
+        , rsaDmodQminus1 = dmodqminus1
+        , rsaCoefficient = coefficient }
+rsaPrivateKeyFromPacket _ = Nothing
+
+secretPemFromPacket packet = pemFromPacket Sec packet
+
+pemFromPacket Sec packet =
+    case key_algorithm packet of
+     RSA -> do
+        rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
+        let asn1 = toASN1 rsa []
+            bs = encodeASN1 DER asn1
+            dta = Base64.encode (L.unpack bs)
+            output = writePEM "RSA PRIVATE KEY" dta
+        Just output
+     algo -> Nothing
+pemFromPacket Pub packet =
+    case key_algorithm packet of
+     RSA -> do
+        rsa <- rsaKeyFromPacket packet
+        let asn1 = toASN1 (pkcs8 rsa) []
+            bs = encodeASN1 DER asn1
+            dta = Base64.encode (L.unpack bs)
+            output = writePEM "PUBLIC KEY" dta
+        Just output
+     algo -> Nothing
+pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p
+pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p
+pemFromPacket AutoAccess _ = Nothing
+
+writeKeyToFile ::
+  Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
+writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do
+    case pemFromPacket (access stream) packet of
+     Just output -> do
+        let stamp = toEnum . fromEnum $ timestamp packet
+        handleIO_ (return [(fname, FailedFileWrite)]) $ do
+            saved_mask <- setFileCreationMask 0o077
+            -- Note: The key's timestamp is included in it's fingerprint.
+            --       Therefore, we should attempt to preserve it.
+            writeStamped (InputFileContext "" "") fname stamp output
+            setFileCreationMask saved_mask
+            return [(fname, ExportedSubkey)]
+     Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]
+
+writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do
+    case key_algorithm packet of
+     RSA -> do
+        flip (maybe (return []))
+             (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
+            $ \rsa -> do
+        let -- asn1 = toASN1 rsa []
+            -- bs = encodeASN1 DER asn1
+            -- dta = Base64.encode (L.unpack bs)
+            b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
+             where
+                MPI i = ac rsa
+                i2bs_unsized :: Integer -> S.ByteString
+                i2bs_unsized 0 = S.singleton 0
+                i2bs_unsized i = S.reverse $ S.unfoldr go i
+                 where go i' = if i' <= 0 then Nothing
+                                          else Just (fromIntegral i', (i' `shiftR` 8))
+            output = unlines
+                [ "Private-key-format: v1.2"
+                , "Algorithm: 8 (RSASHA256)"
+                , "Modulus: " ++ b64 rsaN rsa
+                , "PublicExponent: " ++ b64 rsaE rsa
+                , "PrivateExponent: " ++ b64 rsaD rsa
+                , "Prime1: " ++ b64 rsaP rsa
+                , "Prime2: " ++ b64 rsaQ rsa
+                , "Exponent1: " ++ b64 rsaDmodP1 rsa
+                , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
+                , "Coefficient: " ++ b64 rsaCoefficient rsa
+                ]
+            stamp = toEnum . fromEnum $ timestamp packet
+        handleIO_ (return [(fname, FailedFileWrite)]) $ do
+            saved_mask <- setFileCreationMask 0o077
+            -- Note: The key's timestamp is included in it's fingerprint.
+            --       Therefore, we should attempt to preserve it.
+            writeStamped (InputFileContext "" "") fname stamp output
+            setFileCreationMask saved_mask
+            return [(fname, ExportedSubkey)]
+     algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
+
+writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
+                -> KeyDB
+                -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
+                -> IO (KikiCondition [(FilePath,KikiReportAction)])
+writePEMKeys doDecrypt db exports = do
+    ds <- mapM decryptKeys exports
+    let ds' = map functorToEither ds
+    if null (lefts ds')
+        then do
+            rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p)
+                       (rights ds')
+            return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
+        else do
+            return (head $ lefts ds')
+ where
+    decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
+        = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
+    decryptKeys (fname,subspec,[p],stream) = do
+        pun <- doDecrypt p
+        try pun $ \pun -> do
+        return $ KikiSuccess (fname,stream,pun)
+
+makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+                        -> Map.Map KeyKey MappedPacket
+                        -> IO (MappedPacket -> IO (KikiCondition Packet))
+makeMemoizingDecrypter operation ctx keys =
+   if null chains then  do
+    -- (*) Notice we do not pass ctx to resolveForReport.
+    -- This is because the merge function does not currently use a context
+    -- and the pws map keys must match the MappedPacket locations.
+    -- TODO: Perhaps these should both be of type InputFile rather than
+    -- FilePath?
+    -- pws :: Map.Map FilePath (IO S.ByteString)
+    {-
+    pws <-
+        Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
+                         (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
+                            $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
+    -}
+        let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
+        pws2 <- 
+            Traversable.mapM (cachedContents prompt ctx)
+             $ Map.fromList $ mapMaybe
+                    (\spec -> (,passSpecPassFile spec) `fmap` do
+                        guard $ isNothing $ passSpecKeySpec spec
+                        passSpecRingFile spec)
+                    passspecs
+        defpw <- do
+            Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
+             $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
+                                            && isNothing (passSpecKeySpec sp))
+                                        $ opPassphrases operation
+        unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
+        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
+    else let PassphraseMemoizer f = head chains
+         in return f
+ where
+    (chains,passspecs) = partition isChain $ opPassphrases operation
+                            where isChain (PassphraseMemoizer {}) = True
+                                  isChain _ = False
+    doDecrypt :: IORef (Map.Map KeyKey Packet)
+                -> Map.Map FilePath (IO S.ByteString)
+                -> Maybe (IO S.ByteString)
+                -> MappedPacket
+                -> IO (KikiCondition Packet)
+    doDecrypt unkeysRef pws defpw mp0 = do
+        unkeys <- readIORef unkeysRef
+        let mp = fromMaybe mp0 $ do
+                    k <- Map.lookup kk keys
+                    return $ mergeKeyPacket "decrypt" mp0 k
+            wk = packet mp0
+            kk = keykey wk
+            fs = Map.keys $ locations mp
+
+            decryptIt [] = return BadPassphrase
+            decryptIt (getpw:getpws) = do
+                -- TODO: This function should use mergeKeyPacket to 
+                --  combine the packet with it's unspilled version before
+                --  attempting to decrypt it.
+                pw <- getpw
+                let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
+                case symmetric_algorithm wkun of
+                    Unencrypted -> do
+                        writeIORef unkeysRef (Map.insert kk wkun unkeys)
+                        return $ KikiSuccess wkun
+                    _ -> decryptIt getpws
+
+            getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
+
+        case symmetric_algorithm wk of
+            Unencrypted -> return (KikiSuccess wk)
+            _ -> maybe (decryptIt getpws)
+                       (return . KikiSuccess)
+                    $ Map.lookup kk unkeys
+
+performManipulations ::
+                (MappedPacket -> IO (KikiCondition Packet))
+                -> KeyRingRuntime
+                -> Maybe MappedPacket
+                -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
+                -> IO (KikiCondition (KeyRingRuntime,KikiReport))
+performManipulations doDecrypt rt wk manip = do
+    let db = rtKeyDB rt
+        performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
+    r <- Traversable.mapM performAll db
+    try (sequenceA r) $ \db -> do
+    return $ KikiSuccess (rt { rtKeyDB =  fmap fst db }, concatMap snd $ Map.elems db)
+ where
+    perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
+    perform kd (InducerSignature uid subpaks) = do
+        try kd $ \(kd,report) -> do
+        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
+        wkun' <- doDecrypt wk'
+        try wkun' $ \wkun -> do    
+        let flgs = if keykey (keyPacket kd) == keykey wkun
+                    then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
+                    else []
+            sigOver = makeInducerSig (keyPacket kd)
+                                     wkun
+                                     (UserIDPacket uid)
+                                     $ flgs ++ subpaks
+            om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
+            toMappedPacket om p = (mappedPacket "" p) {locations=om}
+            selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
+                                   . (== keykey whosign)
+                                   . keykey)) vs
+            keys = map keyPacket $ Map.elems (rtKeyDB rt)
+            overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
+            vs :: [ ( Packet -- signature
+                   , Maybe SignatureOver -- Nothing means non-verified
+                   , Packet ) -- key who signed
+                 ]
+            vs = do
+                   x <- maybeToList $ Map.lookup uid (keyUids kd)
+                   sig <- map (packet . fst) (fst x)
+                   o <- overs sig
+                   k <- keys
+                   let ov = verify (Message [k]) $ o
+                   signatures_over ov
+                   return (sig,Just ov,k)
+            additional new_sig = do
+                new_sig <- maybeToList new_sig
+                guard (null $ selfsigs)
+                signatures_over new_sig
+        sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
+        let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
+            f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
+                  , om `Map.union` snd x )
+        -- XXX: Shouldn't this signature generation show up in the KikiReport ?
+        return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
+
+    perform kd (SubKeyDeletion topk subk) = do
+        try kd $ \(kd,report) -> do
+        let kk = keykey $ packet $ keyMappedPacket kd
+            kd' | kk /= topk = kd
+                | otherwise  = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
+            pred k _ = k /= subk
+            ps = concat $ maybeToList $ do
+                SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
+                return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
+            ctx = InputFileContext (rtSecring rt) (rtPubring rt)
+            rings = [HomeSec, HomePub] >>= resolveInputFile ctx
+        return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
+
+initializeMissingPEMFiles ::
+    KeyRingOperation
+      -> InputFileContext -> Maybe String
+      -> (MappedPacket -> IO (KikiCondition Packet))
+      -> KeyDB
+      -> IO (KikiCondition ( (KeyDB,[( FilePath
+                                     , Maybe String
+                                     , [MappedPacket]
+                                     , StreamInfo )])
+                           , [(FilePath,KikiReportAction)]))
+initializeMissingPEMFiles operation ctx grip decrypt db = do
+        nonexistents <-
+           filterM (fmap not . doesFileExist . fst)
+               $ do (f,t) <- Map.toList (opFiles operation)
+                    f <- resolveInputFile ctx f
+                    return (f,t)
+
+        let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
+                (fname,stream) <- nonexistents
+                guard $ isMutable stream
+                guard $ isSecretKeyFile (typ stream)
+                usage <- usageFromFilter (fill stream) -- TODO: Error if no result?
+                let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
+                    -- ms will contain duplicates if a top key has multiple matching
+                    -- subkeys.  This is intentional.
+                    -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
+                    -- ms = filterMatches topspec $ Map.toList db
+                    ns = do
+                       (kk,kd) <- filterMatches topspec $ Map.toList db
+                       return (kk , subkeysForExport subspec kd)
+                return (fname,subspec,ns,stream)
+            (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
+                                             notmissing
+            exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0
+
+            ambiguity (f,topspec,subspec,_) = do
+               return $ AmbiguousKeySpec f
+
+            ifnotnull (x:xs) f g = f x
+            ifnotnull _      f g = g
+
+        ifnotnull ambiguous ambiguity $ do
+
+        -- create nonexistent files via external commands
+        do
+           let cmds = mapMaybe getcmd missing
+                 where
+                   getcmd (fname,subspec,ms,stream) = do
+                       cmd <- initializer stream
+                       return (fname,subspec,ms,stream,cmd)
+           rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
+               e <- systemEnv [ ("file",fname)
+                              , ("usage",fromMaybe "" subspec) ]
+                              cmd
+               case e of
+                 ExitFailure num -> return (tup,FailedExternal num)
+                 ExitSuccess     -> return (tup,ExternallyGeneratedFile)
+
+           v <- foldM (importSecretKey decrypt)
+                      (KikiSuccess (db,[])) $ do
+                    ((f,subspec,ms,stream,cmd),r) <- rs
+                    guard $ case r of
+                       ExternallyGeneratedFile -> True
+                       _ -> False
+                    return (f,subspec,map fst ms,stream,cmd)
+
+           try v $ \(db,import_rs) -> do
+           return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
+                                     ++ import_rs)
+{-
+interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
+interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
+interpretManip kd manip = return kd
+-}
+
+combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+combineTransforms trans rt kd = updates
+ where
+    updates = -- kManip operation rt kd ++
+              concatMap (\t -> resolveTransform t rt kd) sanitized
+    sanitized = group (sort trans) >>= take 1
+
+isSubkeySignature (SubkeySignature {}) = True
+isSubkeySignature _                    = False
+
+-- Returned data is simmilar to getBindings but the Word8 codes
+-- are ORed together.
+accBindings ::
+  Bits t =>
+  [(t, (Packet, Packet), [a], [a1], [a2])]
+  -> [(t, (Packet, Packet), [a], [a1], [a2])]
+accBindings bs = as
+  where
+    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
+    as = map (foldl1 combine) gs
+    bindingPair (_,p,_,_,_) = pub2 p
+      where
+        pub2 (a,b) = (pub a, pub b)
+        pub a = fingerprint_material a
+    samePair a b = bindingPair a == bindingPair b
+    combine (ac,p,akind,ahashed,aclaimaints)
+            (bc,_,bkind,bhashed,bclaimaints)
+        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
+
+
+
+verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
+ where
+    verified = do
+        sig <- signatures (Message nonkeys)
+        let v = verify (Message keys) sig
+        guard (not . null $ signatures_over v)
+        return v
+    (top,othersigs) = partition isSubkeySignature verified
+    embedded = do
+        sub <- top
+        let sigover = signatures_over sub
+            unhashed = sigover >>= unhashed_subpackets
+            subsigs = mapMaybe backsig unhashed
+            -- This should consist only of 0x19 values
+            -- subtypes = map signature_type subsigs
+        -- trace ("subtypes = "++show subtypes) (return ())
+        -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
+        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
+        let v = verify (Message [subkey sub]) sig
+        guard (not . null $ signatures_over v)
+        return v
+
+smallpr k = drop 24 $ fingerprint k
+
+disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
+ where
+    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
+    samepr a b = smallpr a == smallpr b
+
+    {-
+    -- useful for testing
+    group2 :: [a] -> [[a]]
+    group2 (x:y:ys) = [x,y]:group2 ys
+    group2 [x]      = [[x]]
+    group2 []       = []
+    -}
+
+
+getBindings ::
+  [Packet]
+  ->
+    ( [([Packet],[SignatureOver])] --  other signatures with key sets
+                                   --  that were used for the verifications
+    , [(Word8,
+       (Packet, Packet), -- (topkey,subkey)
+       [String],         -- usage flags
+       [SignatureSubpacket], -- hashed data
+       [Packet])] -- binding signatures
+    )
+getBindings pkts = (sigs,bindings)
+ where
+    (sigs,concat->bindings) = unzip $ do
+        let (keys,_) = partition isKey pkts
+        keys <- disjoint_fp keys
+        let (bs,sigs) = verifyBindings keys pkts
+        return . ((keys,sigs),) $ do
+            b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
+            i <- map signature_issuer (signatures_over b)
+            i <- maybeToList i
+            who <- maybeToList $ find_key fingerprint (Message keys) i
+            let (code,claimants) =
+                    case () of
+                        _ | who == topkey b -> (1,[])
+                        _ | who == subkey b -> (2,[])
+                        _                   -> (0,[who])
+            let hashed = signatures_over b >>= hashed_subpackets
+                kind = guard (code==1) >> hashed >>= maybeToList . usage
+            return (code,(topkey b,subkey b), kind, hashed,claimants)
+
+resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
+ where
+    ops = map (\u -> InducerSignature u []) us
+    us = filter torStyle $ Map.keys umap
+    torStyle str = and [ uid_topdomain parsed == "onion"
+                        , uid_realname parsed `elem` ["","Anonymous"]
+                        , uid_user parsed == "root"
+                        , fmap (match . fst) (lookup (packet k) torbindings)
+                            == Just True ]
+      where parsed = parseUID str
+            match =  (==subdom) . take (fromIntegral len)
+            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
+            subdom = Char8.unpack subdom0
+            len = T.length (uid_subdomain parsed)
+            torbindings = getTorKeys (map packet $ flattenTop "" True kd)
+            getTorKeys pub = do
+                xs <- groupBindings pub
+                (_,(top,sub),us,_,_) <- xs
+                guard ("tor" `elem` us)
+                let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
+                return (top,(torhash,sub))
+
+            groupBindings pub = gs
+             where (_,bindings) = getBindings pub
+                   bindings' = accBindings bindings
+                   code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
+                   ownerkey (_,(a,_),_,_,_) = a
+                   sameMaster (ownerkey->a) (ownerkey->b)
+                        = fingerprint_material a==fingerprint_material b
+                   gs = groupBy sameMaster (sortBy (comparing code) bindings')
+
+
+resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
+ where
+    topk = keykey $ packet k -- key to master of key to be deleted
+    subk = do
+        (k,sub) <- Map.toList submap
+        guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
+        return k
+
+
+-- | Load and update key files according to the specified 'KeyRingOperation'.
+runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
+runKeyRing operation = do
+    homedir <- getHomeDir (opHome operation)
+    let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
+        -- FIXME: try' should probably accept a list of KikiReportActions.
+        --  This would be useful for reporting on disk writes that have already
+        --  succeded prior to this termination.
+        try' v body =
+            case functorToEither v of
+                   Left e -> return $ KikiResult e []
+                   Right wkun -> body wkun
+    try' homedir $ \(homedir,secring,pubring,grip0) -> do
+    let ctx = InputFileContext secring pubring
+        tolocks = filesToLock operation ctx 
+    secring <- return Nothing
+    pubring <- return Nothing
+    lks <- forM tolocks $ \f -> do
+        lk <- dotlock_create f 0
+        v <- flip (maybe $ return Nothing) lk $ \lk -> do
+                e <- dotlock_take lk (-1)
+                if e==0 then return $ Just lk
+                        else dotlock_destroy lk >> return Nothing
+        return (v,f)
+    let (lked, map snd -> failed_locks) = partition (isJust . fst) lks
+    ret <-
+      if not $ null failed_locks
+       then return $ KikiResult (FailedToLock failed_locks) []
+       else do
+
+        -- merge all keyrings, PEM files, and wallets
+        bresult <- buildKeyDB ctx grip0 operation
+        try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
+
+        externals_ret <- initializeMissingPEMFiles operation
+                                                   ctx
+                                                   grip
+                                                   decrypt
+                                                   db
+        try' externals_ret $ \((db,exports),report_externals) -> do
+
+        let rt = KeyRingRuntime
+                       { rtPubring = homepubPath ctx
+                       , rtSecring = homesecPath ctx
+                       , rtGrip = grip
+                       , rtWorkingKey = fmap packet wk
+                       , rtKeyDB = db
+                       , rtRingAccess = accs
+                       , rtPassphrases = decrypt
+                       }
+
+        r <- performManipulations decrypt
+                                  rt
+                                  wk
+                                  (combineTransforms $ opTransforms operation)
+        try' r $ \(rt,report_manips) -> do
+
+        r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
+        try' r $ \report_wallets -> do
+
+        r <- writeRingKeys operation rt unspilled report_manips
+        try' r $ \report_rings -> do
+
+        r <- writePEMKeys decrypt (rtKeyDB rt) exports
+        try' r $ \report_pems -> do
+        
+        import_hosts <- writeHostsFiles operation ctx hs
+
+        return $ KikiResult (KikiSuccess rt)
+                   $ concat [ report_imports
+                            , report_externals
+                            , report_manips
+                            , report_wallets
+                            , report_rings
+                            , report_pems ]
+
+    forM_ lked $ \(Just lk, fname) -> dotlock_release lk
+
+    return ret
+
+parseOptionFile :: FilePath -> IO [String]
+parseOptionFile fname = do
+    xs <- fmap lines (readFile fname)
+    let ys = filter notComment xs
+        notComment ('#':_) = False
+        notComment cs      = not (all isSpace cs)
+    return ys
+
+-- | returns ( home directory
+--           , path to secret ring
+--           , path to public ring
+--           , fingerprint of working key
+--           )
+getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
+getHomeDir protohome = do
+        homedir <- envhomedir protohome
+        flip (maybe (return CantFindHome))
+             homedir $ \homedir -> do
+        -- putStrLn $ "homedir = " ++show homedir
+        let secring = homedir ++ "/" ++ "secring.gpg"
+            pubring = homedir ++ "/" ++ "pubring.gpg"
+        -- putStrLn $ "secring = " ++ show secring
+        workingkey <- getWorkingKey homedir
+        return $ KikiSuccess (homedir,secring,pubring,workingkey)
+ where
+    envhomedir opt = do
+        gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
+        homed <- fmap (mfilter (/="") . Just) getHomeDirectory
+        let homegnupg = (++('/':(appdir home))) <$> homed
+        let val = (opt `mplus` gnupghome `mplus` homegnupg)
+        return $ val
+
+    -- TODO: rename this to getGrip
+    getWorkingKey homedir = do
+        let o = Nothing
+            h = Just homedir
+        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
+                let optfiles = map (second ((h++"/")++))
+                                   (maybe optfile_alts' (:[]) o')
+                    optfile_alts' = zip (False:repeat True) (optfile_alts home)
+                    o' = fmap (False,) o
+                in filterM (doesFileExist . snd) optfiles
+        args <- flip (maybe $ return []) ofile $
+            \(forgive,fname) -> parseOptionFile fname
+        let config = map (topair . words) args
+                        where topair (x:xs) = (x,xs)
+        return $ lookup "default-key" config >>= listToMaybe
+
+#if MIN_VERSION_base(4,6,0)
+#else
+lookupEnv :: String -> IO (Maybe String) 
+lookupEnv var =
+    handleIO_ (return Nothing) $ fmap Just (getEnv var)
+#endif
+
+isKey :: Packet -> Bool
+isKey (PublicKeyPacket {}) = True
+isKey (SecretKeyPacket {}) = True
+isKey _                    = False
+
+isUserID :: Packet -> Bool
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isTrust :: Packet -> Bool
+isTrust (TrustPacket {}) = True
+isTrust _                = False
+
+sigpackets ::
+  Monad m =>
+  Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
+sigpackets typ hashed unhashed = return $
+    signaturePacket
+        4 -- version
+        typ -- 0x18 subkey binding sig, or 0x19 back-signature
+        RSA
+        SHA1
+        hashed
+        unhashed
+        0 -- Word16 -- Left 16 bits of the signed hash value
+        [] -- [MPI]
+
+secretToPublic :: Packet -> Packet
+secretToPublic pkt@(SecretKeyPacket {}) =
+    PublicKeyPacket { version = version pkt
+                    , timestamp = timestamp pkt
+                    , key_algorithm = key_algorithm pkt
+                    -- , ecc_curve = ecc_curve pkt
+                    , key = let seckey = key pkt
+                                pubs = public_key_fields (key_algorithm pkt)
+                            in filter (\(k,v) -> k `elem` pubs) seckey
+                    , is_subkey = is_subkey pkt
+                    , v3_days_of_validity = Nothing
+                    }
+secretToPublic pkt = pkt
+
+
+
+slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
+slurpWIPKeys stamp "" = ([],[])
+slurpWIPKeys stamp cs =
+    let (b58,xs) = Char8.span (`elem` base58chars) cs
+        mb        = decode_btc_key stamp (Char8.unpack b58)
+    in if L.null b58
+        then let (ys,xs') = Char8.break (`elem` base58chars) cs
+                 (ks,js)  = slurpWIPKeys stamp xs'
+             in (ks,ys:js)
+        else let (ks,js) = slurpWIPKeys stamp xs
+             in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
+
+
+decode_btc_key ::
+  Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
+decode_btc_key timestamp str = do
+    (network_id,us) <- base58_decode str
+    return . (network_id,) $ Message $ do
+        let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
+            {-
+            xy = secp256k1_G `pmul` d
+            x = getx xy
+            y = gety xy
+            -- y² = x³ + 7 (mod p)
+            y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            -}
+            secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
+            ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
+            -- pub = cannonical_eckey x y
+            -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
+            -- address = base58_encode hash
+            -- pubstr = concatMap (printf "%02x") $ pub
+            -- _ = pubstr :: String
+        return $ {- trace (unlines ["pub="++show pubstr
+                                ,"add="++show address
+                                ,"y  ="++show y
+                                ,"y' ="++show y'
+                                ,"y''="++show y'']) -}
+            SecretKeyPacket
+            { version = 4
+            , timestamp = toEnum (fromEnum timestamp)
+            , key_algorithm = ECDSA
+            , key = [ -- public fields...
+                     ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
+                    ,('l',MPI 256)
+                    ,('x',MPI x)
+                    ,('y',MPI y)
+                    -- secret fields
+                    ,('d',MPI d)
+                    ]
+            , s2k_useage = 0
+            , s2k = S2K 100 ""
+            , symmetric_algorithm = Unencrypted
+            , encrypted_data = ""
+            , is_subkey = True
+            }
+
+rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
+rsaKeyFromPacket p | isKey p = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
+
+rsaKeyFromPacket _ = Nothing
+
+
+readPacketsFromWallet ::
+    Maybe Packet
+    -> InputFile
+    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+readPacketsFromWallet wk fname = do
+    let ctx = InputFileContext "" ""
+    timestamp <- getInputFileTime ctx fname
+    input <- readInputFileL ctx fname
+    let (ks,_) = slurpWIPKeys timestamp input
+    unless (null ks) $ do
+        -- decrypt wk
+        -- create sigs
+        -- return key/sig pairs
+        return ()
+    return $ do
+        wk <- maybeToList wk
+        guard (not $ null ks)
+        let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
+                                where tag = CryptoCoins.nameFromSecretByte tagbyte
+        (wk,MarkerPacket,(MarkerPacket,Map.empty))
+         :map prep ks
+
+readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
+readPacketsFromFile ctx fname = do
+    -- warn $ fname ++ ": reading..."
+    input <- readInputFileL ctx fname
+#if MIN_VERSION_binary(0,7,0)
+    return $
+      case decodeOrFail input of
+        Right (_,_,msg ) -> msg
+        Left  (_,_,_)    ->
+          -- FIXME
+          -- trace (fname++": read fail") $
+          Message []
+#else
+    return $ decode input
+#endif
+
+-- | Get the time stamp of a signature.
+--
+-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
+-- the hashed section.  TODO: change this?
+--
+signature_time :: SignatureOver -> Word32
+signature_time ov = case (if null cs then ds else cs) of
+                                [] -> minBound
+                                xs -> maximum xs
+          where
+            ps = signatures_over ov
+            ss = filter isSignaturePacket ps
+            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
+            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
+            creationTime (SignatureCreationTimePacket t) = [t]
+            creationTime _                               = []
+
+splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
+splitAtMinBy comp xs = minimumBy comp' xxs
+ where
+    xxs = zip (inits xs) (tails xs)
+    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
+    compM (Just a) (Just b) = comp a b
+    compM Nothing  mb       = GT
+    compM _        _        = LT
+
+
+
+-- | Given list of subpackets, a master key, one of its subkeys and a
+-- list of signatures on that subkey, yields:
+--
+--   * preceding list of signatures
+--
+--   * The most recent valid signature made by the master key along with a
+--   flag that indicates whether or not all of the supplied subpackets occur in
+--   it or, if no valid signature from the working key is present, Nothing.
+--
+--   * following list of signatures
+--
+findTag ::
+  [SignatureSubpacket]
+  -> Packet
+  -> Packet
+  -> [(MappedPacket, b)]
+  -> ([(MappedPacket, b)],
+      Maybe (Bool, (MappedPacket, b)),
+      [(MappedPacket, b)])
+findTag tag topk subkey subsigs = (xs',minsig,ys')
+         where
+            vs = map (\sig ->
+                          (sig, do
+                                sig <- Just (packet . fst $ sig)
+                                guard (isSignaturePacket sig)
+                                guard $ flip isSuffixOf
+                                             (fingerprint topk)
+                                        . fromMaybe "%bad%" 
+                                        . signature_issuer
+                                        $ sig
+                                listToMaybe $
+                                  map (signature_time . verify (Message [topk]))
+                                      (signatures $ Message [topk,subkey,sig])))
+                     subsigs
+            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
+            xs' = map fst xs
+            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
+            minsig = do
+                (sig,ov) <- listToMaybe ys
+                ov
+                let hshed = hashed_subpackets $ packet $ fst sig
+                return ( null $ tag \\ hshed, sig)
+
+mkUsage :: String -> SignatureSubpacket
+mkUsage tag = NotationDataPacket
+                { human_readable = True
+                , notation_name = "usage@"
+                , notation_value = tag
+                }
+
+makeSig ::
+  (MappedPacket -> IO (KikiCondition Packet))
+  -> MappedPacket
+  -> [Char]
+  -> MappedPacket
+  -> [SignatureSubpacket]
+  -> Maybe (MappedPacket, Map.Map k a)
+  -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
+makeSig doDecrypt top fname subkey_p tags mbsig = do
+    let wk = packet top
+    wkun <- doDecrypt top
+    try wkun $ \wkun -> do
+    let grip = fingerprint wk
+        addOrigin new_sig =
+            flip (maybe $ return FailedToMakeSignature)
+                 (new_sig >>= listToMaybe . signatures_over)
+                 $ \new_sig -> do
+            let mp' = mappedPacket fname new_sig
+            return $ KikiSuccess (mp', Map.empty)
+        parsedkey = [packet subkey_p]
+        hashed0 = KeyFlagsPacket
+                    { certify_keys = False
+                    , sign_data = False
+                    , encrypt_communication = False
+                    , encrypt_storage = False
+                    , split_key = False
+                    , authentication = True
+                    , group_key = False }
+                    : tags
+                    -- implicitly added:
+                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
+        subgrip = fingerprint (head parsedkey)
+
+    back_sig <- pgpSign (Message parsedkey)
+                        (SubkeySignature wk
+                                         (head parsedkey)
+                                         (sigpackets 0x19
+                                                     hashed0
+                                                     [IssuerPacket subgrip]))
+                        (if key_algorithm (head parsedkey)==ECDSA
+                            then SHA256
+                            else SHA1)
+                        subgrip
+    let iss = IssuerPacket (fingerprint wk)
+        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
+        unhashed0 = maybe [iss] cons_iss back_sig
+
+    new_sig <- pgpSign (Message [wkun])
+                       (SubkeySignature wk
+                                        (head parsedkey)
+                                        (sigpackets 0x18
+                                                   hashed0
+                                                   unhashed0))
+                      SHA1
+                      grip
+    let newSig = do
+            r <- addOrigin new_sig
+            return $ fmap (,[]) r
+    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
+    let sig = packet mp
+        isCreation (SignatureCreationTimePacket {}) = True
+        isCreation _ = False
+        isExpiration (SignatureExpirationTimePacket {}) = True
+        isExpiration _ = False
+        (cs,ps) = partition isCreation (hashed_subpackets sig)
+        (es,qs) = partition isExpiration ps
+        stamp = listToMaybe . sortBy (comparing Down) $
+                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
+        exp = listToMaybe $ sort $
+                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
+        expires = liftA2 (+) stamp exp
+    timestamp <- now
+    if fmap ( (< timestamp) . fromIntegral) expires == Just True then
+        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
+    else do
+        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
+                        $ maybeToList $ do
+                            e <- expires
+                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
+            sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
+        new_sig <- pgpSign (Message [wkun])
+                           (SubkeySignature wk
+                                            (packet subkey_p)
+                                            [sig'] )
+                           SHA1
+                           (fingerprint wk)
+        newsig <- addOrigin new_sig
+        return $ fmap (,[]) newsig
+
+
+
+data OriginFlags = OriginFlags {
+        originallyPublic :: Bool,
+        originalNum :: Int
+    }
+    deriving Show
+type OriginMap = Map.Map FilePath OriginFlags
+data MappedPacket = MappedPacket
+        { packet :: Packet
+        , locations :: OriginMap
+        } deriving Show
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
+
+type KeyKey = [ByteString]
+data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
+
+-- | This is a GPG Identity which includes a master key and all its UIDs and
+-- subkeys and associated signatures.
+data KeyData = KeyData { keyMappedPacket :: MappedPacket    -- main key
+                       , keySigAndTrusts :: [SigAndTrust]  -- sigs on main key
+                       , keyUids :: (Map.Map String ([SigAndTrust],OriginMap))  -- uids
+                       , keySubKeys :: (Map.Map KeyKey SubKey)    -- subkeys
+                       } deriving Show
+
+type KeyDB = Map.Map KeyKey KeyData
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket :: FilePath -> Packet -> MappedPacket
+mappedPacket filename p = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
+keykey :: Packet -> KeyKey
+keykey key =
+    -- Note: The key's timestamp is normally included in it's fingerprint.
+    --       This is undesirable for kiki because it causes the same
+    --       key to be imported multiple times and show as apparently
+    --       distinct keys with different fingerprints.
+    --       Thus, we will remove the timestamp.
+    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
+
+uidkey :: Packet -> String
+uidkey (UserIDPacket str) = str
+
+merge :: KeyDB -> InputFile -> Message -> KeyDB
+merge db inputfile (Message ps) = merge_ db filename qs
+ where
+    filename = resolveForReport Nothing inputfile
+
+    qs = scanPackets filename ps
+
+    scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+    scanPackets filename [] = []
+    scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
+     where
+        ret p = (p,Map.empty)
+        doit (top,sub,prev) p =
+            case p of
+                _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
+                _ | isKey p && is_subkey p       -> (top,p,ret p)
+                _ | isUserID p                   -> (top,p,ret p)
+                _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
+                _                                -> (top,sub,ret p)
+
+        updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
+
+
+{-
+onionName :: KeyData -> (SockAddr,L.ByteString)
+onionName kd = (addr,name)
+ where
+    (addr,(name:_,_)) = getHostnames kd
+-}
+keyCompare :: String -> Packet -> Packet -> Ordering
+keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+keyCompare what a b | keykey a==keykey b = EQ
+keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
+                              , fingerprint a
+                              , PP.ppShow a
+                              , fingerprint b
+                              , PP.ppShow b
+                              ]
+
+mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
+mergeKeyPacket what key p = 
+    key { packet = minimumBy (keyCompare what) [packet key,packet p]
+        , locations = Map.union (locations key) (locations p)
+        }
+
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    asMapped n p = mappedPacketWithHint filename p n
+    asSigAndTrust n (p,tm) = (asMapped n p,tm)
+    emptyUids = Map.empty
+    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
+    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
+     where
+        -- NOTE:
+        --  if a keyring file has both a public key packet and a secret key packet
+        --  for the same key, then only one of them will survive, which ever is
+        --  later in the file.
+        --
+        --  This is due to the use of statements like
+        --      (Map.insert filename (origin p n) (locations key))
+        --
+        update :: Maybe KeyData -> Maybe KeyData
+        update v | isKey p && not (is_subkey p)
+          = case v of
+             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
+                     -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
+                                       sigs
+                                       uids
+                                       subkeys
+             _       -> error . concat $ ["Unexpected master key merge error: "
+                                         ,show (fingerprint top, fingerprint p)]
+        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
+          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
+        update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
+                                    subkeys
+        update (Just (KeyData key sigs uids subkeys))
+          = case sub of
+             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
+             UserIDPacket {} -> Just $ KeyData key
+                                               sigs
+                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               subkeys
+             _  | isKey sub  -> Just $ KeyData key
+                                               sigs
+                                               uids
+                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
+             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
+        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
+
+    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
+
+    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
+    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
+    mergeSubkey n p (Just (SubKey key sigs)) = Just $
+        SubKey (mergeKeyPacket "subs" key $ asMapped n p)
+               sigs
+
+    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
+    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
+    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
+    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
+
+    whatP (a,_) = concat . take 1 . words . show $ a
+
+
+    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
+    mergeSig n sig sigs =
+      let (xs,ys) = break (isSameSig sig) sigs
+      in if null ys
+          then sigs++[first (asMapped n) sig]
+          else let y:ys'=ys
+               in xs ++ (mergeSameSig n sig y : ys')
+     where
+        isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
+            a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
+        isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
+
+        mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
+        mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
+          | isSignaturePacket a && isSignaturePacket b =
+                ( m { packet = b { unhashed_subpackets =
+                                      union (unhashed_subpackets b) (unhashed_subpackets a)
+                                 }
+                   , locations = Map.insert filename (origin a n) locs }
+                -- TODO: when merging items, we should delete invalidated origins
+                -- from the orgin map.
+                , tb `Map.union` ta )
+
+        mergeSameSig n a b = b -- trace ("discarding dup "++show a) b
+
+    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
+    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
+
+    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
+    mergeSubSig n sig Nothing = error $
+        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
+
+unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
+unsig fname isPublic (sig,trustmap) =
+    sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
+  where
+    f n _ = n==fname -- && trace ("fname=n="++show n) True
+    asMapped n p = let m = mappedPacket fname p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
+
+concatSort ::
+  FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
+concatSort fname getp f = concat . sortByHint fname getp . map f
+
+sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
+sortByHint fname f = sortBy (comparing gethint)
+  where
+    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
+    defnum = -1
+
+flattenKeys :: Bool -> KeyDB -> Message
+flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
+ where
+    prefilter = if isPublic then id else filter isSecret
+                 where
+                  isSecret (_,(KeyData
+                                  (MappedPacket { packet=(SecretKeyPacket {})})
+                                  _
+                                  _
+                                  _)) = True
+                  isSecret _          = False
+
+
+flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
+flattenTop fname ispub (KeyData key sigs uids subkeys) =
+    unk ispub key :
+            ( flattenAllUids fname ispub uids
+             ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
+
+flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
+flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
+
+unk :: Bool -> MappedPacket -> MappedPacket
+unk isPublic = if isPublic then toPacket secretToPublic else id
+                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
+
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
+flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
+flattenUid fname ispub (str,(sigs,om)) =
+    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
+
+getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
+getCrossSignedSubkeys topk subs tag = do
+        SubKey k sigs <- Map.elems subs
+        let subk = packet k
+        let sigs' = do
+                torsig <- filter (has_tag tag) $ map (packet . fst) sigs
+                sig <- (signatures $ Message [topk,subk,torsig])
+                let v = verify (Message [topk]) sig
+                -- Require parent's signature
+                guard (not . null $ signatures_over v)
+                let unhashed = unhashed_subpackets torsig
+                    subsigs = mapMaybe backsig unhashed
+                    -- This should consist only of 0x19 values
+                    -- subtypes = map signature_type subsigs
+                sig' <- signatures . Message $ [topk,subk]++subsigs
+                let v' = verify (Message [subk]) sig'
+                -- Require subkey's signature
+                guard . not . null $ signatures_over v'
+                return torsig
+        guard (not $ null sigs')
+        return subk
+ where
+    has_tag tag p = isSignaturePacket p
+                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
+                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
+
+
+-- |
+-- Returns (ip6 fingerprint address,(onion names,other host names))
+--
+-- Requires a validly cross-signed tor key for each onion name returned.
+-- (Signature checks are performed.)
+getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
+getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
+ where
+    othernames = do
+        mp <- flattenAllUids "" True uids
+        let p = packet mp
+        guard $ isSignaturePacket p
+        uh <- unhashed_subpackets p
+        case uh of
+            NotationDataPacket True "hostname@" v
+              -> return $ Char8.pack v
+            _ -> mzero
+
+    addr = fingerdress topk
+    -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
+    topk = packet topmp
+    torkeys = getCrossSignedSubkeys topk subs "tor"
+
+    -- subkeyPacket (SubKey k _ ) = k
+    onames :: [L.ByteString]
+    onames = map ( (<> ".onion")
+                 . Char8.pack
+                 . take 16
+                 . torhash )
+                 torkeys
+
+hasFingerDress :: KeyDB -> SockAddr -> Bool
+hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
+hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
+ where
+    (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
+    g' = map toUpper g
+
+-- We return into IO in case we want to make a signature here.
+setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
+setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
+    -- TODO: we are removing the origin from the UID OriginMap,
+    --       when we should be removing origins from the locations
+    --       field of the sig's MappedPacket records.
+    -- Call getHostnames and compare to see if no-op.
+    if not (pred addr) || names0 == names \\ onions 
+        then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                             , "                   file: "++show (map Char8.unpack names)
+                             , "                   pred: "++show (pred addr)]) -}
+                    (return kd)
+        else do
+    -- We should be sure to remove origins so that the data is written
+    --   (but only if something changed).
+    -- Filter all hostnames present in uids
+    -- Write notations into first uid
+    {-
+    trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                   , "                    file: "++show (map Char8.unpack names) ]) $ do
+    -}
+    return $ KeyData topmp topsigs uids1 subs
+ where
+    topk = packet topmp
+    addr = fingerdress topk
+    names :: [Char8.ByteString]
+    names = Hosts.namesForAddress addr hosts
+    (_,(onions,names0)) = getHostnames kd
+    notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
+    isName (NotationDataPacket True "hostname@" _) = True
+    isName _ = False
+    uids0 = fmap zapIfHasName uids
+    fstuid = head $ do
+        p <- map packet $ flattenAllUids "" True uids
+        guard $ isUserID p
+        return $ uidkey p
+    uids1 = Map.adjust addnames fstuid uids0
+    addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
+     where
+        (ss,ts) = splitAt 1 sigs
+        f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
+                                                       else (sig, tm)
+         where p' = (packet sig) { unhashed_subpackets=uh }
+               uh = unhashed_subpackets (packet sig) ++ notations
+    zapIfHasName (sigs,om) = if or bs then (sigs',om)  -- XXX: removed om=Map.empty to preserve UserID origin
+                                      else (sigs,om)
+     where
+        (bs, sigs') = unzip $ map unhash sigs
+
+        unhash (sig,tm) = ( not (null ns)
+                          , ( sig { packet = p', locations = Map.empty }
+                            , tm ) )
+         where
+            psig = packet sig
+            p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
+                                           else psig
+            uh = unhashed_subpackets psig
+            (ns,ps) = partition isName uh
+
+fingerdress :: Packet -> SockAddr
+fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
+ where
+    zero = SockAddrInet 0 0
+    addr_str = colons $  "fd" ++ drop 10 (map toLower $ fingerprint topk)
+    colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
+    colons xs                 = xs
+
+backsig :: SignatureSubpacket -> Maybe Packet
+backsig (EmbeddedSignaturePacket s) = Just s
+backsig _                           = Nothing
+
+socketFamily :: SockAddr -> Family
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 {}) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+
+#if ! MIN_VERSION_unix(2,7,0)
+setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO ()
+setFdTimesHiRes (Posix.Fd fd) atime mtime =
+  withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+    throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times)
+
+data CTimeSpec = CTimeSpec Posix.EpochTime CLong
+instance Storable CTimeSpec where
+    sizeOf    _ = (16)
+    alignment _ = alignment (undefined :: CInt)
+    poke p (CTimeSpec sec nsec) = do
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec
+        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec
+    peek p = do
+        sec  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
+        nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
+        return $ CTimeSpec sec nsec
+
+toCTimeSpec :: POSIXTime -> CTimeSpec
+toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac)
+  where
+    (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
+    (sec', frac') = properFraction $ toRational t
+
+foreign import ccall unsafe "futimens"
+    c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt
+#endif
+
+onionNameForContact :: KeyKey -> KeyDB -> Maybe String
+onionNameForContact kk db = do
+    contact <- Map.lookup kk db
+    let (_,(name:_,_)) = getHostnames contact
+    return $ Char8.unpack name
diff --git a/lib/PEM.hs b/lib/PEM.hs
new file mode 100644
index 0000000..e07b3d4
--- /dev/null
+++ b/lib/PEM.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+module PEM where
+
+import Data.Monoid
+import qualified Data.ByteString.Lazy as LW
+import qualified Data.ByteString.Lazy.Char8 as L
+import Control.Monad
+import Control.Applicative
+import qualified Codec.Binary.Base64 as Base64
+import ScanningParser
+
+data PEMBlob = PEMBlob { pemType :: L.ByteString
+                       , pemBlob :: L.ByteString
+                       }
+ deriving (Eq,Show)
+
+pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
+ where
+    hdr typ = "-----BEGIN " <> typ <> "-----"
+    fndtyp typ bs = if bs==hdr typ then Just typ else Nothing
+    fndany bs = do
+        guard $ "-----BEGIN " `L.isPrefixOf` bs
+        let x0 = L.drop 11 bs
+        guard $ "-----" `LW.isSuffixOf` x0
+        let typ = L.take (L.length x0 - 5) x0
+        return typ
+
+    pbdy typ xs = (mblob, drop 1 rs)
+     where
+        (ys,rs) = span (/="-----END " <> typ <> "-----") xs
+        mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
+        dta = case ys of
+                []        -> ""
+                dta_lines -> L.concat dta_lines
diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs
new file mode 100644
index 0000000..4e3ac38
--- /dev/null
+++ b/lib/ProcessUtils.hs
@@ -0,0 +1,45 @@
+module ProcessUtils
+    ( ExitCode(ExitFailure,ExitSuccess)
+    , systemEnv
+    ) where
+
+import GHC.IO.Exception ( ioException, IOErrorType(..) )
+import System.Process
+import System.Posix.Signals
+import System.Process.Internals (runGenProcess_,defaultSignal)
+import System.Environment
+import Data.Maybe ( isNothing )
+import System.IO.Error ( mkIOError, ioeSetErrorString ) 
+import System.Exit ( ExitCode(..) )
+
+
+-- | systemEnv
+-- This is like System.Process.system except that it lets you set
+-- some environment variables.
+systemEnv :: [(String, String)] -> String -> IO ExitCode
+systemEnv _    ""  = 
+    ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
+systemEnv vars cmd = do
+    env0 <- getEnvironment
+    let env1 = filter (isNothing . flip lookup vars . fst) env0
+        env = vars ++ env1
+    syncProcess "system" $ (shell cmd) {env=Just env}
+ where
+    -- This is a non-exported function from System.Process
+    syncProcess fun c = do
+      -- The POSIX version of system needs to do some manipulation of signal
+      -- handlers.  Since we're going to be synchronously waiting for the child,
+      -- we want to ignore ^C in the parent, but handle it the default way
+      -- in the child (using SIG_DFL isn't really correct, it should be the
+      -- original signal handler, but the GHC RTS will have already set up
+      -- its own handler and we don't want to use that).
+      old_int  <- installHandler sigINT  Ignore Nothing
+      old_quit <- installHandler sigQUIT Ignore Nothing
+      (_,_,_,p) <- runGenProcess_ fun c
+            (Just defaultSignal) (Just defaultSignal)
+      r <- waitForProcess p
+      _ <- installHandler sigINT  old_int Nothing
+      _ <- installHandler sigQUIT old_quit Nothing
+      return r
+
+
diff --git a/lib/ScanningParser.hs b/lib/ScanningParser.hs
new file mode 100644
index 0000000..f99e120
--- /dev/null
+++ b/lib/ScanningParser.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module ScanningParser
+ ( ScanningParser(..)
+ , scanAndParse
+ , scanAndParse1
+ ) where
+
+import Data.Maybe
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+-- | This type provides the means to parse a stream of 'tok' and extract all
+-- the 'obj' parses that occur.
+--
+-- Use Functor and Monoid interfaces to combine parsers.  For example,
+--
+-- > parserAorB = fmap Left parserA <> fmap Right parserB
+--
+data ScanningParser tok obj = forall partial. ScanningParser
+    { findFirst :: tok -> Maybe partial
+    -- ^ If the token starts an object, returns a partial parse.
+    , parseBody :: partial -> [tok] -> (Maybe obj,[tok])
+    -- ^ Given a partial parse and the stream of tokens that follow, attempt to
+    -- parse an object and return the unconsumed tokens.
+    }
+
+instance Functor (ScanningParser a) where
+    fmap f (ScanningParser ffst pbody)
+        = ScanningParser ffst (\b -> first (fmap f) . pbody b)
+     where
+        first f (x,y) = (f x, y)
+
+
+instance Monoid (ScanningParser a b) where
+    mempty = ScanningParser (const Nothing) (const $ const (Nothing,[]))
+    mappend (ScanningParser ffstA pbdyA)
+            (ScanningParser ffstB pbdyB)
+     = ScanningParser ffst pbody
+     where
+        ffst x = mplus (Left  <$> ffstA x)
+                       (Right <$> ffstB x)
+        pbody (Left apart)  = pbdyA apart
+        pbody (Right bpart) = pbdyB bpart
+
+
+-- | Apply a 'ScanningParser' to a list of tokens, yielding a list of parsed
+-- objects.
+scanAndParse :: ScanningParser a c -> [a] -> [c]
+scanAndParse psr [] = []
+scanAndParse psr@(ScanningParser ffst pbdy) ts = do
+    (b,xs) <- take 1 $ mapMaybe findfst' tss
+    let (mc,ts') = pbdy b xs
+        rec = scanAndParse psr ts'
+    maybe rec (:rec) mc
+ where
+    tss = tails ts
+    findfst' ts = do
+        x <- listToMaybe ts
+        b <- ffst x
+        return (b,drop 1 ts)
+
+scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a])
+scanAndParse1 psr@(ScanningParser ffst pbdy) ts = 
+    maybe (Nothing,[]) (uncurry pbdy) mb
+ where
+    mb = listToMaybe $ mapMaybe findfst' tss
+    tss = tails ts
+    findfst' ts = do
+        x <- listToMaybe ts
+        b <- ffst x
+        return (b,drop 1 ts)
diff --git a/lib/TimeUtil.hs b/lib/TimeUtil.hs
new file mode 100644
index 0000000..879bc32
--- /dev/null
+++ b/lib/TimeUtil.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
+module TimeUtil
+    ( now
+    , IsTime(..)
+    , fromTime
+    , toUTC
+    , parseRFC2822
+    , printRFC2822
+    , dateParser
+    ) where
+
+import Data.Time.LocalTime
+import Data.Time.Format
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+#if !MIN_VERSION_time(1,5,0)
+import System.Locale (defaultTimeLocale)
+#endif
+import Data.String
+import Control.Applicative
+import Data.Maybe
+import Data.Char
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import Foreign.C.Types ( CTime(..) )
+import Data.Word ( Word32 )
+
+import ScanningParser
+
+class IsTime a where
+    fromZonedTime :: ZonedTime -> a
+    toZonedTime :: a -> IO ZonedTime
+
+instance IsTime ZonedTime where
+    fromZonedTime x = x
+    toZonedTime x = return x
+
+instance IsTime UTCTime where
+    toZonedTime t = utcToLocalZonedTime t
+    fromZonedTime zt = zonedTimeToUTC zt
+
+instance IsTime Integer where
+    toZonedTime t = utcToLocalZonedTime utime
+     where
+        utime = posixSecondsToUTCTime (fromIntegral t)
+    fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime
+     where
+        utime = zonedTimeToUTC zt
+
+printRFC2822 :: (IsString b, IsTime a) => a -> IO b
+printRFC2822 tm = do
+    zt@(ZonedTime lt z) <- toZonedTime tm
+    let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone
+        timeZoneStr = timeZoneOffsetString z
+        printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")"
+    return $ fromString $ rfc2822
+
+parseRFC2822 :: IsTime b => S.ByteString -> Maybe b
+parseRFC2822 str =
+    case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of
+        []     -> Nothing
+        (zt:_) -> Just $ fromZonedTime zt
+ where
+    str' = S.unpack stripped
+    stripped = strip $ str
+    strip bs = bs3
+     where
+        (_,bs0) = S.span isSpace bs
+        (bs1,_) = S.spanEnd isSpace bs0
+        (bs2,cp) = S.spanEnd (==')') bs1
+        bs3 = if S.null cp
+                then bs2
+                else let (op,_) = S.spanEnd (/='(') bs2
+                     in fst $ S.spanEnd isSpace $ S.init op
+    formatRFC2822 = [ "%a, %e %b %Y %T GMT"
+                    , "%a, %e %b %Y %T %z"
+                    , "%e %b %Y %T GMT"
+                    , "%e %b %Y %T %z"
+                    , "%a, %e %b %Y %R GMT"
+                    , "%a, %e %b %Y %R %z"
+                    , "%e %b %Y %R GMT"
+                    , "%e %b %Y %R %z"
+                    ]
+
+now :: IO Integer
+now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
+
+dateParser :: ScanningParser L.ByteString UTCTime
+dateParser = ScanningParser ffst pbdy
+ where
+    ffst bs = do
+        let (h,bs') = L.splitAt 6 bs
+        if h=="Date: "
+          then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs'
+          else Nothing
+    pbdy date xs = (date,xs)
+
+class IsUTC a where
+    fromUTC :: UTCTime -> a
+    toUTC :: a -> UTCTime
+
+fromTime :: ( IsUTC a, IsUTC b ) => a -> b
+fromTime = fromUTC . toUTC
+
+instance IsUTC UTCTime where
+    fromUTC = id
+    toUTC = id
+
+instance IsUTC CTime where
+    fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc)
+    toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t)
+
+instance IsUTC Word32 where
+    fromUTC utc = round $ utcTimeToPOSIXSeconds utc
+    toUTC t = posixSecondsToUTCTime (realToFrac t)
+
+{-
+main = do
+    nowtime <- now
+    printRFC2822 nowtime >>= putStrLn
+    let test1 = "Thu, 08 May 2014 23:24:47 -0400"
+        test2 = " Thu,    08 May 2014 23:24:47 -0400 (EDT) "
+    putStrLn $ show (parseRFC2822 test1 :: Maybe Integer)
+    putStrLn $ show (parseRFC2822 test2 :: Maybe Integer)
+    return ()
+-}
diff --git a/lib/dotlock.c b/lib/dotlock.c
new file mode 100644
index 0000000..c111159
--- /dev/null
+++ b/lib/dotlock.c
@@ -0,0 +1,1303 @@
+/* dotlock.c - dotfile locking
+ * Copyright (C) 1998, 2000, 2001, 2003, 2004,
+ *               2005, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This file is part of JNLIB, which is a subsystem of GnuPG.
+ *
+ * JNLIB is free software; you can redistribute it and/or modify it
+ * under the terms of either
+ *
+ *   - the GNU Lesser General Public License as published by the Free
+ *     Software Foundation; either version 3 of the License, or (at
+ *     your option) any later version.
+ *
+ * or
+ *
+ *   - the GNU General Public License as published by the Free
+ *     Software Foundation; either version 2 of the License, or (at
+ *     your option) any later version.
+ *
+ * or both in parallel, as here.
+ *
+ * JNLIB is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copies of the GNU General Public License
+ * and the GNU Lesser General Public License along with this program;
+ * if not, see <http://www.gnu.org/licenses/>.
+ *
+ * ALTERNATIVELY, this file may be distributed under the terms of the
+ * following license, in which case the provisions of this license are
+ * required INSTEAD OF the GNU Lesser General License or the GNU
+ * General Public License. If you wish to allow use of your version of
+ * this file only under the terms of the GNU Lesser General License or
+ * the GNU General Public License, and not to allow others to use your
+ * version of this file under the terms of the following license,
+ * indicate your decision by deleting this paragraph and the license
+ * below.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, and the entire permission notice in its entirety,
+ *    including the disclaimer of warranties.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. The name of the author may not be used to endorse or promote
+ *    products derived from this software without specific prior
+ *    written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
+ * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ * DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+/*
+   Overview:
+   =========
+
+   This module implements advisory file locking in a portable way.
+   Due to the problems with POSIX fcntl locking a separate lock file
+   is used.  It would be possible to use fcntl locking on this lock
+   file and thus avoid the weird auto unlock bug of POSIX while still
+   having an unproved better performance of fcntl locking.  However
+   there are still problems left, thus we resort to use a hardlink
+   which has the well defined property that a link call will fail if
+   the target file already exists.
+
+   Given that hardlinks are also available on NTFS file systems since
+   Windows XP; it will be possible to enhance this module to use
+   hardlinks even on Windows and thus allow Windows and Posix clients
+   to use locking on the same directory.  This is not yet implemented;
+   instead we use a lockfile on Windows along with W32 style file
+   locking.
+
+   On FAT file systems hardlinks are not supported.  Thus this method
+   does not work.  Our solution is to use a O_EXCL locking instead.
+   Querying the type of the file system is not easy to do in a
+   portable way (e.g. Linux has a statfs, BSDs have a the same call
+   but using different structures and constants).  What we do instead
+   is to check at runtime whether link(2) works for a specific lock
+   file.
+
+
+   How to use:
+   ===========
+
+   At program initialization time, the module should be explicitly
+   initialized:
+
+      dotlock_create (NULL, 0);
+
+   This installs an atexit handler and may also initialize mutex etc.
+   It is optional for non-threaded applications.  Only the first call
+   has an effect.  This needs to be done before any extra threads are
+   started.
+
+   To create a lock file (which  prepares it but does not take the
+   lock) you do:
+
+     dotlock_t h
+
+     h = dotlock_create (fname, 0);
+     if (!h)
+       error ("error creating lock file: %s\n", strerror (errno));
+
+   It is important to handle the error.  For example on a read-only
+   file system a lock can't be created (but is usually not needed).
+   FNAME is the file you want to lock; the actual lockfile is that
+   name with the suffix ".lock" appended.  On success a handle to be
+   used with the other functions is returned or NULL on error.  Note
+   that the handle shall only be used by one thread at a time.  This
+   function creates a unique file temporary file (".#lk*") in the same
+   directory as FNAME and returns a handle for further operations.
+   The module keeps track of theses unique files so that they will be
+   unlinked using the atexit handler.  If you don't need the lock file
+   anymore, you may also explicitly remove it with a call to:
+
+     dotlock_destroy (h);
+
+   To actually lock the file, you use:
+
+     if (dotlock_take (h, -1))
+       error ("error taking lock: %s\n", strerror (errno));
+
+   This function will wait until the lock is acquired.  If an
+   unexpected error occurs if will return non-zero and set ERRNO.  If
+   you pass (0) instead of (-1) the function does not wait in case the
+   file is already locked but returns -1 and sets ERRNO to EACCES.
+   Any other positive value for the second parameter is considered a
+   timeout valuie in milliseconds.
+
+   To release the lock you call:
+
+     if (dotlock_release (h))
+       error ("error releasing lock: %s\n", strerror (errno));
+
+   or, if the lock file is not anymore needed, you may just call
+   dotlock_destroy.  However dotlock_release does some extra checks
+   before releasing the lock and prints diagnostics to help detecting
+   bugs.
+
+   If you want to explicitly destroy all lock files you may call
+
+     dotlock_remove_lockfiles ();
+
+   which is the core of the installed atexit handler.  In case your
+   application wants to disable locking completely it may call
+
+     disable_locking ()
+
+   before any locks are created.
+
+   There are two convenience functions to store an integer (e.g. a
+   file descriptor) value with the handle:
+
+     void dotlock_set_fd (dotlock_t h, int fd);
+     int  dotlock_get_fd (dotlock_t h);
+
+   If nothing has been stored dotlock_get_fd returns -1.
+
+
+
+   How to build:
+   =============
+
+   This module was originally developed for GnuPG but later changed to
+   allow its use without any GnuPG dependency.  If you want to use it
+   with you application you may simply use it and it should figure out
+   most things automagically.
+
+   You may use the common config.h file to pass macros, but take care
+   to pass -DHAVE_CONFIG_H to the compiler.  Macros used by this
+   module are:
+
+     DOTLOCK_USE_PTHREAD  - Define if POSIX threads are in use.
+
+     DOTLOCK_GLIB_LOGGING - Define this to use Glib logging functions.
+
+     DOTLOCK_EXT_SYM_PREFIX - Prefix all external symbols with the
+                              string to which this macro evaluates.
+
+     GNUPG_MAJOR_VERSION - Defined when used by GnuPG.
+
+     HAVE_DOSISH_SYSTEM  - Defined for Windows etc.  Will be
+                           automatically defined if a the target is
+                           Windows.
+
+     HAVE_POSIX_SYSTEM   - Internally defined to !HAVE_DOSISH_SYSTEM.
+
+     HAVE_SIGNAL_H       - Should be defined on Posix systems.  If config.h
+                           is not used defaults to defined.
+
+     DIRSEP_C            - Separation character for file name parts.
+                           Usually not redefined.
+
+     EXTSEP_S            - Separation string for file name suffixes.
+                           Usually not redefined.
+
+     HAVE_W32CE_SYSTEM   - Currently only used by GnuPG.
+
+   Note that there is a test program t-dotlock which has compile
+   instructions at its end.  At least for SMBFS and CIFS it is
+   important that 64 bit versions of stat are used; most programming
+   environments do this these days, just in case you want to compile
+   it on the command line, remember to pass -D_FILE_OFFSET_BITS=64
+
+
+   Bugs:
+   =====
+
+   On Windows this module is not yet thread-safe.
+
+
+   Miscellaneous notes:
+   ====================
+
+   On hardlinks:
+   - Hardlinks are supported under Windows with NTFS since XP/Server2003.
+   - In Linux 2.6.33 both SMBFS and CIFS seem to support hardlinks.
+   - NFS supports hard links.  But there are solvable problems.
+   - FAT does not support links
+
+   On the file locking API:
+   - CIFS on Linux 2.6.33 supports several locking methods.
+     SMBFS seems not to support locking.  No closer checks done.
+   - NFS supports Posix locks.  flock is emulated in the server.
+     However there are a couple of problems; see below.
+   - FAT does not support locks.
+   - An advantage of fcntl locking is that R/W locks can be
+     implemented which is not easy with a straight lock file.
+
+   On O_EXCL:
+   - Does not work reliable on NFS
+   - Should work on CIFS and SMBFS but how can we delete lockfiles?
+
+   On NFS problems:
+   - Locks vanish if the server crashes and reboots.
+   - Client crashes keep the lock in the server until the client
+     re-connects.
+   - Communication problems may return unreliable error codes.  The
+     MUA Postfix's workaround is to compare the link count after
+     seeing an error for link.  However that gives a race.  If using a
+     unique file to link to a lockfile and using stat to check the
+     link count instead of looking at the error return of link(2) is
+     the best solution.
+   - O_EXCL seems to have a race and may re-create a file anyway.
+
+*/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* Some quick replacements for stuff we usually expect to be defined
+   in config.h.  Define HAVE_POSIX_SYSTEM for better readability. */
+#if !defined (HAVE_DOSISH_SYSTEM) && defined(_WIN32)
+# define HAVE_DOSISH_SYSTEM 1
+#endif
+#if !defined (HAVE_DOSISH_SYSTEM) && !defined (HAVE_POSIX_SYSTEM)
+# define HAVE_POSIX_SYSTEM 1
+#endif
+
+/* With no config.h assume that we have sitgnal.h.  */
+#if !defined (HAVE_CONFIG_H) && defined (HAVE_POSIX_SYSTEM)
+# define HAVE_SIGNAL_H 1
+#endif
+
+/* Standard headers.  */
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+#include <ctype.h>
+#include <errno.h>
+#include <unistd.h>
+#ifdef  HAVE_DOSISH_SYSTEM
+# define WIN32_LEAN_AND_MEAN  /* We only need the OS core stuff.  */
+# include <windows.h>
+#else
+# include <sys/types.h>
+# include <sys/stat.h>
+# include <sys/utsname.h>
+#endif
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#ifdef HAVE_SIGNAL_H
+# include <signal.h>
+#endif
+#ifdef DOTLOCK_USE_PTHREAD
+# include <pthread.h>
+#endif
+
+#ifdef DOTLOCK_GLIB_LOGGING
+# include <glib.h>
+#endif
+
+#ifdef GNUPG_MAJOR_VERSION
+# include "libjnlib-config.h"
+#endif
+#ifdef HAVE_W32CE_SYSTEM
+# include "utf8conv.h"  /* WindowsCE requires filename conversion.  */
+#endif
+
+#include "dotlock.h"
+
+
+/* Define constants for file name construction.  */
+#if !defined(DIRSEP_C) && !defined(EXTSEP_S)
+# ifdef HAVE_DOSISH_SYSTEM
+#  define DIRSEP_C '\\'
+#  define EXTSEP_S "."
+#else
+#  define DIRSEP_C '/'
+#  define EXTSEP_S "."
+# endif
+#endif
+
+/* In GnuPG we use wrappers around the malloc fucntions.  If they are
+   not defined we assume that this code is used outside of GnuPG and
+   fall back to the regular malloc functions.  */
+#ifndef jnlib_malloc
+# define jnlib_malloc(a)     malloc ((a))
+# define jnlib_calloc(a,b)   calloc ((a), (b))
+# define jnlib_free(a)       free ((a))
+#endif
+
+/* Wrapper to set ERRNO.  */
+#ifndef jnlib_set_errno
+# ifdef HAVE_W32CE_SYSTEM
+#  define jnlib_set_errno(e)  gpg_err_set_errno ((e))
+# else
+#  define jnlib_set_errno(e)  do { errno = (e); } while (0)
+# endif
+#endif
+
+/* Gettext macro replacement.  */
+#ifndef _
+# define _(a) (a)
+#endif
+
+#ifdef GNUPG_MAJOR_VERSION
+# define my_info_0(a)       log_info ((a))
+# define my_info_1(a,b)     log_info ((a), (b))
+# define my_info_2(a,b,c)   log_info ((a), (b), (c))
+# define my_info_3(a,b,c,d) log_info ((a), (b), (c), (d))
+# define my_error_0(a)      log_error ((a))
+# define my_error_1(a,b)    log_error ((a), (b))
+# define my_error_2(a,b,c)  log_error ((a), (b), (c))
+# define my_debug_1(a,b)    log_debug ((a), (b))
+# define my_fatal_0(a)      log_fatal ((a))
+#elif defined (DOTLOCK_GLIB_LOGGING)
+# define my_info_0(a)       g_message ((a))
+# define my_info_1(a,b)     g_message ((a), (b))
+# define my_info_2(a,b,c)   g_message ((a), (b), (c))
+# define my_info_3(a,b,c,d) g_message ((a), (b), (c), (d))
+# define my_error_0(a)      g_warning ((a))
+# define my_error_1(a,b)    g_warning ((a), (b))
+# define my_error_2(a,b,c)  g_warning ((a), (b), (c))
+# define my_debug_1(a,b)    g_debug ((a), (b))
+# define my_fatal_0(a)      g_error ((a))
+#else
+# define my_info_0(a)       fprintf (stderr, (a))
+# define my_info_1(a,b)     fprintf (stderr, (a), (b))
+# define my_info_2(a,b,c)   fprintf (stderr, (a), (b), (c))
+# define my_info_3(a,b,c,d) fprintf (stderr, (a), (b), (c), (d))
+# define my_error_0(a)      fprintf (stderr, (a))
+# define my_error_1(a,b)    fprintf (stderr, (a), (b))
+# define my_error_2(a,b,c)  fprintf (stderr, (a), (b), (c))
+# define my_debug_1(a,b)    fprintf (stderr, (a), (b))
+# define my_fatal_0(a)      do { fprintf (stderr,(a)); fflush (stderr); \
+                                 abort (); } while (0)
+#endif
+
+
+
+
+
+/* The object describing a lock.  */
+struct dotlock_handle
+{
+  struct dotlock_handle *next;
+  char *lockname;            /* Name of the actual lockfile.          */
+  unsigned int locked:1;     /* Lock status.                          */
+  unsigned int disable:1;    /* If true, locking is disabled.         */
+  unsigned int use_o_excl:1; /* Use open (O_EXCL) for locking.        */
+
+  int extra_fd;              /* A place for the caller to store an FD.  */
+
+#ifdef HAVE_DOSISH_SYSTEM
+  HANDLE lockhd;       /* The W32 handle of the lock file.      */
+#else /*!HAVE_DOSISH_SYSTEM */
+  char *tname;         /* Name of the lockfile template.        */
+  size_t nodename_off; /* Offset in TNAME of the nodename part. */
+  size_t nodename_len; /* Length of the nodename part.          */
+#endif /*!HAVE_DOSISH_SYSTEM */
+};
+
+
+/* A list of of all lock handles.  The volatile attribute might help
+   if used in an atexit handler.  */
+static volatile dotlock_t all_lockfiles;
+#ifdef DOTLOCK_USE_PTHREAD
+static pthread_mutex_t all_lockfiles_mutex = PTHREAD_MUTEX_INITIALIZER;
+# define LOCK_all_lockfiles() do {                               \
+        if (pthread_mutex_lock (&all_lockfiles_mutex))           \
+          my_fatal_0 ("locking all_lockfiles_mutex failed\n");   \
+      } while (0)
+# define UNLOCK_all_lockfiles() do {                             \
+        if (pthread_mutex_unlock (&all_lockfiles_mutex))         \
+          my_fatal_0 ("unlocking all_lockfiles_mutex failed\n"); \
+      } while (0)
+#else  /*!DOTLOCK_USE_PTHREAD*/
+# define LOCK_all_lockfiles()   do { } while (0)
+# define UNLOCK_all_lockfiles() do { } while (0)
+#endif /*!DOTLOCK_USE_PTHREAD*/
+
+/* If this has the value true all locking is disabled.  */
+static int never_lock;
+
+
+
+
+
+/* Entirely disable all locking.  This function should be called
+   before any locking is done.  It may be called right at startup of
+   the process as it only sets a global value.  */
+void
+dotlock_disable (void)
+{
+  never_lock = 1;
+}
+
+
+#ifdef HAVE_POSIX_SYSTEM
+static int
+maybe_deadlock (dotlock_t h)
+{
+  dotlock_t r;
+  int res = 0;
+
+  LOCK_all_lockfiles ();
+  for (r=all_lockfiles; r; r = r->next)
+    {
+      if ( r != h && r->locked )
+        {
+          res = 1;
+          break;
+        }
+    }
+  UNLOCK_all_lockfiles ();
+  return res;
+}
+#endif /*HAVE_POSIX_SYSTEM*/
+
+
+/* Read the lock file and return the pid, returns -1 on error.  True
+   will be stored in the integer at address SAME_NODE if the lock file
+   has been created on the same node. */
+#ifdef HAVE_POSIX_SYSTEM
+static int
+read_lockfile (dotlock_t h, int *same_node )
+{
+  char buffer_space[10+1+70+1]; /* 70 is just an estimated value; node
+                                   names are usually shorter. */
+  int fd;
+  int pid = -1;
+  char *buffer, *p;
+  size_t expected_len;
+  int res, nread;
+
+  *same_node = 0;
+  expected_len = 10 + 1 + h->nodename_len + 1;
+  if ( expected_len >= sizeof buffer_space)
+    {
+      buffer = jnlib_malloc (expected_len);
+      if (!buffer)
+        return -1;
+    }
+  else
+    buffer = buffer_space;
+
+  if ( (fd = open (h->lockname, O_RDONLY)) == -1 )
+    {
+      int e = errno;
+      my_info_2 ("error opening lockfile '%s': %s\n",
+                 h->lockname, strerror(errno) );
+      if (buffer != buffer_space)
+        jnlib_free (buffer);
+      jnlib_set_errno (e); /* Need to return ERRNO here. */
+      return -1;
+    }
+
+  p = buffer;
+  nread = 0;
+  do
+    {
+      res = read (fd, p, expected_len - nread);
+      if (res == -1 && errno == EINTR)
+        continue;
+      if (res < 0)
+        {
+          my_info_1 ("error reading lockfile '%s'\n", h->lockname );
+          close (fd);
+          if (buffer != buffer_space)
+            jnlib_free (buffer);
+          jnlib_set_errno (0); /* Do not return an inappropriate ERRNO. */
+          return -1;
+        }
+      p += res;
+      nread += res;
+    }
+  while (res && nread != expected_len);
+  close(fd);
+
+  if (nread < 11)
+    {
+      my_info_1 ("invalid size of lockfile '%s'\n", h->lockname);
+      if (buffer != buffer_space)
+        jnlib_free (buffer);
+      jnlib_set_errno (0); /* Better don't return an inappropriate ERRNO. */
+      return -1;
+    }
+
+  if (buffer[10] != '\n'
+      || (buffer[10] = 0, pid = atoi (buffer)) == -1
+      || !pid )
+    {
+      my_error_2 ("invalid pid %d in lockfile '%s'\n", pid, h->lockname);
+      if (buffer != buffer_space)
+        jnlib_free (buffer);
+      jnlib_set_errno (0);
+      return -1;
+    }
+
+  if (nread == expected_len
+      && !memcmp (h->tname+h->nodename_off, buffer+11, h->nodename_len)
+      && buffer[11+h->nodename_len] == '\n')
+    *same_node = 1;
+
+  if (buffer != buffer_space)
+    jnlib_free (buffer);
+  return pid;
+}
+#endif /*HAVE_POSIX_SYSTEM */
+
+
+/* Check whether the file system which stores TNAME supports
+   hardlinks.  Instead of using the non-portable statsfs call which
+   differs between various Unix versions, we do a runtime test.
+   Returns: 0 supports hardlinks; 1 no hardlink support, -1 unknown
+   (test error).  */
+#ifdef HAVE_POSIX_SYSTEM
+static int
+use_hardlinks_p (const char *tname)
+{
+  char *lname;
+  struct stat sb;
+  unsigned int nlink;
+  int res;
+
+  if (stat (tname, &sb))
+    return -1;
+  nlink = (unsigned int)sb.st_nlink;
+
+  lname = jnlib_malloc (strlen (tname) + 1 + 1);
+  if (!lname)
+    return -1;
+  strcpy (lname, tname);
+  strcat (lname, "x");
+
+  /* We ignore the return value of link() because it is unreliable.  */
+  (void) link (tname, lname);
+
+  if (stat (tname, &sb))
+    res = -1;  /* Ooops.  */
+  else if (sb.st_nlink == nlink + 1)
+    res = 0;   /* Yeah, hardlinks are supported.  */
+  else
+    res = 1;   /* No hardlink support.  */
+
+  unlink (lname);
+  jnlib_free (lname);
+  return res;
+}
+#endif /*HAVE_POSIX_SYSTEM */
+
+
+
+#ifdef  HAVE_POSIX_SYSTEM
+/* Locking core for Unix.  It used a temporary file and the link
+   system call to make locking an atomic operation. */
+static dotlock_t
+dotlock_create_unix (dotlock_t h, const char *file_to_lock)
+{
+  int  fd = -1;
+  char pidstr[16];
+  const char *nodename;
+  const char *dirpart;
+  int dirpartlen;
+  struct utsname utsbuf;
+  size_t tnamelen;
+
+  snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid() );
+
+  /* Create a temporary file. */
+  if ( uname ( &utsbuf ) )
+    nodename = "unknown";
+  else
+    nodename = utsbuf.nodename;
+
+  if ( !(dirpart = strrchr (file_to_lock, DIRSEP_C)) )
+    {
+      dirpart = EXTSEP_S;
+      dirpartlen = 1;
+    }
+  else
+    {
+      dirpartlen = dirpart - file_to_lock;
+      dirpart = file_to_lock;
+    }
+
+  LOCK_all_lockfiles ();
+  h->next = all_lockfiles;
+  all_lockfiles = h;
+
+  tnamelen = dirpartlen + 6 + 30 + strlen(nodename) + 10 + 1;
+  h->tname = jnlib_malloc (tnamelen + 1);
+  if (!h->tname)
+    {
+      all_lockfiles = h->next;
+      UNLOCK_all_lockfiles ();
+      jnlib_free (h);
+      return NULL;
+    }
+  h->nodename_len = strlen (nodename);
+
+  snprintf (h->tname, tnamelen, "%.*s/.#lk%p.", dirpartlen, dirpart, h );
+  h->nodename_off = strlen (h->tname);
+  snprintf (h->tname+h->nodename_off, tnamelen - h->nodename_off,
+           "%s.%d", nodename, (int)getpid ());
+
+  do
+    {
+      jnlib_set_errno (0);
+      fd = open (h->tname, O_WRONLY|O_CREAT|O_EXCL,
+                 S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR );
+    }
+  while (fd == -1 && errno == EINTR);
+
+  if ( fd == -1 )
+    {
+      all_lockfiles = h->next;
+      UNLOCK_all_lockfiles ();
+      my_error_2 (_("failed to create temporary file '%s': %s\n"),
+                  h->tname, strerror(errno));
+      jnlib_free (h->tname);
+      jnlib_free (h);
+      return NULL;
+    }
+  if ( write (fd, pidstr, 11 ) != 11 )
+    goto write_failed;
+  if ( write (fd, nodename, strlen (nodename) ) != strlen (nodename) )
+    goto write_failed;
+  if ( write (fd, "\n", 1 ) != 1 )
+    goto write_failed;
+  if ( close (fd) )
+    goto write_failed;
+
+  /* Check whether we support hard links.  */
+  switch (use_hardlinks_p (h->tname))
+    {
+    case 0: /* Yes.  */
+      break;
+    case 1: /* No.  */
+      unlink (h->tname);
+      h->use_o_excl = 1;
+      break;
+    default:
+      my_error_2 ("can't check whether hardlinks are supported for '%s': %s\n",
+                  h->tname, strerror(errno));
+      goto write_failed;
+    }
+
+  h->lockname = jnlib_malloc (strlen (file_to_lock) + 6 );
+  if (!h->lockname)
+    {
+      all_lockfiles = h->next;
+      UNLOCK_all_lockfiles ();
+      unlink (h->tname);
+      jnlib_free (h->tname);
+      jnlib_free (h);
+      return NULL;
+    }
+  strcpy (stpcpy (h->lockname, file_to_lock), EXTSEP_S "lock");
+  UNLOCK_all_lockfiles ();
+  if (h->use_o_excl)
+    my_debug_1 ("locking for '%s' done via O_EXCL\n", h->lockname);
+
+  return h;
+
+ write_failed:
+  all_lockfiles = h->next;
+  UNLOCK_all_lockfiles ();
+  my_error_2 (_("error writing to '%s': %s\n"), h->tname, strerror (errno));
+  close (fd);
+  unlink (h->tname);
+  jnlib_free (h->tname);
+  jnlib_free (h);
+  return NULL;
+}
+#endif /*HAVE_POSIX_SYSTEM*/
+
+
+#ifdef HAVE_DOSISH_SYSTEM
+/* Locking core for Windows.  This version does not need a temporary
+   file but uses the plain lock file along with record locking.  We
+   create this file here so that we later only need to do the file
+   locking.  For error reporting it is useful to keep the name of the
+   file in the handle.  */
+static dotlock_t
+dotlock_create_w32 (dotlock_t h, const char *file_to_lock)
+{
+  LOCK_all_lockfiles ();
+  h->next = all_lockfiles;
+  all_lockfiles = h;
+
+  h->lockname = jnlib_malloc ( strlen (file_to_lock) + 6 );
+  if (!h->lockname)
+    {
+      all_lockfiles = h->next;
+      UNLOCK_all_lockfiles ();
+      jnlib_free (h);
+      return NULL;
+    }
+  strcpy (stpcpy(h->lockname, file_to_lock), EXTSEP_S "lock");
+
+  /* If would be nice if we would use the FILE_FLAG_DELETE_ON_CLOSE
+     along with FILE_SHARE_DELETE but that does not work due to a race
+     condition: Despite the OPEN_ALWAYS flag CreateFile may return an
+     error and we can't reliable create/open the lock file unless we
+     would wait here until it works - however there are other valid
+     reasons why a lock file can't be created and thus the process
+     would not stop as expected but spin until Windows crashes.  Our
+     solution is to keep the lock file open; that does not harm. */
+  {
+#ifdef HAVE_W32CE_SYSTEM
+    wchar_t *wname = utf8_to_wchar (h->lockname);
+
+    if (wname)
+      h->lockhd = CreateFile (wname,
+                              GENERIC_READ|GENERIC_WRITE,
+                              FILE_SHARE_READ|FILE_SHARE_WRITE,
+                              NULL, OPEN_ALWAYS, 0, NULL);
+    else
+      h->lockhd = INVALID_HANDLE_VALUE;
+    jnlib_free (wname);
+#else
+    h->lockhd = CreateFile (h->lockname,
+                            GENERIC_READ|GENERIC_WRITE,
+                            FILE_SHARE_READ|FILE_SHARE_WRITE,
+                            NULL, OPEN_ALWAYS, 0, NULL);
+#endif
+  }
+  if (h->lockhd == INVALID_HANDLE_VALUE)
+    {
+      all_lockfiles = h->next;
+      UNLOCK_all_lockfiles ();
+      my_error_2 (_("can't create '%s': %s\n"), h->lockname, w32_strerror (-1));
+      jnlib_free (h->lockname);
+      jnlib_free (h);
+      return NULL;
+    }
+  return h;
+}
+#endif /*HAVE_DOSISH_SYSTEM*/
+
+
+/* Create a lockfile for a file name FILE_TO_LOCK and returns an
+   object of type dotlock_t which may be used later to actually acquire
+   the lock.  A cleanup routine gets installed to cleanup left over
+   locks or other files used internally by the lock mechanism.
+
+   Calling this function with NULL does only install the atexit
+   handler and may thus be used to assure that the cleanup is called
+   after all other atexit handlers.
+
+   This function creates a lock file in the same directory as
+   FILE_TO_LOCK using that name and a suffix of ".lock".  Note that on
+   POSIX systems a temporary file ".#lk.<hostname>.pid[.threadid] is
+   used.
+
+   FLAGS must be 0.
+
+   The function returns an new handle which needs to be released using
+   destroy_dotlock but gets also released at the termination of the
+   process.  On error NULL is returned.
+ */
+
+dotlock_t
+dotlock_create (const char *file_to_lock, unsigned int flags)
+{
+  static int initialized;
+  dotlock_t h;
+
+  if ( !initialized )
+    {
+      atexit (dotlock_remove_lockfiles);
+      initialized = 1;
+    }
+
+  if ( !file_to_lock )
+    return NULL;  /* Only initialization was requested.  */
+
+  if (flags)
+    {
+      jnlib_set_errno (EINVAL);
+      return NULL;
+    }
+
+  h = jnlib_calloc (1, sizeof *h);
+  if (!h)
+    return NULL;
+  h->extra_fd = -1;
+
+  if (never_lock)
+    {
+      h->disable = 1;
+      LOCK_all_lockfiles ();
+      h->next = all_lockfiles;
+      all_lockfiles = h;
+      UNLOCK_all_lockfiles ();
+      return h;
+    }
+
+#ifdef HAVE_DOSISH_SYSTEM
+  return dotlock_create_w32 (h, file_to_lock);
+#else /*!HAVE_DOSISH_SYSTEM */
+  return dotlock_create_unix (h, file_to_lock);
+#endif /*!HAVE_DOSISH_SYSTEM*/
+}
+
+
+
+/* Convenience function to store a file descriptor (or any any other
+   integer value) in the context of handle H.  */
+void
+dotlock_set_fd (dotlock_t h, int fd)
+{
+  h->extra_fd = fd;
+}
+
+/* Convenience function to retrieve a file descriptor (or any any other
+   integer value) stored in the context of handle H.  */
+int
+dotlock_get_fd (dotlock_t h)
+{
+  return h->extra_fd;
+}
+
+
+
+#ifdef HAVE_POSIX_SYSTEM
+/* Unix specific code of destroy_dotlock.  */
+static void
+dotlock_destroy_unix (dotlock_t h)
+{
+  if (h->locked && h->lockname)
+    unlink (h->lockname);
+  if (h->tname && !h->use_o_excl)
+    unlink (h->tname);
+  jnlib_free (h->tname);
+}
+#endif /*HAVE_POSIX_SYSTEM*/
+
+
+#ifdef HAVE_DOSISH_SYSTEM
+/* Windows specific code of destroy_dotlock.  */
+static void
+dotlock_destroy_w32 (dotlock_t h)
+{
+  if (h->locked)
+    {
+      OVERLAPPED ovl;
+
+      memset (&ovl, 0, sizeof ovl);
+      UnlockFileEx (h->lockhd, 0, 1, 0, &ovl);
+    }
+  CloseHandle (h->lockhd);
+}
+#endif /*HAVE_DOSISH_SYSTEM*/
+
+
+/* Destroy the locck handle H and release the lock.  */
+void
+dotlock_destroy (dotlock_t h)
+{
+  dotlock_t hprev, htmp;
+
+  if ( !h )
+    return;
+
+  /* First remove the handle from our global list of all locks. */
+  LOCK_all_lockfiles ();
+  for (hprev=NULL, htmp=all_lockfiles; htmp; hprev=htmp, htmp=htmp->next)
+    if (htmp == h)
+      {
+        if (hprev)
+          hprev->next = htmp->next;
+        else
+          all_lockfiles = htmp->next;
+        h->next = NULL;
+        break;
+      }
+  UNLOCK_all_lockfiles ();
+
+  /* Then destroy the lock. */
+  if (!h->disable)
+    {
+#ifdef HAVE_DOSISH_SYSTEM
+      dotlock_destroy_w32 (h);
+#else /* !HAVE_DOSISH_SYSTEM */
+      dotlock_destroy_unix (h);
+#endif /* HAVE_DOSISH_SYSTEM */
+      jnlib_free (h->lockname);
+    }
+  jnlib_free(h);
+}
+
+
+
+#ifdef HAVE_POSIX_SYSTEM
+/* Unix specific code of make_dotlock.  Returns 0 on success and -1 on
+   error.  */
+static int
+dotlock_take_unix (dotlock_t h, long timeout)
+{
+  int wtime = 0;
+  int sumtime = 0;
+  int pid;
+  int lastpid = -1;
+  int ownerchanged;
+  const char *maybe_dead="";
+  int same_node;
+
+ again:
+  if (h->use_o_excl)
+    {
+      /* No hardlink support - use open(O_EXCL).  */
+      int fd;
+
+      do
+        {
+          jnlib_set_errno (0);
+          fd = open (h->lockname, O_WRONLY|O_CREAT|O_EXCL,
+                     S_IRUSR|S_IRGRP|S_IROTH|S_IWUSR );
+        }
+      while (fd == -1 && errno == EINTR);
+
+      if (fd == -1 && errno == EEXIST)
+        ; /* Lock held by another process.  */
+      else if (fd == -1)
+        {
+          my_error_2 ("lock not made: open(O_EXCL) of '%s' failed: %s\n",
+                      h->lockname, strerror (errno));
+          return -1;
+        }
+      else
+        {
+          char pidstr[16];
+
+          snprintf (pidstr, sizeof pidstr, "%10d\n", (int)getpid());
+          if (write (fd, pidstr, 11 ) == 11
+              && write (fd, h->tname + h->nodename_off,h->nodename_len)
+              == h->nodename_len
+              && write (fd, "\n", 1) == 1
+              && !close (fd))
+            {
+              h->locked = 1;
+              return 0;
+            }
+          /* Write error.  */
+          my_error_2 ("lock not made: writing to '%s' failed: %s\n",
+                      h->lockname, strerror (errno));
+          close (fd);
+          unlink (h->lockname);
+          return -1;
+        }
+    }
+  else /* Standard method:  Use hardlinks.  */
+    {
+      struct stat sb;
+
+      /* We ignore the return value of link() because it is unreliable.  */
+      (void) link (h->tname, h->lockname);
+
+      if (stat (h->tname, &sb))
+        {
+          my_error_1 ("lock not made: Oops: stat of tmp file failed: %s\n",
+                      strerror (errno));
+          /* In theory this might be a severe error: It is possible
+             that link succeeded but stat failed due to changed
+             permissions.  We can't do anything about it, though.  */
+          return -1;
+        }
+
+      if (sb.st_nlink == 2)
+        {
+          h->locked = 1;
+          return 0; /* Okay.  */
+        }
+    }
+
+  /* Check for stale lock files.  */
+  if ( (pid = read_lockfile (h, &same_node)) == -1 )
+    {
+      if ( errno != ENOENT )
+        {
+          my_info_0 ("cannot read lockfile\n");
+          return -1;
+        }
+      my_info_0 ("lockfile disappeared\n");
+      goto again;
+    }
+  else if ( pid == getpid() && same_node )
+    {
+      my_info_0 ("Oops: lock already held by us\n");
+      h->locked = 1;
+      return 0; /* okay */
+    }
+  else if ( same_node && kill (pid, 0) && errno == ESRCH )
+    {
+      /* Note: It is unlikley that we get a race here unless a pid is
+         reused too fast or a new process with the same pid as the one
+         of the stale file tries to lock right at the same time as we.  */
+      my_info_1 (_("removing stale lockfile (created by %d)\n"), pid);
+      unlink (h->lockname);
+      goto again;
+    }
+
+  if (lastpid == -1)
+    lastpid = pid;
+  ownerchanged = (pid != lastpid);
+
+  if (timeout)
+    {
+      struct timeval tv;
+
+      /* Wait until lock has been released.  We use increasing retry
+         intervals of 50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s
+         but reset it if the lock owner meanwhile changed.  */
+      if (!wtime || ownerchanged)
+        wtime = 50;
+      else if (wtime < 800)
+        wtime *= 2;
+      else if (wtime == 800)
+        wtime = 2000;
+      else if (wtime < 8000)
+        wtime *= 2;
+
+      if (timeout > 0)
+        {
+          if (wtime > timeout)
+            wtime = timeout;
+          timeout -= wtime;
+        }
+
+      sumtime += wtime;
+      if (sumtime >= 1500)
+        {
+          sumtime = 0;
+          my_info_3 (_("waiting for lock (held by %d%s) %s...\n"),
+                     pid, maybe_dead, maybe_deadlock(h)? _("(deadlock?) "):"");
+        }
+
+
+      tv.tv_sec = wtime / 1000;
+      tv.tv_usec = (wtime % 1000) * 1000;
+      select (0, NULL, NULL, NULL, &tv);
+      goto again;
+    }
+
+  jnlib_set_errno (EACCES);
+  return -1;
+}
+#endif /*HAVE_POSIX_SYSTEM*/
+
+
+#ifdef HAVE_DOSISH_SYSTEM
+/* Windows specific code of make_dotlock.  Returns 0 on success and -1 on
+   error.  */
+static int
+dotlock_take_w32 (dotlock_t h, long timeout)
+{
+  int wtime = 0;
+  int w32err;
+  OVERLAPPED ovl;
+
+ again:
+  /* Lock one byte at offset 0.  The offset is given by OVL.  */
+  memset (&ovl, 0, sizeof ovl);
+  if (LockFileEx (h->lockhd, (LOCKFILE_EXCLUSIVE_LOCK
+                              | LOCKFILE_FAIL_IMMEDIATELY), 0, 1, 0, &ovl))
+    {
+      h->locked = 1;
+      return 0; /* okay */
+    }
+
+  w32err = GetLastError ();
+  if (w32err != ERROR_LOCK_VIOLATION)
+    {
+      my_error_2 (_("lock '%s' not made: %s\n"),
+                  h->lockname, w32_strerror (w32err));
+      return -1;
+    }
+
+  if (timeout)
+    {
+      /* Wait until lock has been released.  We use retry intervals of
+         50ms, 100ms, 200ms, 400ms, 800ms, 2s, 4s and 8s.  */
+      if (!wtime)
+        wtime = 50;
+      else if (wtime < 800)
+        wtime *= 2;
+      else if (wtime == 800)
+        wtime = 2000;
+      else if (wtime < 8000)
+        wtime *= 2;
+
+      if (timeout > 0)
+        {
+          if (wtime > timeout)
+            wtime = timeout;
+          timeout -= wtime;
+        }
+
+      if (wtime >= 800)
+        my_info_1 (_("waiting for lock %s...\n"), h->lockname);
+
+      Sleep (wtime);
+      goto again;
+    }
+
+  return -1;
+}
+#endif /*HAVE_DOSISH_SYSTEM*/
+
+
+/* Take a lock on H.  A value of 0 for TIMEOUT returns immediately if
+   the lock can't be taked, -1 waits forever (hopefully not), other
+   values wait for TIMEOUT milliseconds.  Returns: 0 on success  */
+int
+dotlock_take (dotlock_t h, long timeout)
+{
+  int ret;
+
+  if ( h->disable )
+    return 0; /* Locks are completely disabled.  Return success. */
+
+  if ( h->locked )
+    {
+      my_debug_1 ("Oops, '%s' is already locked\n", h->lockname);
+      return 0;
+    }
+
+#ifdef HAVE_DOSISH_SYSTEM
+  ret = dotlock_take_w32 (h, timeout);
+#else /*!HAVE_DOSISH_SYSTEM*/
+  ret = dotlock_take_unix (h, timeout);
+#endif /*!HAVE_DOSISH_SYSTEM*/
+
+  return ret;
+}
+
+
+
+#ifdef HAVE_POSIX_SYSTEM
+/* Unix specific code of release_dotlock.  */
+static int
+dotlock_release_unix (dotlock_t h)
+{
+  int pid, same_node;
+
+  pid = read_lockfile (h, &same_node);
+  if ( pid == -1 )
+    {
+      my_error_0 ("release_dotlock: lockfile error\n");
+      return -1;
+    }
+  if ( pid != getpid() || !same_node )
+    {
+      my_error_1 ("release_dotlock: not our lock (pid=%d)\n", pid);
+      return -1;
+    }
+
+  if ( unlink( h->lockname ) )
+    {
+      my_error_1 ("release_dotlock: error removing lockfile '%s'\n",
+                  h->lockname);
+      return -1;
+    }
+  /* Fixme: As an extra check we could check whether the link count is
+     now really at 1. */
+  return 0;
+}
+#endif /*HAVE_POSIX_SYSTEM */
+
+
+#ifdef HAVE_DOSISH_SYSTEM
+/* Windows specific code of release_dotlock.  */
+static int
+dotlock_release_w32 (dotlock_t h)
+{
+  OVERLAPPED ovl;
+
+  memset (&ovl, 0, sizeof ovl);
+  if (!UnlockFileEx (h->lockhd, 0, 1, 0, &ovl))
+    {
+      my_error_2 ("release_dotlock: error removing lockfile '%s': %s\n",
+                  h->lockname, w32_strerror (-1));
+      return -1;
+    }
+
+  return 0;
+}
+#endif /*HAVE_DOSISH_SYSTEM */
+
+
+/* Release a lock.  Returns 0 on success.  */
+int
+dotlock_release (dotlock_t h)
+{
+  int ret;
+
+  /* To avoid atexit race conditions we first check whether there are
+     any locks left.  It might happen that another atexit handler
+     tries to release the lock while the atexit handler of this module
+     already ran and thus H is undefined.  */
+  LOCK_all_lockfiles ();
+  ret = !all_lockfiles;
+  UNLOCK_all_lockfiles ();
+  if (ret)
+    return 0;
+
+  if ( h->disable )
+    return 0;
+
+  if ( !h->locked )
+    {
+      my_debug_1 ("Oops, '%s' is not locked\n", h->lockname);
+      return 0;
+    }
+
+#ifdef HAVE_DOSISH_SYSTEM
+  ret = dotlock_release_w32 (h);
+#else
+  ret = dotlock_release_unix (h);
+#endif
+
+  if (!ret)
+    h->locked = 0;
+  return ret;
+}
+
+
+
+/* Remove all lockfiles.  This is called by the atexit handler
+   installed by this module but may also be called by other
+   termination handlers.  */
+void
+dotlock_remove_lockfiles (void)
+{
+  dotlock_t h, h2;
+
+  /* First set the lockfiles list to NULL so that for example
+     dotlock_release is ware that this fucntion is currently
+     running.  */
+  LOCK_all_lockfiles ();
+  h = all_lockfiles;
+  all_lockfiles = NULL;
+  UNLOCK_all_lockfiles ();
+
+  while ( h )
+    {
+      h2 = h->next;
+      dotlock_destroy (h);
+      h = h2;
+    }
+}
diff --git a/lib/dotlock.h b/lib/dotlock.h
new file mode 100644
index 0000000..3fb9bcb
--- /dev/null
+++ b/lib/dotlock.h
@@ -0,0 +1,112 @@
+/* dotlock.h - dotfile locking declarations
+ * Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc.
+ *
+ * This file is part of JNLIB, which is a subsystem of GnuPG.
+ *
+ * JNLIB is free software; you can redistribute it and/or modify it
+ * under the terms of either
+ *
+ *   - the GNU Lesser General Public License as published by the Free
+ *     Software Foundation; either version 3 of the License, or (at
+ *     your option) any later version.
+ *
+ * or
+ *
+ *   - the GNU General Public License as published by the Free
+ *     Software Foundation; either version 2 of the License, or (at
+ *     your option) any later version.
+ *
+ * or both in parallel, as here.
+ *
+ * JNLIB is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copies of the GNU General Public License
+ * and the GNU Lesser General Public License along with this program;
+ * if not, see <http://www.gnu.org/licenses/>.
+ *
+ * ALTERNATIVELY, this file may be distributed under the terms of the
+ * following license, in which case the provisions of this license are
+ * required INSTEAD OF the GNU Lesser General License or the GNU
+ * General Public License. If you wish to allow use of your version of
+ * this file only under the terms of the GNU Lesser General License or
+ * the GNU General Public License, and not to allow others to use your
+ * version of this file under the terms of the following license,
+ * indicate your decision by deleting this paragraph and the license
+ * below.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, and the entire permission notice in its entirety,
+ *    including the disclaimer of warranties.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. The name of the author may not be used to endorse or promote
+ *    products derived from this software without specific prior
+ *    written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
+ * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ * DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#ifndef LIBJNLIB_DOTLOCK_H
+#define LIBJNLIB_DOTLOCK_H
+
+/* See dotlock.c for a description.  */
+
+#ifdef DOTLOCK_EXT_SYM_PREFIX
+# ifndef _DOTLOCK_PREFIX
+#  define _DOTLOCK_PREFIX1(x,y)  x ## y
+#  define _DOTLOCK_PREFIX2(x,y) _DOTLOCK_PREFIX1(x,y)
+#  define _DOTLOCK_PREFIX(x)    _DOTLOCK_PREFIX2(DOTLOCK_EXT_SYM_PREFIX,x)
+# endif /*_DOTLOCK_PREFIX*/
+# define dotlock_disable          _DOTLOCK_PREFIX(dotlock_disable)
+# define dotlock_create           _DOTLOCK_PREFIX(dotlock_create)
+# define dotlock_set_fd           _DOTLOCK_PREFIX(dotlock_set_fd)
+# define dotlock_get_fd           _DOTLOCK_PREFIX(dotlock_get_fd)
+# define dotlock_destroy          _DOTLOCK_PREFIX(dotlock_destroy)
+# define dotlock_take             _DOTLOCK_PREFIX(dotlock_take)
+# define dotlock_release          _DOTLOCK_PREFIX(dotlock_release)
+# define dotlock_remove_lockfiles _DOTLOCK_PREFIX(dotlock_remove_lockfiles)
+#endif /*DOTLOCK_EXT_SYM_PREFIX*/
+
+#ifdef __cplusplus
+extern "C"
+{
+#if 0
+}
+#endif
+#endif
+
+
+struct dotlock_handle;
+typedef struct dotlock_handle *dotlock_t;
+
+void dotlock_disable (void);
+dotlock_t dotlock_create (const char *file_to_lock, unsigned int flags);
+void dotlock_set_fd (dotlock_t h, int fd);
+int  dotlock_get_fd (dotlock_t h);
+void dotlock_destroy (dotlock_t h);
+int dotlock_take (dotlock_t h, long timeout);
+int dotlock_release (dotlock_t h);
+void dotlock_remove_lockfiles (void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif /*LIBJNLIB_DOTLOCK_H*/