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/GnuPGAgent.hs | 4 - lib/KeyRing.hs | 428 +----------------------------------------------- lib/PacketTranscoder.hs | 204 +++++++++++++++++++++++ lib/Types.hs | 263 +++++++++++++++++++++++++++++ 4 files changed, 469 insertions(+), 430 deletions(-) create mode 100644 lib/PacketTranscoder.hs create mode 100644 lib/Types.hs (limited to 'lib') diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index 165fdf2..4a0e8c8 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs @@ -12,7 +12,6 @@ module GnuPGAgent import Debug.Trace import Control.Monad import Data.Char -import Data.String import Data.OpenPGP import Data.OpenPGP.Util import Network.Socket @@ -195,6 +194,3 @@ mpi_nbits (MPI n) = 8 * fromIntegral len b | L.head b == 0x0 -> L.length b - 1 | otherwise -> L.length b - -testkey = SecretKeyPacket {version = 4, timestamp = 1472243938, key_algorithm = RSA, key = [('n',MPI 925098108806375345974135594703587915335809897839280536758475464131261107271275275932941944111979646806461228101207851537942631933552941000008763874178530420365203962506983368285394789190952706134189777248228503641959576566803847321978843353927484729746589488105067415601601958095348374608399772919464713280387221943804165023869848572344992805664813501588760551986737643636299927619834836785540438897016892383261773529795165480003163651143689566476205133258213375814625458146741502313336447508506512546267421431425245630464604235460425475063276208764001900603879017446724640013942643622160007288636580727874256816955228499258020260878806702335205106422310450767943433083341074984990460601274996333576709631004285781450883843918772938883789506765607663117687871326332910317916884385080960167806232865135145253097892026144191502423556603525411279749089026836608340578157620006555362884552555447347323681257897414720771902270571787966952008017289476385955943926940452534284336204814865498532173422146165623516746915729611768809058047983375615970447956865689598628436093143714990376442967204932522864539829901037938858768502028897029767875742018399924904388125541551233394021154526824492768592689377932549076041702724833113848612007956279),('e',MPI 65537)], s2k_useage = 255, s2k = IteratedSaltedS2K SHA1 4073382889203176146 7864320, symmetric_algorithm = CAST5, encrypted_data = fromString "\NUL\ESC\145\219\220k\SOH\147}\236K\165\207\&9g\245Nl\\)l\193\224{\251\180T\240\150\184\164:Fbx\t\SI\143\213\202?\137\158zd\247\188W\227l\NUL\154s\173\NUL\"k\162\243\rh\233\215\181\207\&7\223\DC3^t\187\158\248\177\ENQ\225\\\186\168\EM\177\211\162U\132\229Nx\227\&8\SYN\234\136\229\142;\252\&90L;\161\181\SO\152\198\&4\153\SUBs\235\195\153N\196\194 [\244+\217\242l\217.\183\186\205(\186\NUL\164\143>\215\168\207}\191\172($\168\139)O\ESCq\GS\138\213\243\229<\187\252\153)\NUL\128\136\237\RS\ETX\216\185\176I\239\185\228\v(\251\&4\233\&3$\236\195\NAKr\234\190J\216y\DC1\av\159\164\CAN\EOT\167\202})\128\182j\195\145]\144\r\232(\215\187\&1K\245\170\218\144\179\205\SOH\180-\185\DC1\168l\195\149\196\191\&9\156\196E\253\159h\154II\180\f\r\211\242\167~\214\223\219S\194\239\192\250\211Z\162\NAK\183M\209\230\&1yd\145\SOH\249\129\ESC\147\EM\237y\vK12O\205\ESC\r\224J\188\189\231\132\153JT\151f8\209\220#~S\165Q\249\SOH\182)\182\244\222\198i\180\221\170Q\238X\206\218\222\164gy\239\&7\136\183P\204\&5\NAK&\ESCC\GS\192\202\SO\241x\145MM\207\229\135\151\189,t\231r\194\196\233[\225\136\234\164r\176NXY\157\&2?\129% g\200\222\150\209\DLEQ\144\FS\181\&4#\US\DC28\179\190\240y3gr\170&\194\CAN)3r\235\252\153\EM\211\a\195\251\187\236\&1\197:\192\158\US\US\163v\153\223\141\254\209\206n\178h\140\&1-\fM\b\SOH\207\155\USb.,\NAKw\247\US\225\b)\236\EM\ENQn}\SUB-\193\f\138F\255P\216\242\164\145\136\213\171\252\254t\178\v\207\187\211\229\161\133\238\146\162\166SrT\168\135\244d6]\151\a\153\156\232\207|\152\223\174\EMj\130\240\211\141\203\167Kl\163\179R\152\225\221m\224!\238\176\217\162\158 fv\149wX\226\132\137H\138\235\207vwN\DC1\DEL'T\171\219\222\n\220V@\249U\227\SUBr\223NE\158=c\189\ACK3H\220\174\&3\139\135\254\246\165\EOTT\248\RS\132\160\219\EMb\188\200\165\138\178\163\STX\170\161\248\217\&1\186\&2r~\243\143\145b\154(\138\161\179\217\ACK\176\243\163IC\176\189Q_\206w\188=\254\143=\175\188\ENQaP\197\SI*\151\242m\178\184\208\SYN@\128\143\DC3-J\163\164{\206<\SUBxG\SI\NUL\153%\187\142\&6\f\186O\142\128'\128\150{\165\156e\201\175\159\185\b\NAK\246M\182\&4\SOH\161\231UV\220\148\245$\173\247-C\212\179\190Z$\184\RSZ\130~\t\249\138r?\201\231\200\190m\128%c\204\ENQH3S\140\228\&8\243\NAK\DC4O\218\162\146R\221\134\217%%\164@#\139\a\STX\218Y\132h\ETX(=\245\135\239|rN\\2\250\\\FS\155:p\247\213\252D']*\137\220\128\232\ar\134\DC4\131\194\SUB\169\130\&6\SI\131\151J!\220\135V\210m!\EM\241\134\158v\200~\190;z\237\218\DC3\NULT\164\151\135|\185\EOT\161c\196QA\228.\ENQ\227d\220\128\238\191&Pw\f'\153\180\DC3\201\SI=0\218\130~\167\t5\172EBA\238D\219\208\168\b\252Y\236\220,\144\&1\239\177\n\DC4\DLE\238\v\ETB\168\246\185\212\239\231\212\212sl\254.\197\216\130g\163\&5\211*\150\243g\220\247\140M\190\172\216\250\248\130\207\&5f\223;=}qU?\\\237\243\ENQ\241[\198\248u\139\a\139\175\247\224\252_N\146G\201\NUL\170{\191\237\140\SYNH2\ESCg\RS\233\175}\189\136\250\240\129\US\187\193\194\189\SUBK\SO\209\177F\200\SOH\173\196kw_)_\227\162\186\DC2\132\181\b@\ACKGo\222f\251br\CAN3~\139\DC2U\bQ\241\CAN:\213\135s\138\GSPIk*\236\&2a;o\247\239\202\145\212(2\223\DEL\bz\157\242@\STX\180g\193\202\230\186\135\189\177l\163\216o\230\&6\DC2\198\164\182\&5\ETX%\228\"!\245\ENQ\180\234\ACK\US\174\249\SO\US\168\STX,\ETB\n\249/\177\179\247Fw$\DLEB\ACK\224\231\EOT\ETB\247\213\182v\180\FS\247\205\222+P&\228\213\216\138ez\189N9x\v\228\217\207L}\ETX&\133\206\vRSM)\SOH\217\253\RS\204\252\249p\v\ACKL!u\SI\\\ETXD\128\&9\152\fy\241\202\204\164\151p\142\147c\207)\130\179'm\211\128I\207\ENQ\r\bcMWt\222\156\&1\199\DLE\157\&0z[H\146\SOHg\238\234\185\181\141\172c\245[\NUL\197\205\ENQ\fM\177\230\253\209~^\213W1'\GS\142\249\SIZ\204\254\240\DC3\231=b!\225@\247x\135\135\226\251[\RS&;\135}\196t\SUBi\CAN\DC14]e\206-l\205\SI\253\222\139y\139V\242\150k\248\191\231\195\211W\226t\170\DLE\174\243\186\211\189\152D\216\235\163\220+\194\247!o^F\198\145M", is_subkey = False} - 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 diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs new file mode 100644 index 0000000..651b00c --- /dev/null +++ b/lib/PacketTranscoder.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +module PacketTranscoder where + +import Control.Monad +import Data.IORef +import Data.List +import Data.Maybe +import Data.OpenPGP +import Data.OpenPGP.Util +import GnuPGAgent +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Map as Map +import qualified Data.Traversable as Traversable +import System.IO ( stderr) +import System.Posix.IO ( fdToHandle ) +import Text.Show.Pretty as PP ( ppShow ) +import Types + +-- | 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) + } + +-- | 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 + ] + +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 + +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 + + + +-- | 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 + + + +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 passspecs0 + 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 ] + + -- TODO: First we should try the master key with AskNot. + -- If that fails, we should try the subkey. + 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 + diff --git a/lib/Types.hs b/lib/Types.hs new file mode 100644 index 0000000..9aa0340 --- /dev/null +++ b/lib/Types.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DeriveFunctor #-} +module Types where + +import Data.Map as Map (Map) +import Data.OpenPGP +import Data.OpenPGP.Util +import FunctorToMaybe +import qualified System.Posix.Types as Posix +import qualified Data.ByteString.Lazy as L + +-- | This type describes an idempotent transformation (merge or import) on a +-- set of GnuPG keyrings and other key files. +data KeyRingOperation = KeyRingOperation + { opFiles :: 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) + +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) + +-- | 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) + + +-- | 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) + +-- | 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) + +data FileType = KeyRingFile + | PEMFile + | WalletFile + | DNSPresentation + | Hosts + deriving (Eq,Ord,Enum,Show) + +-- type UsageTag = String +data Initializer = NoCreate | Internal GenerateKeyParams | External String + deriving (Eq,Ord,Show) + + + +type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) +type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) + +-- | 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) + +-- | 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 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 + +-- | 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 + +data InputFileContext = InputFileContext + { homesecPath :: FilePath + , homepubPath :: FilePath + } + + +-- | The 'KeyKey'-type is used to store the information of a key +-- which is used for finger-printing and as a lookup key into +-- maps. This type may be changed to an actual fingerprint in +-- in the future. +type KeyKey = [L.ByteString] + +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? + +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 + + -- cgit v1.2.3