From 7a579e7b82a2f5707af77f4a7101ce72e57635ac Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 28 Aug 2016 16:10:41 -0400 Subject: Refactored for smaller modules (faster rebuild). --- lib/KeyRing.hs | 428 +-------------------------------------------------------- 1 file changed, 2 insertions(+), 426 deletions(-) (limited to 'lib/KeyRing.hs') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index a055dad..313258d 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -211,6 +211,8 @@ import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) import GnuPGAgent as Agent +import Types +import PacketTranscoder -- DER-encoded elliptic curve ids -- nistp256_id = 0x2a8648ce3d030107 @@ -247,114 +249,6 @@ home = HomeDir , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } -data InputFile = HomeSec - -- ^ A file named secring.gpg located in the home directory. - -- See 'opHome'. - | HomePub - -- ^ A file named pubring.gpg located in the home directory. - -- See 'opHome'. - | ArgFile FilePath - -- ^ Contents will be read or written from the specified path. - | FileDesc Posix.Fd - -- ^ Contents will be read or written from the specified file - -- descriptor. - | Pipe Posix.Fd Posix.Fd - -- ^ Contents will be read from the first descriptor and updated - -- content will be writen to the second. Note: Don't use Pipe - -- for 'Wallet' files. (TODO: Wallet support) - | Generate Int GenerateKeyParams - -- ^ New key packets will be generated if there is no - -- matching content already in the key pool. The integer is - -- a unique id number so that multiple generations can be - -- inserted into 'opFiles' - deriving (Eq,Ord,Show) - --- type UsageTag = String -data Initializer = NoCreate | Internal GenerateKeyParams | External String - deriving (Eq,Ord,Show) - -data FileType = KeyRingFile - | PEMFile - | WalletFile - | DNSPresentation - | Hosts - deriving (Eq,Ord,Enum,Show) - --- | Use this type to indicate whether a file of type 'KeyRingFile' is expected --- to contain secret or public PGP key packets. Note that it is not supported --- to mix both in the same file and that the secret key packets include all of --- the information contained in their corresponding public key packets. -data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. - -- (see 'rtRingAccess') - | Sec -- ^ secret information - | Pub -- ^ public information - deriving (Eq,Ord,Show) - --- | Note that the documentation here is intended for when this value is --- assigned to 'fill'. For other usage, see 'spill'. -data KeyFilter = KF_None -- ^ No keys will be imported. - | KF_Match String -- ^ Only the key that matches the spec will be imported. - | KF_Subkeys -- ^ Subkeys will be imported if their owner key is - -- already in the ring. TODO: Even if their signatures - -- are bad? - | KF_Authentic -- ^ Keys are imported if they belong to an authenticated - -- identity (signed or self-authenticating). - | KF_All -- ^ All keys will be imported. - deriving (Eq,Ord,Show) - --- | This type describes how 'runKeyRing' will treat a file. -data StreamInfo = StreamInfo - { access :: Access - -- ^ Indicates whether the file is allowed to contain secret information. - , typ :: FileType - -- ^ Indicates the format and content type of the file. - , fill :: KeyFilter - -- ^ This filter controls what packets will be inserted into a file. - , spill :: KeyFilter - -- - -- ^ Use this to indicate whether or not a file's contents should be - -- available for updating other files. Note that although its type is - -- 'KeyFilter', it is usually interpretted as a boolean flag. Details - -- depend on 'typ' and are as follows: - -- - -- 'KeyRingFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * otherwise - The file's contents will be shared. - -- - -- 'PEMFile': - -- - -- * 'KF_None' - The file's contents will not be shared. - -- - -- * 'KF_Match' - The file's key will be shared with the specified owner - -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be - -- equal to this value; changing the usage or owner of a key is not - -- supported via the fill/spill mechanism. - -- - -- * otherwise - Unspecified. Do not use. - -- - -- 'WalletFile': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - -- 'Hosts': - -- - -- * The 'spill' setting is ignored and the file's contents are shared. - -- (TODO) - -- - , initializer :: Initializer - -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set, - -- then it is interpretted as a shell command that may be used to create - -- the key if it does not exist. - , transforms :: [Transform] - -- ^ Per-file transformations that occur before the contents of a file are - -- spilled into the common pool. - } - deriving (Eq,Show) - - spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True @@ -387,10 +281,6 @@ usageFromFilter (KF_Match usage) = return usage usageFromFilter _ = mzero -type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) - -type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) - data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' @@ -418,84 +308,6 @@ data KeyRingRuntime = KeyRingRuntime data PacketUpdate = InducerSignature String [SignatureSubpacket] | SubKeyDeletion KeyKey KeyKey --- | This type is used to indicate where to obtain passphrases. -data PassphraseSpec = PassphraseSpec - { passSpecRingFile :: Maybe FilePath - -- ^ If not Nothing, the passphrase is to be used for packets - -- from this file. - , passSpecKeySpec :: Maybe String - -- ^ Non-Nothing value reserved for future use. - -- (TODO: Use this to implement per-key passphrase associations). - , passSpecPassFile :: InputFile - -- ^ The passphrase will be read from this file or file descriptor. - } - -- | Use this to carry pasphrases from a previous run. - | PassphraseMemoizer PacketTranscoder - | PassphraseAgent - -instance Show PassphraseSpec where - show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) - show (PassphraseMemoizer _) = "PassphraseMemoizer" -instance Eq PassphraseSpec where - PassphraseSpec a b c == PassphraseSpec d e f - = and [a==d,b==e,c==f] - _ == _ - = False - - - -data Transform = - Autosign - -- ^ This operation will make signatures for any tor-style UID - -- that matches a tor subkey and thus can be authenticated without - -- requring the judgement of a human user. - -- - -- A tor-style UID is one of the following form: - -- - -- > Anonymous - | DeleteSubkeyByFingerprint String - -- ^ Delete the subkey specified by the given fingerprint and any - -- associated signatures on that key. - | DeleteSubkeyByUsage String - -- ^ Delete the subkey specified by the given fingerprint and any - -- associated signatures on that key. - deriving (Eq,Ord,Show) - --- | This type describes an idempotent transformation (merge or import) on a --- set of GnuPG keyrings and other key files. -data KeyRingOperation = KeyRingOperation - { opFiles :: Map.Map InputFile StreamInfo - -- ^ Indicates files to be read or updated. - , opPassphrases :: [PassphraseSpec] - -- ^ Indicates files or file descriptors where passphrases can be found. - , opTransforms :: [Transform] - -- ^ Transformations to be performed on the key pool after all files have - -- been read and before any have been written. - , opHome :: Maybe FilePath - -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' - -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted - -- and if that is not set, it falls back to $HOME/.gnupg. - } - deriving (Eq,Show) - -resolveInputFile :: InputFileContext -> InputFile -> [FilePath] -resolveInputFile ctx = resolve - where - resolve HomeSec = return (homesecPath ctx) - resolve HomePub = return (homepubPath ctx) - resolve (ArgFile f) = return f - resolve _ = [] - -resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath -resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) - where str = case (fdr,fdw) of - (0,1) -> "-" - _ -> "&pipe" ++ show (fdr,fdw) -resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) - where str = "&" ++ show fd -resolveForReport mctx f = concat $ resolveInputFile ctx f - where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx - filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] filesToLock k ctx = do @@ -635,33 +447,6 @@ instance ASN1Object RSAPrivateKey where --- | This type is used to indicate success or failure --- and in the case of success, return the computed object. --- The 'FunctorToMaybe' class is implemented to facilitate --- branching on failture. -data KikiCondition a = KikiSuccess a - | FailedToLock [FilePath] - | BadPassphrase - | FailedToMakeSignature - | CantFindHome - | AmbiguousKeySpec FilePath - | CannotImportMasterKey - | NoWorkingKey - deriving ( Functor, Show ) - -instance FunctorToMaybe KikiCondition where - functorToMaybe (KikiSuccess a) = Just a - functorToMaybe _ = Nothing - -instance Applicative KikiCondition where - pure a = KikiSuccess a - f <*> a = - case functorToEither f of - Right f -> case functorToEither a of - Right a -> pure (f a) - Left err -> err - Left err -> err - -- | This type is used to describe events triggered by 'runKeyRing'. In -- addition to normal feedback (e.g. 'NewPacket'), it also may indicate -- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a @@ -1349,18 +1134,6 @@ seek_key (KeyUidMatch pat) ps uidStr _ = "" -data InputFileContext = InputFileContext - { homesecPath :: FilePath - , homepubPath :: FilePath - } - -readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString -readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents -readInputFileS ctx inp = do - let fname = resolveInputFile ctx inp - fmap S.concat $ mapM S.readFile fname - readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents @@ -1436,27 +1209,6 @@ doesInputFileExist ctx f = do -} --- | Reads contents of an 'InputFile' or returns the cached content from a prior call. --- An optional prompt is provided and will be printed on stdout only in the case that --- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin). -cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) -cachedContents maybePrompt ctx fd = do - ref <- newIORef Nothing - return $ get maybePrompt ref fd - where - trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs - - get maybePrompt ref fd = do - pw <- readIORef ref - flip (flip maybe return) pw $ do - if fd == FileDesc 0 then case maybePrompt of - Just prompt -> S.hPutStr stderr prompt - Nothing -> return () - else return () - pw <- fmap trimCR $ readInputFileS ctx fd - writeIORef ref (Just pw) - return pw - generateSubkey :: PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db @@ -2589,115 +2341,6 @@ writePEMKeys doDecrypt db exports = do try pun $ \pun -> do return $ KikiSuccess (fname,stream,pun) -makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext - -> Map.Map KeyKey (OriginMapped Query) - -> IO PacketTranscoder -makeMemoizingDecrypter operation ctx keys = do - if null chains then do - -- (*) Notice we do not pass ctx to resolveForReport. - -- This is because the merge function does not currently use a context - -- and the pws map keys must match the MappedPacket locations. - -- TODO: Perhaps these should both be of type InputFile rather than - -- FilePath? - -- pws :: Map.Map FilePath (IO S.ByteString) - {- - -- This disabled code obtained password sources from StreamInfo records. - pws <- - Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) - (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above - $ Map.filter (isJust . pwfile . typ) $ opFiles operation) - -} - let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" - -- List of file-specific password sources. - pws2 <- - Traversable.mapM (cachedContents prompt ctx) - $ Map.fromList $ mapMaybe - (\spec -> (,passSpecPassFile spec) `fmap` do - guard $ isNothing $ passSpecKeySpec spec - passSpecRingFile spec) - passspecs - -- List of general password sources. - defpw <- do - Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) - $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) - && isNothing (passSpecKeySpec sp)) - $ passspecs - unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) - return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec) - else let PassphraseMemoizer f = head chains - in return f - where - (chains,passspecs0) = partition isChain $ opPassphrases operation - where isChain (PassphraseMemoizer {}) = True - isChain _ = False - (agentspec,passspecs) = partition isAgent $ opPassphrases operation - where isAgent PassphraseAgent = True - isAgent _ = False - doDecrypt :: IORef (Map.Map KeyKey Packet) - -> Map.Map FilePath (IO S.ByteString) - -> Maybe (IO S.ByteString) - -> Bool - -> (SymmetricAlgorithm,S2K) - -> MappedPacket - -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do - unkeys <- readIORef unkeysRef - let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do - k <- Map.lookup kk keys - return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k) - wk = packet mp0 - kk = keykey wk - fs = Map.keys $ locations mp - - decryptIt [] = return BadPassphrase - decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws) - where - tries count getpw recurse = do - -- TODO: This function should use mergeKeyPacket to - -- combine the packet with it's unspilled version before - -- attempting to decrypt it. Note: We are uninterested - -- in the 'locations' field, so this would effectively - -- allow you to run 'decryptIt' on an unencrypted public key - -- to obtain it's secret key. - (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry) - let wkun = fromMaybe wk $ do - guard $ symmetric_algorithm (packet mp) /= Unencrypted - decryptSecretKey pw (packet mp) - - case symmetric_algorithm wkun of - - Unencrypted -> do - writeIORef unkeysRef (Map.insert kk wkun unkeys) - ek <- if dest_alg==Unencrypted - then return $ Just wkun - else encryptSecretKey pw dest_s2k dest_alg wkun - case ek of - Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse - Nothing -> recurse - Just wken -> return $ KikiSuccess wken - - _ -> recurse - - getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] - - agentpw (ask,qry) = do - s <- session - fromMaybe (return ("",False)) $ do - s <- s - Just $ do - case ask of AskAgain _ -> clearPassphrase s (queryPacket qry) - _ -> return () - mbpw <- getPassphrase s ask qry - quit s - return ( maybe "" S8.pack mbpw, True) - - if symmetric_algorithm wk == dest_alg - && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) - then return (KikiSuccess wk) - else maybe (decryptIt getpws) - (return . KikiSuccess) - $ Map.lookup kk unkeys - performManipulations :: (PacketDecrypter) -> KeyRingRuntime @@ -3162,19 +2805,6 @@ lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif -isKey :: Packet -> Bool -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isUserID :: Packet -> Bool -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isTrust :: Packet -> Bool -isTrust (TrustPacket {}) = True -isTrust _ = False - sigpackets :: Monad m => Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet @@ -3497,32 +3127,10 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do return $ fmap (,[]) newsig --- | The position and acces a packet had before the operation -data OriginFlags = OriginFlags - { originallyPublic :: Bool - -- ^ false if SecretKeyPacket - , originalNum :: Int - -- ^ packets are numbered, starting from 1.. - } deriving Show - -type OriginMap = Map.Map FilePath OriginFlags - -type MappedPacket = OriginMapped Packet -data OriginMapped a = MappedPacket - { packet :: a - , locations :: OriginMap - } deriving Show -instance Functor OriginMapped where - fmap f (MappedPacket x ls) = MappedPacket (f x) ls - type TrustMap = Map.Map FilePath Packet type SigAndTrust = ( MappedPacket , TrustMap ) -- trust packets --- | The 'KeyKey'-type is used to store the information of a key --- which is used for finger-printing -type KeyKey = [ByteString] - data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show -- | This is a GPG Identity which includes a master key and all its UIDs and @@ -3554,15 +3162,6 @@ mappedPacketWithHint filename p hint = MappedPacket , locations = Map.singleton filename (origin p hint) } -keykey :: Packet -> KeyKey -keykey key = - -- Note: The key's timestamp is normally included in it's fingerprint. - -- This is undesirable for kiki because it causes the same - -- key to be imported multiple times and show as apparently - -- distinct keys with different fingerprints. - -- Thus, we will remove the timestamp. - fingerprint_material (key {timestamp=0}) -- TODO: smaller key? - uidkey :: Packet -> String uidkey (UserIDPacket str) = str @@ -3598,29 +3197,6 @@ onionName kd = (addr,name) (addr,(name:_,_)) = getHostnames kd -} --- | Compare different versions if the same key pair. Public versions --- are considered greater. If the two packets do not represent the same --- key or the packets are not keys at all, an error will result that --- includes the context provided as the first argument. -keyCompare :: String -> Packet -> Packet -> Ordering -keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT -keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT -keyCompare what a b | keykey a==keykey b = EQ -keyCompare what a b = error $ unlines ["Unable to merge "++what++":" - , if isKey a then fingerprint a else "" - , PP.ppShow a - , if isKey b then fingerprint b else "" - , PP.ppShow b - ] - --- | Merge two representations of the same key, prefering secret version --- because they have more information. -mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket -mergeKeyPacket what key p = - key { packet = minimumBy (keyCompare what) [packet key,packet p] - , locations = Map.union (locations key) (locations p) - } - merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB -- cgit v1.2.3