path: root/KeyRing.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
module KeyRing where

import System.Environment
import Control.Monad
import Data.Maybe
import Data.Char
import Data.Ord
import Data.List
import Data.OpenPGP
import Data.Functor
import Data.Bits              ( (.|.) )
import Control.Applicative    ( liftA2, (<$>) )
import System.Directory       ( getHomeDirectory, doesFileExist )
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.Word ( Word8 )
import Data.Binary ( decode )
import ControlMaybe ( handleIO_ )
import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
       , ASN1(Start,End,IntVal,OID,BitString), ASN1ConstructionType(Sequence) )
import Data.ASN1.BitArray ( BitArray(..), toBitArray )
import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1' )
import Data.ASN1.BinaryEncoding ( DER(..) )
import Data.Time.Clock.POSIX ( getPOSIXTime )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString )
import qualified Data.ByteString      as S ( unpack )
import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 
import qualified Crypto.Types.PubKey.ECC as ECC
import qualified Codec.Binary.Base32 as Base32
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.Text as T ( Text, unpack, pack,
        strip, reverse, drop, break, dropAround )
import System.Posix.Types (EpochTime)
import System.Posix.Files ( modificationTime, getFileStatus )

import qualified CryptoCoins as CryptoCoins
import Base58
import FunctorToMaybe
import DotLock

-- DER-encoded elliptic curve ids
nistp256_id  = 0x2a8648ce3d030107
secp256k1_id = 0x2b8104000a

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

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

data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int

type UsageTag = String
type Initializer = String
type PassWordFile = InputFile

data FileType = KeyRingFile PassWordFile | PEMFile UsageTag | WalletFile

data RefType = ConstRef | MutableRef (Maybe Initializer)


data KeyRingRuntime = KeyRingRuntime
                        { rtPubring :: FilePath
                        , rtSecring :: FilePath
                        , rtRings :: [FilePath]
                        , rtWallets :: [FilePath]
                        , rtGrip :: Maybe String
                        , rtKeyDB :: KeyDB
                        }

data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)

data KeyRingData = KeyRingData
    { kFiles :: Map.Map InputFile (RefType,FileType)
    , kImports :: Map.Map FilePath (KeyData -> Bool)
    -- ^ indicates what pgp packets get written to which keyring files
    , homeSpec :: Maybe String
    }

resolveInputFile secring pubring = resolve
 where
    resolve HomeSec = return secring
    resolve HomePub = return pubring
    resolve (ArgFile f) = return f
    resolve _ = []

filesToLock k secring pubring = do
    (f,(rtyp,ftyp)) <- Map.toList (kFiles k)
    case rtyp of
        ConstRef -> []
        MutableRef {} -> resolveInputFile secring pubring f


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

todo = error "unimplemented"

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

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 _ =
        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]
                         : 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]: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"

data RSAPrivateKey = RSAPrivateKey
    { rsaN :: MPI
    , rsaE :: MPI
    , rsaD :: MPI
    , rsaP :: MPI
    , rsaQ :: MPI
    , rsaDmodP1 :: MPI
    , rsaDmodQminus1 :: MPI
    , rsaCoefficient :: MPI
    }
 deriving Show


data KikiCondition a = KikiSuccess a
    | FailedToLock [FilePath]
    | BadPassphrase
    | FailedToMakeSignature
    | CantFindHome

#define TRIVIAL(OP) fmap _ (OP) = OP
instance Functor KikiCondition where
    fmap f (KikiSuccess a) = KikiSuccess (f a)
    TRIVIAL( FailedToLock x )
    TRIVIAL( BadPassphrase )
    TRIVIAL( FailedToMakeSignature )
instance FunctorToMaybe KikiCondition where
    functorToMaybe (KikiSuccess a) = Just a
    functorToMaybe _               = Nothing

data KikiReportAction =
        NewPacket String
        | MissingPacket String
        | ExportedSubkey
        | GeneratedSubkeyFile
        | NewWalletKey String
        | YieldSignature
        | YieldSecretKeyPacket String
        | UnableToUpdateExpiredSignature
        | WarnFailedToMakeSignature

data KikiResult a = KikiResult
    { kikiCondition :: KikiCondition a
    , kikiReport :: [ (FilePath, KikiReportAction) ]
    }

keyPacket (KeyData k _ _ _) = packet k

usage (NotationDataPacket
        { human_readable = True
        , notation_name  = "usage@"
        , notation_value = u
        }) = Just u
usage _    = Nothing

-- torsig g topk wkun uid timestamp extras = todo
torSigOver 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 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 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 fp k = reverse $ zipWith const (reverse (fingerprint k)) fp

keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
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 (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 str = UserIDRecord {
                    uid_full = str,
                    uid_realname = realname,
                    uid_user = user,
                    uid_subdomain = subdomain,
                    uid_topdomain = topdomain
                }
 where
    text = T.pack str
    (T.strip-> realname, T.dropAround isBracket-> email)
                              = T.break (=='<') text
    (user, T.drop 1-> hostname) = T.break (=='@') email
    ( T.reverse            -> topdomain,
      T.reverse . T.drop 1 -> subdomain)
                              = T.break (=='.') . T.reverse $ hostname
isBracket :: Char -> Bool
isBracket '<' = True
isBracket '>' = True
isBracket _   = False




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


buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
              -> IO (KikiCondition ((KeyDB,Maybe String),[(FilePath,KikiReportAction)]))
buildKeyDB secring pubring grip0 keyring = do
    let isring (KeyRingFile {}) = True
        isring _                = False

        iswallet WalletFile = True
        iswallet _          = False

        files isring = do
            (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
            guard (isring ftyp)
            resolveInputFile secring pubring f

        readp n = fmap (n,) (readPacketsFromFile n)

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

    ms <- mapM readp (files isring)
    let grip = grip0 `mplus` (fingerprint <$> fstkey)
          where
            fstkey = listToMaybe $ mapMaybe isSecringKey ms 
                      where isSecringKey (fn,Message ps)
                                | fn==secring = listToMaybe ps
                            isSecringKey _  = Nothing
        wk = listToMaybe $ do
                fp <- maybeToList grip
                elm <- Map.toList db0
                guard $ matchSpec (KeyGrip fp) elm
                return $ keyPacket (snd elm)
        db0 = foldl' (uncurry . merge) Map.empty ms

    wms <- mapM (readw wk) (files iswallet)
    let wms' = do
            maybeToList wk
            (fname,xs) <- wms
            (_,sub,(_,m)) <- xs
            (tag,top) <- Map.toList m
            return (top,fname,sub,tag)

        doDecrypt = todo

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

    db <- foldM importWalletKey (KikiSuccess (db0,[])) wms'
    try db $ \(db,report) -> do
    return $ KikiSuccess ( (db, grip), report )

torhash key = maybe "" id $ derToBase32 <$> derRSA key

derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy

derRSA rsa = do
    k <- rsaKeyFromPacket rsa
    return $ encodeASN1 DER (toASN1 k [])

try :: KikiCondition a -> (a -> IO (KikiCondition b)) -> IO (KikiCondition b)
try wkun body =
    case functorToEither wkun of
           Left e -> return e
           Right wkun -> body wkun

doImportG
  :: Ord k =>
     (Packet -> IO (KikiCondition Packet))
     -> Map.Map k KeyData
     -> [k]
     -> [Char]
     -> [Char]
     -> Packet
     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
doImportG doDecrypt db m0 tag 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 (tag == "tor")
            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 (packet 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 = torSigOver (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 tag wk key subsigs
        doInsert mbsig db = do
            sig' <- makeSig doDecrypt top fname subkey_p tag 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



runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a)
runKeyRing keyring op = do
    homedir <- getHomeDir (homeSpec keyring)
    let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
        try' v body =
            case functorToEither v of
                   Left e -> return $ KikiResult e []
                   Right wkun -> body wkun
    try' homedir $ \(homedir,secring,pubring,grip0) -> do
    let tolocks = filesToLock keyring secring pubring
    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) = partition (isJust . fst) lks
        ret = if null failed then KikiSuccess () else FailedToLock failed
    ret <- case functorToEither ret of
      Right {} -> do
         bresult <- buildKeyDB secring pubring grip0 keyring -- build db
         try' bresult $ \((db,grip),report1) -> do
             a <- return $ op KeyRingRuntime
                            { rtPubring = pubring
                            , rtSecring = secring
                            , rtRings = [] -- todo secring:pubring:keyringFiles keyring
                            , rtWallets = [] -- todo walletFiles keyring
                            , rtGrip = grip
                            , rtKeyDB = db
                            }
             report2 <- todo -- write files
            
             return $ KikiResult (KikiSuccess a) (report1 ++ report2)
      Left err -> return $ KikiResult err []

    forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                         dotlock_destroy lk -- todo: verify we want this

    return ret


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

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 <- lookupEnv (homevar home) >>=
                  \d -> return $ d >>= guard . (/="") >> d
        homed <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        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 var =
    handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif

isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isUserID (UserIDPacket {}) = True
isUserID _                 = False

isTrust (TrustPacket {}) = True
isTrust _                = False

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 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 :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
slurpWIPKeys stamp "" = ([],[])
slurpWIPKeys stamp cs =
    let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
        mb        = decode_btc_key stamp (Char8.unpack b58)
    in if L.null b58 
        then let (ys,xs') = Char8.break (\x -> elem x 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 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@(PublicKeyPacket {}) = do
    n <- lookup 'n' $ key p
    e <- lookup 'e' $ key p
    return $ RSAKey n e
rsaKeyFromPacket p@(SecretKeyPacket {}) = do
    n <- lookup 'n' $ key p
    e <- lookup 'e' $ key p
    return $ RSAKey n e
rsaKeyFromPacket _ = Nothing


readPacketsFromWallet :: 
    Maybe Packet
    -> FilePath 
    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
readPacketsFromWallet wk fname = do
    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
                    modificationTime <$> getFileStatus fname
    input <- L.readFile fname
    let (ks,_) = slurpWIPKeys timestamp input
    when (not (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 :: FilePath -> IO Message
readPacketsFromFile fname = do
    -- warn $ fname ++ ": reading..."
    input <- L.readFile fname
#if MIN_VERSION_binary(0,6,4)
    return $
      case decodeOrFail input of
        Right (_,_,msg ) -> msg
        Left  (_,_,_)    -> trace (fname++": read fail") $ Message []
#else
    return $ decode input
#endif

now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime

signature_time ov = case if null cs then ds else cs of
                                [] -> minBound
                                xs -> last (sort 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 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



findTag tag wk subkey subsigs = (xs',minsig,ys')
         where
            vs = map (\sig ->
                          (sig, do
                                sig <- Just (packet . fst $ sig)
                                guard (isSignaturePacket sig)
                                guard $ flip isSuffixOf
                                             (fingerprint wk)
                                        . maybe "%bad%" id
                                        . signature_issuer
                                        $ sig
                                listToMaybe $
                                  map (signature_time . verify (Message [wk]))
                                      (signatures $ Message [wk,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 hs = filter (\p->isNotation p && notation_name p=="usage@")
                                (hashed_subpackets . packet . fst $ sig)
                    ks = map notation_value hs
                    isNotation (NotationDataPacket {}) = True
                    isNotation _ = False
                return (tag `elem` ks, sig)


makeSig doDecrypt top fname subkey_p tag mbsig = do
    let wk = packet top
    wkun <- doDecrypt wk
    try wkun $ \wkun -> do
    let grip = fingerprint wk
        addOrigin new_sig = do
            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 }
                    , NotationDataPacket
                        { human_readable = True
                        , notation_name = "usage@"
                        , notation_value = tag
                        }
                    -- 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 do
        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
    else do
        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
                        $ maybeToList $ do
                            e <- expires
                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
            notation = NotationDataPacket
                        { notation_name = "usage@"
                        , notation_value = tag
                        , human_readable = True }
            sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
        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
        , usage_tag :: Maybe String
        , locations :: OriginMap
        }

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

type KeyKey = [ByteString]
data SubKey = SubKey MappedPacket [SigAndTrust]
data KeyData = KeyData MappedPacket    -- main key
                       [SigAndTrust]  -- sigs on main key
                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
                       (Map.Map KeyKey SubKey)    -- subkeys

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 filename p = MappedPacket 
    { packet = p
    , usage_tag = Nothing
    , locations = Map.singleton filename (origin p (-1))
    }

keykey key =
    -- Note: The key's timestamp is included in it's fingerprint.
    --       Therefore, the same key with a different timestamp is
    --       considered distinct using this keykey implementation.
    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?

uidkey (UserIDPacket str) = str

merge :: KeyDB -> FilePath -> Message -> KeyDB
merge db filename (Message ps) = merge_ db filename qs
 where
    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)
                _ | otherwise                    -> (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




merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
                -> KeyDB
merge_ db filename qs = foldl mergeit db (zip [0..] qs)
 where
    keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
    keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
    keycomp a b | keykey a==keykey b = EQ
    keycomp a b = error $ unlines ["Unable to merge keys:"
                                  , fingerprint a
                                  , PP.ppShow a
                                  , fingerprint b
                                  , PP.ppShow b
                                  ]

    asMapped n p = let m = mappedPacket filename p
                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
    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 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 ( (asMapped n (minimumBy keycomp [packet key,p]))
                                          { locations = Map.insert filename (origin p n) (locations key) } )
                                       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 ((asMapped n (minimumBy subcomp [packet key,p]))
                 { locations = Map.insert filename (origin p n) (locations key) })
               sigs
     where
        -- Compare master keys, LT is prefered for merging
        -- Compare subkeys, LT is prefered for merging
        subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
        subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
        subcomp a b | keykey a==keykey b = EQ
        subcomp a b = error $ unlines ["Unable to merge subs:"
                                      , fingerprint a
                                      , PP.ppShow a
                                      , fingerprint b
                                      , PP.ppShow b
                                      ]
        subcomp_m a b = subcomp (packet a) (packet b)

    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')


    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 =
                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
           , locations = Map.insert filename (origin a n) locs }
        , tb `Map.union` ta )

     where
        -- TODO: when merging items, we should delete invalidated origins
        -- from the orgin map.
        mergeItem ys x = if x `elem` ys then ys else ys++[x]

    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 fname getp f = concat . sortByHint fname getp . map f

sortByHint fname f = sortBy (comparing gethint)
  where
    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
    defnum = -1

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


 
{-
data Kiki a =
    SinglePass (KeyRingData -> KeyRingAction a)
    | forall b. MultiPass (KeyRingData -> KeyRingAction b)
                          (Kiki (b -> a))

fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass pass) = SinglePass pass'
 where
    pass' kd = case pass kd of
                KeyRingAction v -> RunTimeAction (\rt -> g rt v)
                RunTimeAction f -> RunTimeAction (\rt -> g rt (f rt))
fmapWithRT g (MultiPass pass0 k) = MultiPass pass0 k'
 where
    k' = fmapWithRT (\rt f -> g rt . f) k

instance Functor Kiki where fmap f k = fmapWithRT (const f) k

instance Monad Kiki where
    return x = SinglePass (const $ KeyRingAction x)
    
    k >>= f  = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
                where (.:) = (.) . (.)

eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a
eval rt (SinglePass f) kd =
    case f kd of KeyRingAction v -> v
                 RunTimeAction g -> g rt                       
eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd

eval' :: Kiki (KeyRingData -> a) -> Kiki a
eval' k@(SinglePass pass) = SinglePass pass'
 where
    pass' kd = case pass kd of
                KeyRingAction f -> KeyRingAction (f kd)
                RunTimeAction g -> RunTimeAction (\rt -> g rt kd)
eval' k@(MultiPass p kk) = MultiPass p kk'
 where
    kk' = fmap flip kk

-}



{-
fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
    = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
    = SinglePass $ d { kAction = RunTimeAction f' }
    where f' rt = g rt (f rt)
fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
    where g' rt h = g rt . h
-}


data Kiki a =
    SinglePass { passInfo :: KeyRingData
               , rtAction :: KeyRingAction a }
    | forall b.
       MultiPass { passInfo :: KeyRingData
                 , passAction :: KeyRingAction b
                 , nextPass :: Kiki (b -> a)
                 }



evalAction :: KeyRingRuntime -> KeyRingAction a -> a
evalAction rt (KeyRingAction v) = v
evalAction rt (RunTimeAction g) = g rt

instance Monad KeyRingAction where
    return x = KeyRingAction x
    m >>= g  = case m of
        KeyRingAction v -> g v
        RunTimeAction f -> RunTimeAction $ \rt -> evalAction rt (g $ f rt)

instance Functor KeyRingAction where
    fmap g (KeyRingAction v) = KeyRingAction $ g v
    fmap g (RunTimeAction f) = RunTimeAction $ \rt -> g (f rt)

{-
argOut :: (KeyRingAction (a -> b)) -> a -> KeyRingAction b
argOut = todo
argIn :: (a -> KeyRingAction b) -> KeyRingAction (a->b)
-}

{-
fmapWithRT :: (a -> KeyRingAction b) -> Kiki a -> Kiki b
fmapWithRT g k@(SinglePass {}) = k { rtAction = action }
 where
    action = rtAction k >>= g
fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
 where
    next' = fmapWithRT g' next {- next :: Kiki (x -> a) -}
    -- g' :: ( (x->a) -> KeyRingAction b)
    g' h = RunTimeAction $
            \rt x -> case g (h x) of
                        KeyRingAction v -> v
                        RunTimeAction f -> f rt
-}

fmapWithRT :: KeyRingAction (a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass pass atn) = SinglePass pass atn'
 where
    atn' = g >>= flip fmap atn
fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
 where
    next' = fmapWithRT g' next
    g' = fmap (\gf h -> gf . h) g

instance Functor Kiki where
    fmap f k = fmapWithRT (return f) k

instance Monad Kiki where
    return x = SinglePass todo (return x)
    k >>= f  = kjoin $ fmap f k

kikiAction :: Kiki a -> KeyRingAction a
kikiAction (SinglePass _ atn) = atn
kikiAction (MultiPass _ atn next) = do
        x <- atn
        g <- kikiAction next
        return $ g x

kjoin :: Kiki (Kiki a) -> Kiki a
kjoin k = fmapWithRT eval' k
 where
    eval' :: KeyRingAction (Kiki a -> a)
    eval' = RunTimeAction (\rt -> evalAction rt . kikiAction )

    {-
    kjoin :: Kiki (Kiki a) -> Kiki a
    kjoin k = kjoin' (fmap kikiAction k)
     where
        ev rt (KeyRingAction v) = v
        ev rt (RunTimeAction g) = g rt

        kjoin' :: Kiki (KeyRingAction a) -> Kiki a
        kjoin' (SinglePass pass atn) = SinglePass pass $ join atn
        kjoin' (MultiPass pass atn next) = MultiPass pass atn next'
            where
                next' = todo
    -}


{-
instance Functor Kiki where
    fmap f (SinglePass pass atn)
        = SinglePass pass (fmap f atn)
    fmap f (MultiPass pass atn next)
        = MultiPass pass atn (next >>= g)
     where
        g = todo
-}

{-
data Kiki a = SinglePass (KeyRingData a)
              | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))

instance Functor Kiki where
    fmap f (SinglePass d) = SinglePass $ case kAction d of
                                  KeyRingAction v -> d { kAction = KeyRingAction (f v) }
                                  RunTimeAction g -> d { kAction = RunTimeAction (f . g) }
    fmap f (MultiPass p k)= MultiPass p (fmap (f .) k)

eval :: KeyRingRuntime -> Kiki a -> a
eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v
eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt
eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p)

fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
    = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
    = SinglePass $ d { kAction = RunTimeAction f' }
    where f' rt = g rt (f rt)
fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
    where g' rt h = g rt . h

kjoin :: Kiki (Kiki a) -> Kiki a
kjoin k = fmapWithRT eval k

passCount :: Kiki a -> Int
passCount (MultiPass _ k) = 1 + passCount k
passCount (SinglePass {}) = 1

instance Monad Kiki where
    return x = SinglePass (kret x)
    k >>= f  = kjoin (fmap f k)
-}


-- Kiki a -> a -> Kiki b

atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a
atRuntime = todo

goHome :: Maybe FilePath -> Kiki ()
goHome p = todo -- SinglePass $ (kret ()) { homeSpec = p }

syncRing :: InputFile -> Kiki ()
syncRing = todo

syncSubKey :: String -> FilePath -> String -> Kiki ()
syncSubKey usage path cmd = todo

syncWallet :: FilePath -> Kiki ()
syncWallet = todo

usePassphraseFD :: Int -> Kiki ()
usePassphraseFD = todo

importAll :: Kiki ()
importAll = todo

importAllAuthentic :: Kiki ()
importAllAuthentic = todo

signSelfAuthorized :: Kiki ()
signSelfAuthorized = todo

showIdentity :: Message -> String
showIdentity = todo

identities :: Kiki [Message]
identities = todo

currentIdentity :: Kiki Message
currentIdentity = todo

identityBySpec :: String -> Kiki Message
identityBySpec = todo

identityBySSHKey :: String -> Kiki Message
identityBySSHKey = todo

keyBySpec :: String -> Kiki Packet
keyBySpec = todo

walletInputFormat :: Packet -> String
walletInputFormat = todo