{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} 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.Monoid 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, 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 ( pack, null, readFile, writeFile, ByteString, toChunks ) import qualified Data.ByteString as S ( unpack, splitAt, concat, cons ) import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break, concat, lines ) import qualified Crypto.Types.PubKey.ECC as ECC import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 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 System.IO (hPutStrLn,withFile,IOMode(..)) import Data.Binary ( encode ) 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 instance ASN1Object RSAPrivateKey where toASN1 rsa@(RSAPrivateKey {}) = \xs -> Start Sequence : IntVal 0 : mpiVal rsaN : mpiVal rsaE : mpiVal rsaD : mpiVal rsaP : mpiVal rsaQ : mpiVal rsaDmodP1 : mpiVal rsaDmodQminus1 : mpiVal rsaCoefficient : End Sequence : xs where mpiVal f = IntVal x where MPI x = f rsa fromASN1 ( Start Sequence : IntVal _ -- version : IntVal n : IntVal e : IntVal d : IntVal p : IntVal q : IntVal dmodp1 : IntVal dmodqminus1 : IntVal coefficient : ys) = Right ( privkey, tail $ dropWhile notend ys) where notend (End Sequence) = False notend _ = True privkey = RSAPrivateKey { rsaN = MPI n , rsaE = MPI e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = MPI dmodp1 , rsaDmodQminus1 = MPI dmodqminus1 , rsaCoefficient = MPI coefficient } fromASN1 _ = Left "fromASN1: RSAPrivateKey: unexpected format" data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] | BadPassphrase | FailedToMakeSignature | CantFindHome | AmbiguousKeySpec | CannotImportMasterKey deriving ( Functor, Show ) 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 keyMappedPacket (KeyData k _ _ _) = 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,Maybe Packet),[(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 db_rings = foldl' (uncurry . merge) Map.empty ms wk = listToMaybe $ do fp <- maybeToList grip elm <- Map.toList db_rings guard $ matchSpec (KeyGrip fp) elm return $ keyPacket (snd elm) wms <- mapM (readw wk) (files iswallet) let wallet_keys = do maybeToList wk (fname,xs) <- wms (_,sub,(_,m)) <- xs (tag,top) <- Map.toList m return (top,fname,sub,tag) 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 (db_rings,[])) wallet_keys try db $ \(db,report) -> do -- todo: import PEMFiles -- use_db <- foldM (doImport decrypt) use_db0 (map snd imports) return $ KikiSuccess ( (db, grip, wk), 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 :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) try x body = case functorToEither x of Left e -> return e Right x -> body x readKeyFromFile False "PEM" fname = do -- warn $ fname ++ ": reading ..." -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let dta = extractPEM "RSA PRIVATE KEY" input -- Char8.putStrLn $ "dta = " <> dta let rsa = do e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) asn1 <- either (const Nothing) Just e k <- either (const Nothing) (Just . fst) (fromASN1 asn1) let _ = k :: RSAPrivateKey return k -- putStrLn $ "rsa = "++ show rsa return . Message $ do rsa <- maybeToList rsa return $ SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = RSA , key = [ -- public fields... ('n',rsaN rsa) ,('e',rsaE rsa) -- secret fields ,('d',rsaD rsa) ,('p',rsaQ rsa) -- Note: p & q swapped ,('q',rsaP rsa) -- Note: p & q swapped ,('u',rsaCoefficient rsa) ] -- , ecc_curve = def , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) extractPEM typ pem = dta where dta = case ys of _:dta_lines -> Char8.concat dta_lines [] -> "" xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) ys = takeWhile (/="-----END " <> typ <> "-----") xs doImport :: Ord k => (Packet -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> ([Char], Maybe [Char], [k], t) -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImport doDecrypt db (fname,subspec,ms,_) = do let fetchkey = readKeyFromFile False "PEM" fname flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do Message parsedkey <- fetchkey flip (maybe $ return $ KikiSuccess (db,[])) (listToMaybe parsedkey) $ \key -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) then return AmbiguousKeySpec else doImportG doDecrypt db m0 tag fname key 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 " 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 isCryptoCoinKey p = and [ isKey p , key_algorithm p == ECDSA , lookup 'c' (key p) == Just (MPI secp256k1_id) ] 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 (map (packet . fst) sigs) return (tag,mp) 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 :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeWalletKeys krd db wk = do let cs = db `coinKeysOwnedBy` wk -- export wallet keys isMutableWallet (MutableRef {}) WalletFile = True isMutableWallet _ _ = False files pred = do (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) guard (pred rtyp ftyp) resolveInputFile "" "" 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 withFile n AppendMode $ \fh -> do rs <- forM cs' $ \(net,wip) -> do hPutStrLn fh wip return (n, NewWalletKey net) return (report ++ rs) report <- foldM writeWallet [] (files isMutableWallet) return $ KikiSuccess report ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f showPacket :: Packet -> String showPacket p | isKey p = (if is_subkey p then showPacket0 p else ifSecret p "----Secret-----" "----Public-----") ++ " "++show (key_algorithm p)++" "++fingerprint p | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) | otherwise = showPacket0 p showPacket0 p = concat . take 1 $ words (show p) writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet -> FilePath -> FilePath -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd db wk secring pubring = do let ks = Map.elems db {- fs = Map.keys (foldr unionfiles Map.empty ks) where unionfiles (KeyData p _ _ _) m = Map.union m (locations p) -} isring (KeyRingFile {}) = True isring _ = False isMutable (MutableRef {}) = True isMutable _ = False fs = do (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) guard (isring ftyp) n <- resolveInputFile secring pubring f return (n,isMutable rtyp) fromfile f (KeyData p _ _ _) = Map.member f $ locations p let s = do (f,mutable) <- fs let x = do d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyMappedPacket ks) n <- maybeToList $ Map.lookup f (locations p) flattenTop f (originallyPublic n) d changes = filter isnew x where isnew p = isNothing (Map.lookup f $ locations p) {- trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do -} guard (not $ null changes) return ((f,mutable),(changes,x)) let (towrites,report) = (\f -> foldl f ([],[]) s) $ \(ws,report) ((f,mutable),(changes,x)) -> if mutable then let rs = flip map changes $ \c -> (f, NewPacket $ showPacket (packet c)) in (ws++[(f,x)],report++rs) else let rs = flip map changes $ \c -> (f,MissingPacket (showPacket (packet c))) in (ws,report++rs) forM_ towrites $ \(f,x) -> do let m = Message $ map packet x -- warn $ "writing "++f L.writeFile f (encode m) return $ KikiSuccess report 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,wk),report1) -> do a <- return $ op KeyRingRuntime { rtPubring = pubring , rtSecring = secring , rtRings = [] -- todo secring:pubring:keyringFiles keyring , rtWallets = [] -- todo walletFiles keyring , rtGrip = grip , rtKeyDB = db } r <- writeWalletKeys keyring db wk try' r $ \report2 -> do r <- writeRingKeys keyring db wk secring pubring try' r $ \report3 -> do return $ KikiResult (KikiSuccess a) (report1 ++ report3) 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 -- | 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 <- 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 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] flattenTop fname ispub (KeyData key sigs uids subkeys) = unk ispub key : ( flattenAllUids fname ispub uids ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs unk :: Bool -> MappedPacket -> MappedPacket unk isPublic = if isPublic then toPacket secretToPublic else id where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] flattenUid fname ispub (str,(sigs,om)) = (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs {- 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