path: root/lib/KeyRing.hs

---------------------------------------------------------------------------
-- |
-- Module      :  KeyRing
--
-- Maintainer  :  joe@jerkface.net
-- Stability   :  experimental
--
-- kiki is a command-line utility for manipulating GnuPG's keyring files.  This
-- module is the programmer-facing API it uses to do that.
--
-- Note: This is *not* a public facing API. I (the author) consider this
-- library to be internal to kiki and subject to change at my whim.
--
-- Typically, a client to this module would prepare a 'KeyRingOperation'
-- describing what he wants done, and then invoke 'runKeyRing' to make it
-- happen.
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DeriveFunctor            #-}
{-# LANGUAGE DoAndIfThenElse          #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PatternGuards            #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TupleSections            #-}
{-# LANGUAGE ViewPatterns             #-}
module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where

import System.Environment
import Control.Monad
import Data.Bool
import Data.Maybe
import Data.Either
import Data.Char
import Data.List
import Data.OpenPGP
import System.Directory       ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
import Control.Arrow          ( first, second )
import Data.OpenPGP.Util
import Data.ByteString.Lazy   ( ByteString )
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 (decodeASN1', encodeASN1, encodeASN1' )
import Data.ASN1.BinaryEncoding ( DER(..) )
import Data.Bits ((.&.), shiftR )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString      as S
#if defined(VERSION_memory)
import qualified Data.ByteString.Char8 as S8
import Data.ByteArray.Encoding
#elif defined(VERSION_dataenc)
import qualified Codec.Binary.Base32 as Base32
import qualified Codec.Binary.Base64 as Base64
#endif
#if !defined(VERSION_cryptonite)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Types.PubKey.ECC as ECC
#else
#endif
import qualified Codec.Compression.GZip as GZip
import qualified System.Posix.Types as Posix
import System.Posix.Files (setFileCreationMask, setFileTimes )

#if MIN_VERSION_x509(1,5,0)
#endif
#if MIN_VERSION_unix(2,7,0)
import System.Posix.Files ( setFdTimesHiRes )
#else
import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
import Foreign.Marshal.Array ( withArray )
import Foreign.Ptr
import Foreign.C.Error ( throwErrnoIfMinus1_ )
import Foreign.Storable
#endif
import System.FilePath ( takeDirectory )
import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose)
import System.Posix.IO ( fdToHandle )
#if ! MIN_VERSION_base(4,6,0)
import GHC.Exts ( Down(..) )
#endif
#if MIN_VERSION_binary(0,7,0)
#endif
import qualified Data.ByteString.Lazy.Char8 as Char8
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as ASCIIArmor
import Codec.Encryption.OpenPGP.ASCIIArmor.Types

import qualified Hosts
import qualified CryptoCoins
import Base58
import FunctorToMaybe
import DotLock
import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
import           KeyRing.BuildKeyDB          (Hostnames(..),
                                              IPsToWriteToHostsFile(..),
                                              buildKeyDB,
                                              combineTransforms,
                                              filterMatches,
                                              fingerdress, flattenKeys,
                                              generateInternals,
                                              getHostnames, getSubkeys,
                                              importSecretKey,
                                              insertSubkey,
                                              matchSpec, merge,
                                              packetFromPublicRSAKey,
                                              parseCertBlob,
                                              parseSingleSpec,
                                              parseSpec, readInputFileL,
                                              readSecretPEMFile,
                                              secp256k1_id, seek_key,
                                              selectKey0, selectPublicKey,
                                              usageFromFilter)

import KeyRing.Types
import PacketTranscoder
import Transforms


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

isMutable :: StreamInfo -> Bool
isMutable stream | KF_None <- fill stream = False
isMutable _                               = True


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


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

data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show

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

instance ASN1Object PKCS8_RSAPublicKey where

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

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

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



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

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

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



getStr :: SingleKeySpec -> String
getStr (FingerprintMatch x) = x
getStr (SubstringMatch _ x) = x
getStr _ = ""

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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


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

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)

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



writeInputFileL :: InputFileContext
                   -> InputFile -> ByteString -> IO ()
writeInputFileL ctx (Pipe _ fd) bs   = fdToHandle fd >>= (`L.hPut` bs)
writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs)
writeInputFileL ctx inp bs = do
    let fname = resolveInputFile ctx inp
    mapM_ (`L.writeFile` bs) fname

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

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

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

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

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


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





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

    -- 3. add hostnames from gpg for addresses not in U
    let u = foldl' f u1 ans
        ans = reverse $ do
            Hostnames 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



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


-- No instance for (ASN1Object RSA.PublicKey)


decodeBlob :: ParsedCert -> ByteString
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





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

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


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

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

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

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

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


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

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

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

mkarmor :: Access -> L.ByteString -> [Armor]
mkarmor access bs = [Armor typ [] bs]
 where
     typ = case access of
            Pub        -> ArmorPublicKeyBlock
            Sec        -> ArmorPrivateKeyBlock
            AutoAccess -> ArmorPrivateKeyBlock -- I don't know, so don't make it look sharable.

writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
                    -> [(FilePath,KikiReportAction)]
                {-
                ->  KeyDB -> Maybe Packet
                -> FilePath -> FilePath
                -}
                -> IO (KikiCondition [(FilePath,KikiReportAction)])
writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
    let isring (KeyRingFile {}) = True
        isring _                = False
        db = rtKeyDB rt
        secring = rtSecring rt
        pubring = rtPubring rt
        ctx = InputFileContext secring pubring
    let s = do
        (f,f0,stream) <- do
            (f0,stream) <- Map.toList (opFiles krd)
            guard (isring $ typ stream)
            f <- resolveInputFile ctx f0
            return (f,f0,stream)
        let db' = fromMaybe db $ do
                    msg <- Map.lookup f0 unspilled
                    return $ merge db f0 msg
            x = do
                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
                    wantedForFill acc KF_None       = importByExistingMaster
                        -- Note the KF_None case is almost irrelevent as it will be
                        -- filtered later when isMutable returns False.
                        -- We use importByExistingMaster in order to generate
                        -- MissingPacket warnings.  To disable those warnings, use
                        -- const Nothing instead.
                    wantedForFill acc (KF_Match {}) = importByExistingMaster
                    wantedForFill acc KF_Subkeys    = importByExistingMaster
                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
                                                                importByAccess acc kd
                    wantedForFill acc KF_All        = importByAccess acc
                    importByAccess Pub kd = importPublic
                    importByAccess Sec kd = importSecret
                    importByAccess AutoAccess kd =
                        mplus (importByExistingMaster kd)
                              (error $ f ++ ": write public or secret key to file?")
                    importByExistingMaster kd@(KeyData p _ _ _) =
                        fmap originallyPublic $ Map.lookup f $ locations p
                d <- sortByHint f keyMappedPacket (Map.elems db')
                acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
                only_public <- maybeToList $ wantedForFill acc (fill stream) d
                guard $ only_public || isSecretKey (keyPacket d)
                case fill stream of
                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
                                         flattenTop f only_public
                                            $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3
                    _              -> flattenTop f only_public d
            new_packets = filter isnew x
                where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
            -- TODO: We depend on an exact string match between the reported
            -- file origin of the deleted packet and the path of the file we are
            -- writing.  Verify that this is a safe assumption.
            isdeleted (f',DeletedPacket _) = f'==f
            isdeleted _                    = False
        guard (not (null new_packets) || any isdeleted report_manips)
        return ((f0,stream),(new_packets,x))
    let (towrites,report) = foldl' go ([],[]) s
          where
            go (ws,report) ((f,stream),(new_packets,x)) = (ws++writes, report++(items <$> new_packets))
              where
                mutable = isMutable stream
                writes | mutable   = [(stream,f,x)]
                       | otherwise = []
                items c = ( concat $ resolveInputFile ctx f
                          , bool MissingPacket NewPacket mutable $ showPacket (packet c)
                          )
    forM_ towrites $ \(stream,f,xs) -> do
        let encoding = case typ stream of PGPPackets AsciiArmor -> AsciiArmor
                                          _                     -> BinaryPackets
            enc = case encoding of
                BinaryPackets -> id
                AsciiArmor    -> ASCIIArmor.encodeLazy . mkarmor (access stream)
        writeInputFileL ctx f $ enc $ encode $ Message $ map packet xs
    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

data PemType = PemPublicKey | PemPrivateKey | PemCertificate

pemTypeString :: PemType -> String
pemTypeString PemPublicKey  = "PUBLIC KEY"
pemTypeString PemPrivateKey = "PRIVATE KEY"
pemTypeString PemCertificate = "CERTIFICATE"

writePEM :: PemType -> String -> String
writePEM (pemTypeString -> typ) dta = pem
 where
    pem = unlines . concat $
            [ ["-----BEGIN " <> typ <> "-----"]
            , split64s dta
            , ["-----END " <> typ <> "-----"] ]
    split64s :: String -> [String]
    split64s "" = []
    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta

    -- 64 byte lines

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

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

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

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

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

writeKeyToFile ::
  StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
writeKeyToFile stream@(StreamInfo { typ = PEMFile }) fname packet = do
    case pemFromPacket (access stream) packet of
     Just output -> do
        let stamp = toEnum . fromEnum $ timestamp packet
        handleIO_ (return [(fname, FailedFileWrite)]) $ do
            saved_mask <- setFileCreationMask 0o077
            -- Note: The key's timestamp is included in it's fingerprint.
            --       Therefore, we should attempt to preserve it.
            writeStamped (InputFileContext "" "") fname stamp output
            setFileCreationMask saved_mask
            return [(fname, ExportedSubkey)]
     Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]

writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do
    case key_algorithm packet of
     RSA -> do
        flip (maybe (return []))
             (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
            $ \rsa -> do
        let -- asn1 = toASN1 rsa []
            -- bs = encodeASN1 DER asn1
            -- dta = Base64.encode (L.unpack bs)
#if defined(VERSION_memory)
            b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i
#elif defined(VERSION_dataenc)
            b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
#endif
             where
                MPI i = ac rsa
                i2bs_unsized :: Integer -> S.ByteString
                i2bs_unsized 0 = S.singleton 0
                i2bs_unsized i = S.reverse $ S.unfoldr go i
                 where go i' = if i' <= 0 then Nothing
                                          else Just (fromIntegral i', (i' `shiftR` 8))
            output = unlines
                [ "Private-key-format: v1.2"
                , "Algorithm: 8 (RSASHA256)"
                , "Modulus: " ++ b64 rsaN rsa
                , "PublicExponent: " ++ b64 rsaE rsa
                , "PrivateExponent: " ++ b64 rsaD rsa
                , "Prime1: " ++ b64 rsaP rsa
                , "Prime2: " ++ b64 rsaQ rsa
                , "Exponent1: " ++ b64 rsaDmodP1 rsa
                , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
                , "Coefficient: " ++ b64 rsaCoefficient rsa
                ]
            stamp = toEnum . fromEnum $ timestamp packet
        handleIO_ (return [(fname, FailedFileWrite)]) $ do
            saved_mask <- setFileCreationMask 0o077
            -- Note: The key's timestamp is included in it's fingerprint.
            --       Therefore, we should attempt to preserve it.
            writeStamped (InputFileContext "" "") fname stamp output
            setFileCreationMask saved_mask
            return [(fname, ExportedSubkey)]
     algo -> return [(fname, UnableToExport algo $ fingerprint packet)]

writePEMKeys :: (PacketDecrypter)
                -> KeyDB
                -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
                -> IO (KikiCondition [(FilePath,KikiReportAction)])
writePEMKeys doDecrypt db exports = do
    ds <- mapM decryptKeys exports
    let ds' = map functorToEither ds
    if null (lefts ds')
        then do
            rs <- mapM (\(f,stream,p) -> writeKeyToFile stream (ArgFile f) p)
                       (rights ds')
            return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
        else do
            return (head $ lefts ds')
 where
    decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
        = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
    decryptKeys (fname,subspec,[p],stream) = do
        pun <- doDecrypt p
        try pun $ \pun -> do
        return $ KikiSuccess (fname,stream,pun)

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

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

        -- missing - mutable files not in the keyring and not on disk
        -- notmissing - mutable keys in the keyring, but not on disk
        let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
                (fname,stream) <- nonexistents
                let mutableTag
                        | isMutable stream = usageFromFilter (fill stream)
                        | otherwise        = Nothing
                usage <- maybeToList mutableTag
                -- TODO: Use parseSpec3
                -- TODO: Report error if generating without specifying usage tag.
                let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
                    -- ms will contain duplicates if a top key has multiple matching
                    -- subkeys.  This is intentional.
                    -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
                    -- ms = filterMatches topspec $ Map.toList db
                    ns = do
                       (kk,kd) <- filterMatches topspec $ Map.toList db
                       return (kk , subkeysForExport subspec kd)
                return (fname,subspec,ns,stream)
            (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
                                             notmissing
            exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0

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

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

        ifnotnull ambiguous ambiguity $ do

        -- create nonexistent files via external commands
        do
           let cmds = mapMaybe getcmd missing
                 where
                   getcmd (fname,subspec,ms,stream) = do
                       cmd <- case initializer stream of
                                External str -> Just str
                                _            -> Nothing
                       return (fname,subspec,ms,stream,cmd)
           rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
               e <- systemEnv [ ("file",fname)
                              , ("usage",fromMaybe "" subspec) ]
                              cmd
               case e of
                 ExitFailure num -> return (tup,FailedExternal num)
                 ExitSuccess     -> return (tup,ExternallyGeneratedFile)

           v <- foldM (importSecretKey transcode)
                      (KikiSuccess (db,[])) $ do
                    ((f,subspec,ms,stream,cmd),r) <- rs
                    guard $ case r of
                       ExternallyGeneratedFile -> True
                       _ -> False
                    return (ArgFile f,subspec,map fst ms,stream,cmd)

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

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

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

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

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

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


-- 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' :: Monad m => KikiCondition t -> (t -> m (KikiResult a)) -> m (KikiResult a)
try' v body =
  case functorToEither v of
    Left e -> return $ KikiResult e []
    Right wkun -> body wkun

-- | Load and update key files according to the specified 'KeyRingOperation'.
runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
runKeyRing operation =
    withLockedKeyring (opHome operation)
                      (opFiles operation)
                      $ realRunKeyRing operation

withLockedKeyring :: Maybe FilePath
                           -> Map.Map InputFile StreamInfo
                           -> (InputFileContext -> Maybe String -> IO (KikiResult a))
                           -> IO (KikiResult a)
withLockedKeyring homespec opfiles go = do
    -- get homedir and keyring files + fingerprint for working key
    homedir <- getHomeDir homespec
    try' homedir $ \(_homedir, secring, pubring, grip0) -> do
    let ctx = InputFileContext secring pubring
        tolocks = filesToLock opfiles ctx
    secring <- return Nothing
    pubring <- return Nothing
    (locks :: [(Maybe DotLock, FilePath)]) <-
      forM tolocks $ \f -> do
        createDirectoryIfMissing True $ takeDirectory f
        lk <- dotlock_create f 0
        v <- flip (maybe $ return Nothing) lk $ \lk -> do
                e <- dotlock_take lk (-1)
                if e==0 then return $ Just lk
                        else dotlock_destroy lk >> return Nothing
        return (v,f)
    let (lked, map snd -> failed_locks) = partition (isJust . fst) locks
    ret <-
      if not $ null failed_locks
       then return $ KikiResult (FailedToLock failed_locks) []
       else go ctx grip0
    forM_ lked $ \(Just lk, fname) -> dotlock_release lk
    return ret


realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime)
realRunKeyRing operation ctx grip0 = do
        bresult <- buildKeyDB ctx grip0 operation
        try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do

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

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

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

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

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

        r <- writePEMKeys decrypt (rtKeyDB rt) exports
        try' r $ \report_pems -> do

        import_hosts <- writeHostsFiles operation ctx hs

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


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







{-
onionName :: KeyData -> (SockAddr,L.ByteString)
onionName kd = (addr,name)
 where
    (addr,(name:_,_)) = getHostnames kd
-}








#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