--------------------------------------------------------------------------- -- | -- 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 DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing (module KeyRing.Types, module Transforms, module PacketTranscoder, module KeyRing, module KeyRing.BuildKeyDB) where import System.Environment import Control.Monad import Data.Bool import Data.Maybe import Data.Either import Data.Char import Data.List import Data.OpenPGP import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) import Control.Arrow ( first, second ) import Data.OpenPGP.Util import Data.ByteString.Lazy ( ByteString ) import Data.Binary {- decode, decodeOrFail -} import ControlMaybe ( handleIO_ ) import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) ) import Data.ASN1.BitArray ( BitArray(..), toBitArray ) import Data.ASN1.Encoding (decodeASN1', encodeASN1, encodeASN1' ) import Data.ASN1.BinaryEncoding ( DER(..) ) import Data.Bits ((.&.), shiftR ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteArray.Encoding import qualified Codec.Compression.GZip as GZip import GHC.Stack import qualified System.Posix.Types as Posix import System.Posix.Files (setFileCreationMask, setFileTimes ) import System.Posix.Files ( setFdTimesHiRes ) import System.FilePath ( takeDirectory ) import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose) import System.Posix.IO ( fdToHandle ) import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Codec.Encryption.OpenPGP.ASCIIArmor as ASCIIArmor import Codec.Encryption.OpenPGP.ASCIIArmor.Types import qualified Hosts import qualified CryptoCoins import Base58 import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import KeyRing.BuildKeyDB (allNames', Hostnames, IPsToWriteToHostsFile(..), buildKeyDB, combineTransforms, filterMatches, fingerdress, generateInternals, getHostnames, getSubkeys, importSecretKey, insertSubkey, matchSpec, merge, packetFromPublicRSAKey, parseCertBlob, parseSingleSpec, parseSpec, readInputFileL, readSecretPEMFile, secp256k1_id, selectPublicKey, usageFromFilter) import KeyRing.Types import KeyDB import PacketTranscoder import Transforms data HomeDir = HomeDir { homevar :: String , appdir :: String , optfile_alts :: [String] } home :: HomeDir home = HomeDir { homevar = "GNUPGHOME" , appdir = ".gnupg" , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } isMutable :: StreamInfo -> Bool isMutable stream | KF_None <- fill stream = False isMutable _ = True filesToLock :: (Map.Map InputFile StreamInfo) -> InputFileContext -> [FilePath] filesToLock opfiles ctx = do (f,stream) <- Map.toList opfiles case fill stream of KF_None -> [] _ -> resolveInputFile ctx f -- kret :: a -> KeyRingOperation a -- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey pkcs8 (RSAKey n e) = RSAKey8 n e instance ASN1Object PKCS8_RSAPublicKey where -- PKCS #8 Public key data toASN1 (RSAKey8 (MPI n) (MPI e)) = \xs -> Start Sequence : Start Sequence : OID [1,2,840,113549,1,1,1] : Null -- Doesn't seem to be neccessary, but i'm adding it -- to match PEM files I see in the wild. : End Sequence : BitString (toBitArray bs 0) : End Sequence : xs where pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ] bs = encodeASN1' DER pubkey fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" reportString :: KikiReportAction -> String reportString x = uncamel $ show x -- | Errors in kiki are indicated by the returning of this record. data KikiResult a = KikiResult { kikiCondition :: KikiCondition a -- ^ The result or a fatal error condition. , kikiReport :: KikiReport -- ^ A list of non-fatal warnings and informational messages -- along with the files that triggered them. } x509cert :: SignatureSubpacket -> Maybe Char8.ByteString x509cert (NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = u }) = Just (Char8.pack u) x509cert _ = Nothing {- getStr :: SingleKeySpec -> String getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" -} -- | Spec -- -- The product type, SingleKeySpec³ = Circle × Identity × Key. -- -- Key - A single public or private key (subkey, or master without subkeys) (eg, pem file) -- Identity - A single master key with all its subkeys -- Circle - A collection of master keys with their subkeys (eg, gpg file) -- -- The three fields are deliminated by slashes. -- -- When context does not disambiguate, use the following default rules: -- There are(is) -- - no slashes, so interpret as Key -- - one slash, so interpret as Identity/Key -- - two slashes, so interpret as Circle/Identity/Key -- -- (Any of the fields may be left empty.) type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec) data SpecError = SpecENone String | SpecEMissMatch String (Maybe MatchingField) MatchingField | SpecETooBig Spec | SpecETooMany String deriving (Eq,Show,Ord) -- t:tor -- (AnyMatch , AnyMatch, SubstringMatch type "tor") -- u:joe -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "" ) -- u:joe/ -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "!" ) -- fp:4A39F/tor -- (AnyMatch , FingerprintMatch "4A39F", SubstringMatch type "tor") -- u:joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/t:tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/fp:4abf30 -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "4abf30") -- joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe//fp:4abf30 -- (SubstringMatch user "joe", AnyMatch , FingerprintMatch "4abf30") -- c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch , FingerprintMatch "4abf3" ) -- -- where type = Just KeyTypeField -- user = Just UserIDField -- circ = Just GroupIDField -- | parseSpec3 - Parse a key specification. -- -- TODO: This is currently unused. 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 = KeyFP 0 "" subkeySpec (KeyFP ver grip,Nothing) = (matchAll, KeyFP ver grip) subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) subkeySpec (KeyTag p tag, Nothing) = (matchAll, KeyTag p tag) subkeySpec (KeyUidMatch u, Nothing) = (KeyUidMatch u, matchAll) 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) <- fmap (second $ findbyspec spec) (kkData db) (sub,sigs) <- r return (kk,sub,sigs) Just tag -> filterMatches spec (kkData db) >>= findsubs tag where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) findbyspec (KeyFP ver 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 ver g p ==g findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag where gettag (SubKey sub sigs) = do let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs (hastag,_) <- maybeToList mb guard hastag return $ (kk, packet sub, map (packet . fst) sigs) {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps y <- take 1 ys case mtag of Nothing -> return (y,Nothing) Just tag -> let search ys1 = do let zs = snd $ seek_key (KeyTag y tag) ys1 z <- take 1 zs (y,Just z):search (drop 1 zs) in search (drop 1 ys) -} writeInputFileL :: InputFileContext -> InputFile -> ByteString -> IO () writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx inp bs = do let fname = resolveInputFile ctx inp mapM_ (`L.writeFile` bs) fname -- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () -- writeStamped0 :: InputFileContext -> InputFile getWriteFD :: InputFile -> Maybe Posix.Fd getWriteFD (Pipe _ fd) = Just fd getWriteFD (FileDesc fd) = Just fd getWriteFD _ = Nothing writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> (Either Handle FilePath -> t -> IO ()) -> t -> IO () writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do h <- fdToHandle fd dowrite (Left h) bs handleIO_ (return ()) $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp) writeStamped0 ctx inp stamp dowrite bs = do let fname = resolveInputFile ctx inp forM_ fname $ \fname -> do createDirectoryIfMissing True $ takeDirectory fname dowrite (Right fname) bs setFileTimes fname stamp stamp {- This may be useful later. Commented for now, as it is not used. - writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs -} writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str {- - This may be useful later. Commented for now as it is not used. - doesInputFileExist :: InputFileContext -> InputFile -> IO Bool doesInputFileExist ctx f = do case resolveInputFile ctx f of [n] -> doesFileExist n _ -> return True -} writeHostsFiles :: KeyRingOperation -> InputFileContext -> ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [Hostnames], IPsToWriteToHostsFile) -> IO [(FilePath, KikiReportAction)] writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,IPsToWriteToHostsFile outgoing_names) = do let hns = files isMutableHosts isMutableHosts stream | KF_None <- fill stream = False isMutableHosts stream | Hosts <- typ stream = True isMutableHosts _ = False files istyp = do (f,stream) <- Map.toList (opFiles krd) guard (istyp stream) return f -- resolveInputFile ctx f -- 3. add hostnames from gpg for addresses not in U let u = foldl' f u1 ans ans = reverse . filter ((`elem` outgoing_names) . fst) . concat $ allNames' <$> gpgnames 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 :: HasCallStack => 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 $ lookupKeyData 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 $ first unUidString <$> 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 <- keyData use_db guard $ matchSpec (KeyFP 0 fp) elm return $ keyPacket elm mkarmor :: Access -> L.ByteString -> [Armor] mkarmor access bs = [Armor typ [] bs] where typ = case access of Pub -> ArmorPublicKeyBlock Sec -> ArmorPrivateKeyBlock AutoAccess -> ArmorPrivateKeyBlock -- I don't know, so don't make it look sharable. writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message -> [(FilePath,KikiReportAction)] {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do let isring (KeyRingFile {}) = True isring _ = False db = rtKeyDB rt secring = rtSecring rt pubring = rtPubring rt ctx = InputFileContext secring pubring let s = do (f,f0,stream) <- do (f0,stream) <- Map.toList (opFiles krd) guard (isring $ typ stream) f <- resolveInputFile ctx f0 return (f,f0,stream) let db' = fromMaybe db $ do msg <- Map.lookup f0 unspilled return $ merge db f0 msg x = do let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool wantedForFill acc KF_None = importByExistingMaster -- Note the KF_None case is almost irrelevent as it will be -- filtered later when isMutable returns False. -- We use importByExistingMaster in order to generate -- MissingPacket warnings. To disable those warnings, use -- const Nothing instead. wantedForFill acc (KF_Match {}) = importByExistingMaster wantedForFill acc KF_Subkeys = importByExistingMaster wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd importByAccess acc kd wantedForFill acc KF_All = importByAccess acc importByAccess Pub kd = importPublic importByAccess Sec kd = importSecret importByAccess AutoAccess kd = mplus (importByExistingMaster kd) (error $ f ++ ": write public or secret key to file?") importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p d <- sortByHint f keyMappedPacket (keyData db') acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d guard $ only_public || isSecretKey (keyPacket d) case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt flattenTop f only_public $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 _ -> flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) -- TODO: We depend on an exact string match between the reported -- file origin of the deleted packet and the path of the file we are -- writing. Verify that this is a safe assumption. isdeleted (f',DeletedPacket _) = f'==f isdeleted _ = False guard (not (null new_packets) || any isdeleted report_manips) return ((f0,stream),(new_packets,x)) let (towrites,report) = foldl' go ([],[]) s where go (ws,report) ((f,stream),(new_packets,x)) = (ws++writes, report++(items <$> new_packets)) where mutable = isMutable stream writes | mutable = [(stream,f,x)] | otherwise = [] items c = ( concat $ resolveInputFile ctx f , bool MissingPacket NewPacket mutable $ showPacket (packet c) ) forM_ towrites $ \(stream,f,xs) -> do let encoding = case typ stream of PGPPackets AsciiArmor -> AsciiArmor _ -> BinaryPackets enc = case encoding of BinaryPackets -> id AsciiArmor -> ASCIIArmor.encodeLazy . mkarmor (access stream) writeInputFileL ctx f $ enc $ encode $ Message $ map packet xs return $ KikiSuccess report {- getSubkeysForExport kk subspec db = do kd <- maybeToList $ Map.lookup kk db subkeysForExport subspec kd -} -- | If provided Nothing for the first argument, this function returns the -- master key of the given identity. Otherwise, it returns all the subkeys of -- the given identity which have a usage tag that matches the first argument. subkeysForExport :: Maybe String -> KeyData -> [MappedPacket] subkeysForExport subspec (KeyData key _ _ subkeys) = do let subs tag = do e <- Map.elems subkeys guard $ doSearch key tag e return $ subkeyMappedPacket e maybe [key] subs subspec where doSearch key tag (SubKey sub_mp sigtrusts) = let (_,v,_) = findTag [mkUsage tag] (packet key) (packet sub_mp) sigtrusts in fmap fst v==Just True data PemType = PemPublicKey | PemPrivateKey | PemCertificate pemTypeString :: PemType -> String pemTypeString PemPublicKey = "PUBLIC KEY" pemTypeString PemPrivateKey = "RSA 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 dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) 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 dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) 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) $ show $ 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) b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i where MPI i = ac rsa i2bs_unsized :: Integer -> S.ByteString i2bs_unsized 0 = S.singleton 0 i2bs_unsized i = S.reverse $ S.unfoldr go i where go i' = if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8)) output = unlines [ "Private-key-format: v1.2" , "Algorithm: 8 (RSASHA256)" , "Modulus: " ++ b64 rsaN rsa , "PublicExponent: " ++ b64 rsaE rsa , "PrivateExponent: " ++ b64 rsaD rsa , "Prime1: " ++ b64 rsaP rsa , "Prime2: " ++ b64 rsaQ rsa , "Exponent1: " ++ b64 rsaDmodP1 rsa , "Exponent2: " ++ b64 rsaDmodQminus1 rsa , "Coefficient: " ++ b64 rsaCoefficient rsa ] stamp = toEnum . fromEnum $ timestamp packet handleIO_ (return [(fname, FailedFileWrite)]) $ do saved_mask <- setFileCreationMask 0o077 -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. writeStamped (InputFileContext "" "") fname stamp output setFileCreationMask saved_mask return [(fname, ExportedSubkey)] algo -> return [(fname, UnableToExport algo $ show $ fingerprint packet)] writeKeyToFile strm _ _ = error $ "writeKeyToFile: Unsupported file type: " ++ show (typ strm) 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) decryptKeys (_, _, [] , _) = error "writePEMKeys: Key missing from keyring." decryptKeys (_, _, (_:_:_), _) = error "writePEMKeys: Ambiguous key." 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 -- 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 $ kkData 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 (preferredPGPVersion operation)) (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 $ kkData 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 (preferredPGPVersion operation) mwk db (rights internals) try v $ \(db,internals_rs) -> do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) -- FIXME: try' should probably accept a list of KikiReportActions. -- This would be useful for reporting on disk writes that have already -- succeded prior to this termination. try' :: Monad m => KikiCondition t -> (t -> m (KikiResult a)) -> m (KikiResult a) try' v body = case functorToEither v of Left e -> return $ KikiResult e [] Right wkun -> body wkun -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = withLockedKeyring (opHome operation) (opFiles operation) $ realRunKeyRing operation withLockedKeyring :: Maybe FilePath -> Map.Map InputFile StreamInfo -> (InputFileContext -> Maybe String -> IO (KikiResult a)) -> IO (KikiResult a) withLockedKeyring homespec opfiles go = do -- get homedir and keyring files + fingerprint for working key homedir <- getHomeDir homespec try' homedir $ \(_homedir, secring, pubring, grip0) -> do let ctx = InputFileContext secring pubring tolocks = filesToLock opfiles ctx secring <- return Nothing pubring <- return Nothing (locks :: [(Maybe DotLock, FilePath)]) <- forM tolocks $ \f -> do createDirectoryIfMissing True $ takeDirectory f lk <- dotlock_create f 0 v <- flip (maybe $ return Nothing) lk $ \lk -> do e <- dotlock_take lk (-1) if e==0 then return $ Just lk else dotlock_destroy lk >> return Nothing return (v,f) let (lked, map snd -> failed_locks) = partition (isJust . fst) locks ret <- if not $ null failed_locks then return $ KikiResult (FailedToLock failed_locks) [] else go ctx grip0 forM_ lked $ \(Just lk, fname) -> dotlock_release lk return ret realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime) realRunKeyRing operation ctx grip0 = do bresult <- buildKeyDB ctx grip0 operation try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx grip wk transcode db try' externals_ret $ \((db, exports), report_externals) -> do let decrypt = transcode (Unencrypted,S2K 100 "") rt = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db , rtRingAccess = accs , rtPassphrases = transcode } -- Maybe add signatures, delete subkeys r <- performManipulations decrypt rt wk (combineTransforms $ opTransforms operation) try' r $ \(rt,report_manips) -> do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do r <- writeRingKeys operation rt unspilled report_manips try' r $ \report_rings -> do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do import_hosts <- writeHostsFiles operation ctx hs return $ KikiResult (KikiSuccess rt) $ concat [ report_imports , report_externals , report_manips , report_wallets , report_rings , report_pems ] parseOptionFile :: FilePath -> IO [String] parseOptionFile fname = do xs <- fmap lines (readFile fname) let ys = filter notComment xs notComment ('#':_) = False notComment cs = not (all isSpace cs) return ys -- | returns ( home directory -- , path to secret ring -- , path to public ring -- , fingerprint of working key -- ) getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) getHomeDir protohome = do homedir <- envhomedir protohome flip (maybe (return CantFindHome)) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" pubring = homedir ++ "/" ++ "pubring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return $ KikiSuccess (homedir,secring,pubring,workingkey) where envhomedir opt = do gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home) homed <- fmap (mfilter (/="") . Just) getHomeDirectory let homegnupg = (++('/':(appdir home))) <$> homed let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val -- TODO: rename this to getGrip getWorkingKey homedir = do let o = Nothing h = Just homedir ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) (optfile_alts home) o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return []) ofile $ \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) topair _ = error "parseOptionFile yeilded an empty entry?" return $ lookup "default-key" config >>= listToMaybe