--------------------------------------------------------------------------- -- | -- Module : KeyRing -- -- Maintainer : joe@jerkface.net -- Stability : experimental -- -- kiki is a command-line utility for manipulating GnuPG's keyring files. This -- module is the programmer-facing API it uses to do that. -- -- Note: This is *not* a public facing API. I (the author) consider this -- library to be internal to kiki and subject to change at my whim. -- -- Typically, a client to this module would prepare a 'KeyRingOperation' -- describing what he wants done, and then invoke 'runKeyRing' to make it -- happen. {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where import System.Environment import Control.Monad import Control.Exception ( catch ) import System.IO.Error ( isDoesNotExistError ) import Data.Maybe import Data.Either import Data.Char import Data.Ord import Data.List import Data.OpenPGP import Data.Functor import Data.Monoid import Data.Tuple ( swap ) import Data.Bits ( (.|.), (.&.) ) import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) import Control.Arrow ( first, second ) import Data.OpenPGP.Util import Data.ByteString.Lazy ( ByteString ) import Text.Show.Pretty as PP ( ppShow ) import Data.Binary {- decode, decodeOrFail -} import ControlMaybe ( handleIO_ ) import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) ) import Data.ASN1.BitArray ( BitArray(..), toBitArray ) import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' ) import Data.ASN1.BinaryEncoding ( DER(..) ) import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds ) import Data.Time.Clock ( UTCTime ) import Data.Bits ( Bits, shiftR ) import Data.Text.Encoding ( encodeUtf8 ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S #if defined(VERSION_memory) import qualified Data.ByteString.Char8 as S8 import Data.ByteArray.Encoding #elif defined(VERSION_dataenc) import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 #endif #if !defined(VERSION_cryptonite) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Types.PubKey.ECC as ECC #else import qualified Crypto.Hash as Vincent import Data.ByteArray (convert) import qualified Crypto.PubKey.ECC.Types as ECC #endif import qualified Data.X509 as X509 import qualified Crypto.PubKey.RSA as RSA import qualified Codec.Compression.GZip as GZip import qualified Data.Text as T ( Text, unpack, pack, strip, reverse, drop, break, dropAround, length ) import qualified System.Posix.Types as Posix import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus , setFileCreationMask, setFileTimes ) #if MIN_VERSION_x509(1,5,0) import Data.Hourglass.Types import Data.Hourglass #endif #if MIN_VERSION_unix(2,7,0) import System.Posix.Files ( setFdTimesHiRes ) import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) #else import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) import Foreign.Marshal.Array ( withArray ) import Foreign.Ptr import Foreign.C.Error ( throwErrnoIfMinus1_ ) import Foreign.Storable #endif import System.FilePath ( takeDirectory ) import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose) import Data.IORef import System.Posix.IO ( fdToHandle ) import qualified Data.Traversable as Traversable import Data.Traversable ( sequenceA ) #if ! MIN_VERSION_base(4,6,0) import GHC.Exts ( Down(..) ) #endif #if MIN_VERSION_binary(0,7,0) import Debug.Trace #endif import Network.Socket -- (SockAddr) import qualified Data.ByteString.Lazy.Char8 as Char8 import Compat import TimeUtil import PEM import ScanningParser import qualified Hosts import qualified CryptoCoins import Base58 import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import GnuPGAgent as Agent import KeyRing.BuildKeyDB {- (accBindings, backsig, buildKeyDB, combineTransforms, concatSort, derRSA, derToBase32, filterMatches, findTag, fingerdress, flattenAllUids, flattenKeys, flattenSub, flattenTop, generateInternals, getBindings, getHostnames, getSubkeys, importSecretKey, insertSubkey, isKey, isSecretKey, isSubkeySignature, isUserID, keyFlags0, keyPacket, keyflags, keykey, mappedPacket, matchSpec, matchpr, merge, mergeKeyPacket, mkUsage, origin, packetFromPublicRSAKey, parseCertBlob, parseSingleSpec, parseSpec, parseUID, performManipulations, readInputFileL, readSecretPEMFile, resolveForReport, resolveInputFile, rsaKeyFromPacket, secp256k1_id, secretToPublic, seek_key, selectKey0, selectPublicKey, showPacket, sortByHint, subkeyMappedPacket, torhash, usageFromFilter) -} import KeyRing.Types import PacketTranscoder import Transforms data HomeDir = HomeDir { homevar :: String , appdir :: String , optfile_alts :: [String] } home :: HomeDir home = HomeDir { homevar = "GNUPGHOME" , appdir = ".gnupg" , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } isMutable :: StreamInfo -> Bool isMutable stream | KF_None <- fill stream = False isMutable _ = True filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] filesToLock k ctx = do (f,stream) <- Map.toList (opFiles k) case fill stream of KF_None -> [] _ -> resolveInputFile ctx f -- kret :: a -> KeyRingOperation a -- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey pkcs8 (RSAKey n e) = RSAKey8 n e instance ASN1Object PKCS8_RSAPublicKey where -- PKCS #8 Public key data toASN1 (RSAKey8 (MPI n) (MPI e)) = \xs -> Start Sequence : Start Sequence : OID [1,2,840,113549,1,1,1] : Null -- Doesn't seem to be neccessary, but i'm adding it -- to match PEM files I see in the wild. : End Sequence : BitString (toBitArray bs 0) : End Sequence : xs where pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ] bs = encodeASN1' DER pubkey fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" reportString :: KikiReportAction -> String reportString x = uncamel $ show x -- | Errors in kiki are indicated by the returning of this record. data KikiResult a = KikiResult { kikiCondition :: KikiCondition a -- ^ The result or a fatal error condition. , kikiReport :: KikiReport -- ^ A list of non-fatal warnings and informational messages -- along with the files that triggered them. } x509cert :: SignatureSubpacket -> Maybe Char8.ByteString x509cert (NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = u }) = Just (Char8.pack u) x509cert _ = Nothing getStr :: SingleKeySpec -> String getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" -- | Spec -- -- The product type, SingleKeySpec³ = Circle × Identity × Key. -- -- Key - A single public or private key (subkey, or master without subkeys) (eg, pem file) -- Identity - A single master key with all its subkeys -- Circle - A collection of master keys with their subkeys (eg, gpg file) -- -- The three fields are deliminated by slashes. -- -- When context does not disambiguate, use the following default rules: -- There are(is) -- - no slashes, so interpret as Key -- - one slash, so interpret as Identity/Key -- - two slashes, so interpret as Circle/Identity/Key -- -- (Any of the fields may be left empty.) type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec) data SpecError = SpecENone String | SpecEMissMatch String (Maybe MatchingField) MatchingField | SpecETooBig Spec | SpecETooMany String deriving (Eq,Show,Ord) -- t:tor -- (AnyMatch , AnyMatch, SubstringMatch type "tor") -- u:joe -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "" ) -- u:joe/ -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "!" ) -- fp:4A39F/tor -- (AnyMatch , FingerprintMatch "4A39F", SubstringMatch type "tor") -- u:joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/t:tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/fp:4abf30 -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "4abf30") -- joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe//fp:4abf30 -- (SubstringMatch user "joe", AnyMatch , FingerprintMatch "4abf30") -- c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch , FingerprintMatch "4abf3" ) -- -- where type = Just KeyTypeField -- user = Just UserIDField -- circ = Just GroupIDField -- | parseSpec3 - Parse a key specification. parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$> case fields of [] -> Left (SpecENone spec) xs@[t] -> let ds = [0] x = l ds xs getTup1 [x] = tupSection1 (adjustPos x maybeExpecting) x where tupSection1 0 = (AnyMatch,AnyMatch,) tupSection1 1 = (AnyMatch,,AnyMatch) tupSection1 2 = (,AnyMatch,AnyMatch) tupSection1 _ = tupSection1 0 in if all fst x then Right $ getTup1 (map (fst . snd) x) else Left $ mismatch x xs@[u,t] -> let ds = [1,0] x = l ds xs getTup2 [u,t] = indexHole (head (filter (`notElem` gots [u,t]) [0..2])) u t where gots xs = zipWith gotIndex [1,0] xs indexHole 0 = (,,AnyMatch) indexHole 1 = (,AnyMatch,) indexHole 2 = (AnyMatch,,) in if all fst x then Right $ getTup2 (map (fst . snd) x) else Left $ mismatch x xs@[c,u,t] -> let ds = [2,1,0] x = l ds xs getTup3 [a,b,c] = (a,b,c) in if all fst x then Right $ getTup3 (map (fst . snd) x) else Left $ mismatch x _ -> Left (SpecETooMany spec) where expectIndex dflt = maybe dflt fromEnum maybeExpecting l :: [Int] -> [String] -> [(Bool, (SingleKeySpec,Int))] l defaults specs = zipWith (\x y -> (valid (p x) y, (p x,y))) specs defaults where p x = parseSingleSpec x valid :: SingleKeySpec -> Int -> Bool valid spec dflt = ("tuc"::String) !! gotIndex dflt spec `notElem` forbidden (gotIndex dflt spec) where forbidden 0 = "uc" :: [Char] forbidden 1 = "tc" forbidden 2 = "tu" adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0 adjustPos (SubstringMatch (Just UserIDField) _) Nothing = 1 adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2 adjustPos _ (Just i) = fromEnum i gotIndex :: Int -> SingleKeySpec -> Int gotIndex dflt (SubstringMatch (Just got) _) = fromEnum got gotIndex dflt _ = dflt -- FIXME: This throws an exception if input is -- not an erroneous SubstringMatch. mismatch :: [(Bool,(SingleKeySpec,Int))] -> SpecError mismatch xs = case find (not . fst) (reverse xs) of Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n) fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t) where set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs set _ EmptyMatch = AnyMatch set field x = x applyContext :: Maybe MatchingField -> Spec -> Spec applyContext Nothing x = x applyContext (Just KeyTypeField) ((AnyMatch,u,AnyMatch)) = (AnyMatch,AnyMatch,u) applyContext (Just KeyTypeField) ((g,u,AnyMatch)) = (g,AnyMatch,u) applyContext (Just KeyTypeField) x = x applyContext (Just UserIDField) ((AnyMatch,AnyMatch,x)) = (AnyMatch,x,AnyMatch) applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x) applyContext (Just UserIDField) x = x applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch) applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x) applyContext (Just GroupIDField) x = x --applyContext (Just UserIDField) (Right (g,u,x)) = Left $ -- SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $ SpecEMissMatch str (Just GroupIDField) KeyTypeField tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $ SpecEMissMatch str (Just GroupIDField) UserIDField tooBigError Nothing x = return x tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $ SpecETooBig s -- (getStr g) (Just GroupIDField) UserIDField tooBigError (Just KeyTypeField) s@(g,u,t) | g /= AnyMatch = Left $ SpecETooBig s --(getStr g) (Just GroupIDField) KeyTypeField tooBigError _ x = return x wordsBy :: Eq a => a -> [a] -> [[a]] wordsBy _ [] = [] wordsBy c xs = let (b,a) = span (/=c) xs in b:wordsBy c (drop 1 a) {- - BUGGY parseSpec grip spec = (topspec,subspec) where (topspec0,subspec0) = unprefix '/' spec (toptyp,top) = unprefix ':' topspec0 (subtyp,sub) = unprefix ':' subspec0 topspec = case () of _ | null top && or [ subtyp=="fp" , null subtyp && is40digitHex sub ] -> KeyGrip sub _ | null top && null grip -> KeyUidMatch sub _ | null top -> KeyGrip grip _ | toptyp=="fp" || (null toptyp && is40digitHex top) -> KeyGrip top _ | toptyp=="u" -> KeyUidMatch top _ -> KeyUidMatch top subspec = case subtyp of "t" -> Just sub "fp" | top=="" -> Nothing "" | top=="" && is40digitHex sub -> Nothing "" -> listToMaybe sub >> Just sub _ -> Nothing is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True | 'A' <= c && c <= 'F' = True | 'a' <= c && c <= 'f' = True ishex c = False -- | Split a string into two at the first occurance of the given -- delimiter. If the delimeter does not occur, then the first -- item of the returned pair is empty and the second item is the -- input string. unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) where p = break (==c) spec -} filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' where matchAll = KeyGrip "" subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) match spec mps = not . null . snd . seek_key spec . map packet $ mps old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub) oldOrMatch spec sub = old sub || match spec (flattenSub "" True sub) subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty) then oldOrMatch subspec else old) subs where (topspec,subspec) = subkeySpec spec selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of Nothing -> do (kk,r) <- Map.toList $ fmap (findbyspec spec) db (sub,sigs) <- r return (kk,sub,sigs) Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) findbyspec (KeyGrip g) kd = do filter ismatch $ topresult kd : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) (Map.elems $ keySubKeys kd) where ismatch (p,sigs) = matchpr g p ==g findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag where gettag (SubKey sub sigs) = do let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs (hastag,_) <- maybeToList mb guard hastag return $ (kk, packet sub, map (packet . fst) sigs) {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps y <- take 1 ys case mtag of Nothing -> return (y,Nothing) Just tag -> let search ys1 = do let zs = snd $ seek_key (KeyTag y tag) ys1 z <- take 1 zs (y,Just z):search (drop 1 zs) in search (drop 1 ys) -} writeInputFileL :: InputFileContext -> InputFile -> ByteString -> IO () writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx inp bs = do let fname = resolveInputFile ctx inp mapM_ (`L.writeFile` bs) fname -- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () -- writeStamped0 :: InputFileContext -> InputFile getWriteFD :: InputFile -> Maybe Posix.Fd getWriteFD (Pipe _ fd) = Just fd getWriteFD (FileDesc fd) = Just fd getWriteFD _ = Nothing writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> (Either Handle FilePath -> t -> IO ()) -> t -> IO () writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do h <- fdToHandle fd dowrite (Left h) bs handleIO_ (return ()) $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp) writeStamped0 ctx inp stamp dowrite bs = do let fname = resolveInputFile ctx inp forM_ fname $ \fname -> do createDirectoryIfMissing True $ takeDirectory fname dowrite (Right fname) bs setFileTimes fname stamp stamp {- This may be useful later. Commented for now, as it is not used. - writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs -} writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str {- - This may be useful later. Commented for now as it is not used. - doesInputFileExist :: InputFileContext -> InputFile -> IO Bool doesInputFileExist ctx f = do case resolveInputFile ctx f of [n] -> doesFileExist n _ -> return True -} writeHostsFiles :: KeyRingOperation -> InputFileContext -> ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, (t1, [Char8.ByteString]))], [SockAddr]) -> IO [(FilePath, KikiReportAction)] writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do let hns = files isMutableHosts isMutableHosts stream | KF_None <- fill stream = False isMutableHosts stream | Hosts <- typ stream = True isMutableHosts _ = False files istyp = do (f,stream) <- Map.toList (opFiles krd) guard (istyp stream) return f -- resolveInputFile ctx f -- 3. add hostnames from gpg for addresses not in U let u = foldl' f u1 ans ans = reverse $ do (addr,(_,ns)) <- gpgnames guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 n <- ns return (addr,n) f h (addr,n) = Hosts.assignNewName addr n h -- 4. for each host db H, union H with U and write it out as H' -- only if there is a non-empty diff rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do let h = h1 `Hosts.plus` u d = Hosts.diff h0 h rs = map ((fname,) . HostsDiff) d unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h return $ map (first $ resolveForReport $ Just ctx) rs return $ concat rss unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do r <- action case r of KikiSuccess x -> return x e -> error $ errorString e -- No instance for (ASN1Object RSA.PublicKey) decodeBlob :: ParsedCert -> ByteString decodeBlob cert = if 0 /= (bs `L.index` 0) .&. 0x10 then bs else let (keypos0,bs') = L.splitAt 2 bs keypos :: Word16 keypos = decode keypos0 ds = GZip.decompress bs' (prekey,postkey) = L.splitAt (fromIntegral keypos) ds in prekey <> key <> postkey where bs = pcertBlob cert key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert isCryptoCoinKey :: Packet -> Bool isCryptoCoinKey p = and [ isKey p , key_algorithm p == ECDSA , lookup 'c' (key p) == Just (MPI secp256k1_id) ] getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork getCryptoCoinTag p | isSignaturePacket p = do -- CryptoCoins.secret let sps = hashed_subpackets p ++ unhashed_subpackets p u <- listToMaybe $ mapMaybe usage sps CryptoCoins.lookupNetwork CryptoCoins.network_name u getCryptoCoinTag _ = Nothing coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)] coinKeysOwnedBy db wk = do wk <- maybeToList wk let kk = keykey wk KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db (subkk,SubKey mp sigs) <- Map.toList subs let sub = packet mp guard $ isCryptoCoinKey sub tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs return (tag,mp) walletImportFormat :: Word8 -> Packet -> String walletImportFormat idbyte k = secret_base58_foo where -- isSecret (SecretKeyPacket {}) = True -- isSecret _ = False secret_base58_foo = base58_encode seckey Just d = lookup 'd' (key k) (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) seckey = S.cons idbyte bigendian writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeWalletKeys krd db wk = do let cs = db `coinKeysOwnedBy` wk -- export wallet keys isMutableWallet stream | KF_None <- fill stream = False isMutableWallet stream | WalletFile {} <- typ stream = True isMutableWallet _ = False files pred = do (f,stream) <- Map.toList (opFiles krd) guard (pred stream) resolveInputFile (InputFileContext "" "") f let writeWallet report n = do let cs' = do (nw,mp) <- cs -- let fns = Map.keys (locations mp) -- trace ("COIN KEY: "++show fns) $ return () guard . not $ Map.member n (locations mp) let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) return (CryptoCoins.network_name nw,wip) handleIO_ (return report) $ do -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based -- to InputFile-based. withFile n AppendMode $ \fh -> do rs <- forM cs' $ \(net,wip) -> do hPutStrLn fh wip return (n, NewWalletKey net) return (report ++ rs) report <- foldM writeWallet [] (files isMutableWallet) return $ KikiSuccess report -- | returns Just True so as to indicate that -- the public portions of keys will be imported importPublic :: Maybe Bool importPublic = Just True -- | returns False True so as to indicate that -- the public portions of keys will be imported importSecret :: Maybe Bool importSecret = Just False -- TODO: Do we need to memoize this? guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () guardAuthentic rt keydata = guard (isauth rt keydata) isauth :: KeyRingRuntime -> KeyData -> Bool isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk where wk = workingKey (rtGrip rt) (rtKeyDB rt) dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) $ locations p has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids where goodsig (uidstr,(sigs,_)) = not . null $ do sig0 <- fmap (packet . fst) sigs pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0]) signatures_over $ verify (Message [wk]) pre_ov workingKey grip use_db = listToMaybe $ do fp <- maybeToList grip elm <- Map.elems use_db guard $ matchSpec (KeyGrip fp) elm return $ keyPacket elm writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message -> [(FilePath,KikiReportAction)] {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do let isring (KeyRingFile {}) = True isring _ = False db = rtKeyDB rt secring = rtSecring rt pubring = rtPubring rt ctx = InputFileContext secring pubring let s = do (f,f0,stream) <- do (f0,stream) <- Map.toList (opFiles krd) guard (isring $ typ stream) f <- resolveInputFile ctx f0 return (f,f0,stream) let db' = fromMaybe db $ do msg <- Map.lookup f0 unspilled return $ merge db f0 msg x = do let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool wantedForFill acc KF_None = importByExistingMaster -- Note the KF_None case is almost irrelevent as it will be -- filtered later when isMutable returns False. -- We use importByExistingMaster in order to generate -- MissingPacket warnings. To disable those warnings, use -- const Nothing instead. wantedForFill acc (KF_Match {}) = importByExistingMaster wantedForFill acc KF_Subkeys = importByExistingMaster wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd importByAccess acc kd wantedForFill acc KF_All = importByAccess acc importByAccess Pub kd = importPublic importByAccess Sec kd = importSecret importByAccess AutoAccess kd = mplus (importByExistingMaster kd) (error $ f ++ ": write public or secret key to file?") importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p d <- sortByHint f keyMappedPacket (Map.elems db') acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d guard $ only_public || isSecretKey (keyPacket d) case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt flattenTop f only_public $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 _ -> flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) -- TODO: We depend on an exact string match between the reported -- file origin of the deleted packet and the path of the file we are -- writing. Verify that this is a safe assumption. isdeleted (f',DeletedPacket _) = f'==f isdeleted _ = False guard (not (null new_packets) || any isdeleted report_manips) return ((f0,isMutable stream),(new_packets,x)) let (towrites,report) = (\f -> foldl f ([],[]) s) $ \(ws,report) ((f,mutable),(new_packets,x)) -> if mutable then let rs = flip map new_packets $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c)) in (ws++[(f,x)],report++rs) else let rs = flip map new_packets $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c))) in (ws,report++rs) forM_ towrites $ \(f,x) -> do let m = Message $ map packet x -- warn $ "writing "++f writeInputFileL ctx f (encode m) return $ KikiSuccess report {- getSubkeysForExport kk subspec db = do kd <- maybeToList $ Map.lookup kk db subkeysForExport subspec kd -} -- | If provided Nothing for the first argument, this function returns the -- master key of the given identity. Otherwise, it returns all the subkeys of -- the given identity which have a usage tag that matches the first argument. subkeysForExport :: Maybe String -> KeyData -> [MappedPacket] subkeysForExport subspec (KeyData key _ _ subkeys) = do let subs tag = do e <- Map.elems subkeys guard $ doSearch key tag e return $ subkeyMappedPacket e maybe [key] subs subspec where doSearch key tag (SubKey sub_mp sigtrusts) = let (_,v,_) = findTag [mkUsage tag] (packet key) (packet sub_mp) sigtrusts in fmap fst v==Just True data PemType = PemPublicKey | PemPrivateKey | PemCertificate pemTypeString :: PemType -> String pemTypeString PemPublicKey = "PUBLIC KEY" pemTypeString PemPrivateKey = "PRIVATE KEY" pemTypeString PemCertificate = "CERTIFICATE" writePEM :: PemType -> String -> String writePEM (pemTypeString -> typ) dta = pem where pem = unlines . concat $ [ ["-----BEGIN " <> typ <> "-----"] , split64s dta , ["-----END " <> typ <> "-----"] ] split64s :: String -> [String] split64s "" = [] split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta -- 64 byte lines rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do -- public fields... n <- lookup 'n' $ key pkt e <- lookup 'e' $ key pkt -- secret fields MPI d <- lookup 'd' $ key pkt MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped -- Note: Here we fail if 'u' key is missing. -- Ideally, it would be better to compute (inverse q) mod p -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg -- (package constructive-algebra) coefficient <- lookup 'u' $ key pkt let dmodp1 = MPI $ d `mod` (p - 1) dmodqminus1 = MPI $ d `mod` (q - 1) return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = dmodp1 , rsaDmodQminus1 = dmodqminus1 , rsaCoefficient = coefficient } rsaPrivateKeyFromPacket _ = Nothing secretPemFromPacket :: Packet -> Maybe String secretPemFromPacket packet = pemFromPacket Sec packet pemFromPacket :: Access -> Packet -> Maybe String pemFromPacket Sec packet = case key_algorithm packet of RSA -> do rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey let asn1 = toASN1 rsa [] bs = encodeASN1 DER asn1 #if defined(VERSION_memory) dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) #elif defined(VERSION_dataenc) dta = Base64.encode (L.unpack bs) #endif output = writePEM PemPrivateKey dta Just output algo -> Nothing pemFromPacket Pub packet = case key_algorithm packet of RSA -> do rsa <- rsaKeyFromPacket packet let asn1 = toASN1 (pkcs8 rsa) [] bs = encodeASN1 DER asn1 #if defined(VERSION_memory) dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) #elif defined(VERSION_dataenc) dta = Base64.encode (L.unpack bs) #endif output = writePEM PemPublicKey dta Just output algo -> Nothing pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p pemFromPacket AutoAccess _ = Nothing writeKeyToFile :: StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] writeKeyToFile stream@(StreamInfo { typ = PEMFile }) fname packet = do case pemFromPacket (access stream) packet of Just output -> do let stamp = toEnum . fromEnum $ timestamp packet handleIO_ (return [(fname, FailedFileWrite)]) $ do saved_mask <- setFileCreationMask 0o077 -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. writeStamped (InputFileContext "" "") fname stamp output setFileCreationMask saved_mask return [(fname, ExportedSubkey)] Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do case key_algorithm packet of RSA -> do flip (maybe (return [])) (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey $ \rsa -> do let -- asn1 = toASN1 rsa [] -- bs = encodeASN1 DER asn1 -- dta = Base64.encode (L.unpack bs) #if defined(VERSION_memory) b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i #elif defined(VERSION_dataenc) b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) #endif where MPI i = ac rsa i2bs_unsized :: Integer -> S.ByteString i2bs_unsized 0 = S.singleton 0 i2bs_unsized i = S.reverse $ S.unfoldr go i where go i' = if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8)) output = unlines [ "Private-key-format: v1.2" , "Algorithm: 8 (RSASHA256)" , "Modulus: " ++ b64 rsaN rsa , "PublicExponent: " ++ b64 rsaE rsa , "PrivateExponent: " ++ b64 rsaD rsa , "Prime1: " ++ b64 rsaP rsa , "Prime2: " ++ b64 rsaQ rsa , "Exponent1: " ++ b64 rsaDmodP1 rsa , "Exponent2: " ++ b64 rsaDmodQminus1 rsa , "Coefficient: " ++ b64 rsaCoefficient rsa ] stamp = toEnum . fromEnum $ timestamp packet handleIO_ (return [(fname, FailedFileWrite)]) $ do saved_mask <- setFileCreationMask 0o077 -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. writeStamped (InputFileContext "" "") fname stamp output setFileCreationMask saved_mask return [(fname, ExportedSubkey)] algo -> return [(fname, UnableToExport algo $ fingerprint packet)] writePEMKeys :: (PacketDecrypter) -> KeyDB -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] -> IO (KikiCondition [(FilePath,KikiReportAction)]) writePEMKeys doDecrypt db exports = do ds <- mapM decryptKeys exports let ds' = map functorToEither ds if null (lefts ds') then do rs <- mapM (\(f,stream,p) -> writeKeyToFile stream (ArgFile f) p) (rights ds') return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) else do return (head $ lefts ds') where decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub })) = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted. decryptKeys (fname,subspec,[p],stream) = do pun <- doDecrypt p try pun $ \pun -> do return $ KikiSuccess (fname,stream,pun) initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext -> Maybe String -> Maybe MappedPacket -> PacketTranscoder -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , StreamInfo )]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation ctx grip mwk transcode db = do let decrypt = transcode (Unencrypted,S2K 100 "") -- nonexistants - files missing from disk. nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (opFiles operation) f <- resolveInputFile ctx f return (f,t) -- missing - mutable files not in the keyring and not on disk -- notmissing - mutable keys in the keyring, but not on disk let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do (fname,stream) <- nonexistents let mutableTag | isMutable stream = usageFromFilter (fill stream) | otherwise = Nothing usage <- maybeToList mutableTag -- TODO: Use parseSpec3 -- TODO: Report error if generating without specifying usage tag. let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage -- ms will contain duplicates if a top key has multiple matching -- subkeys. This is intentional. -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db -- ms = filterMatches topspec $ Map.toList db ns = do (kk,kd) <- filterMatches topspec $ Map.toList db return (kk , subkeysForExport subspec kd) return (fname,subspec,ns,stream) (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) notmissing exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0 ambiguity (f,topspec,subspec,_) = do return $ AmbiguousKeySpec f ifnotnull (x:xs) f g = f x ifnotnull _ f g = g ifnotnull ambiguous ambiguity $ do -- create nonexistent files via external commands do let cmds = mapMaybe getcmd missing where getcmd (fname,subspec,ms,stream) = do cmd <- case initializer stream of External str -> Just str _ -> Nothing return (fname,subspec,ms,stream,cmd) rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do e <- systemEnv [ ("file",fname) , ("usage",fromMaybe "" subspec) ] cmd case e of ExitFailure num -> return (tup,FailedExternal num) ExitSuccess -> return (tup,ExternallyGeneratedFile) v <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) $ do ((f,subspec,ms,stream,cmd),r) <- rs guard $ case r of ExternallyGeneratedFile -> True _ -> False return (ArgFile f,subspec,map fst ms,stream,cmd) try v $ \(db,import_rs) -> do -- generateInternals let internals = mapMaybe getParams $ do (f,stream) <- nonexistents usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage guard $ null $ do (kk,kd) <- filterMatches topspec $ Map.toList db subkeysForExport subspec kd return (f,stream) where getParams (fname,stream) = case initializer stream of Internal p -> do _ <- internalInitializer stream Just $ Right (p, stream) WarnMissing warning -> Just $ Left warning _ -> Nothing internalInitializer StreamInfo { initializer = Internal _ , spill = KF_Match tag } = Just tag internalInitializer _ = Nothing mapM_ (hPutStrLn stderr) (lefts internals) v <- generateInternals transcode mwk db (rights internals) try v $ \(db,internals_rs) -> do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) -- FIXME: try' should probably accept a list of KikiReportActions. -- This would be useful for reporting on disk writes that have already -- succeded prior to this termination. try' :: Monad m => KikiCondition t -> (t -> m (KikiResult a)) -> m (KikiResult a) try' v body = case functorToEither v of Left e -> return $ KikiResult e [] Right wkun -> body wkun -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = do -- get homedir and keyring files + fingerprint for working key homedir <- getHomeDir (opHome operation) try' homedir $ \(_homedir, secring, pubring, grip0) -> do let ctx = InputFileContext secring pubring tolocks = filesToLock operation ctx secring <- return Nothing pubring <- return Nothing (locks :: [(Maybe DotLock, FilePath)]) <- forM tolocks $ \f -> do createDirectoryIfMissing True $ takeDirectory f lk <- dotlock_create f 0 v <- flip (maybe $ return Nothing) lk $ \lk -> do e <- dotlock_take lk (-1) if e==0 then return $ Just lk else dotlock_destroy lk >> return Nothing return (v,f) let (lked, map snd -> failed_locks) = partition (isJust . fst) locks ret <- if not $ null failed_locks then return $ KikiResult (FailedToLock failed_locks) [] else realRunKeyRing ctx grip0 operation forM_ lked $ \(Just lk, fname) -> dotlock_release lk return ret realRunKeyRing :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiResult KeyRingRuntime) realRunKeyRing ctx grip0 operation = do bresult <- buildKeyDB ctx grip0 operation try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx grip wk transcode db try' externals_ret $ \((db, exports), report_externals) -> do let decrypt = transcode (Unencrypted,S2K 100 "") rt = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db , rtRingAccess = accs , rtPassphrases = transcode } -- Maybe add signatures, delete subkeys r <- performManipulations decrypt rt wk (combineTransforms $ opTransforms operation) try' r $ \(rt,report_manips) -> do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do r <- writeRingKeys operation rt unspilled report_manips try' r $ \report_rings -> do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do import_hosts <- writeHostsFiles operation ctx hs return $ KikiResult (KikiSuccess rt) $ concat [ report_imports , report_externals , report_manips , report_wallets , report_rings , report_pems ] parseOptionFile :: FilePath -> IO [String] parseOptionFile fname = do xs <- fmap lines (readFile fname) let ys = filter notComment xs notComment ('#':_) = False notComment cs = not (all isSpace cs) return ys -- | returns ( home directory -- , path to secret ring -- , path to public ring -- , fingerprint of working key -- ) getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) getHomeDir protohome = do homedir <- envhomedir protohome flip (maybe (return CantFindHome)) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" pubring = homedir ++ "/" ++ "pubring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return $ KikiSuccess (homedir,secring,pubring,workingkey) where envhomedir opt = do gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home) homed <- fmap (mfilter (/="") . Just) getHomeDirectory let homegnupg = (++('/':(appdir home))) <$> homed let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val -- TODO: rename this to getGrip getWorkingKey homedir = do let o = Nothing h = Just homedir ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) (optfile_alts home) o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return []) ofile $ \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) return $ lookup "default-key" config >>= listToMaybe #if MIN_VERSION_base(4,6,0) #else lookupEnv :: String -> IO (Maybe String) lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif {- onionName :: KeyData -> (SockAddr,L.ByteString) onionName kd = (addr,name) where (addr,(name:_,_)) = getHostnames kd -} #if ! MIN_VERSION_unix(2,7,0) setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () setFdTimesHiRes (Posix.Fd fd) atime mtime = withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) data CTimeSpec = CTimeSpec Posix.EpochTime CLong instance Storable CTimeSpec where sizeOf _ = (16) alignment _ = alignment (undefined :: CInt) poke p (CTimeSpec sec nsec) = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec peek p = do sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p return $ CTimeSpec sec nsec toCTimeSpec :: POSIXTime -> CTimeSpec toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac) where (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') (sec', frac') = properFraction $ toRational t foreign import ccall unsafe "futimens" c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt #endif