Refactored for smaller modules (faster rebuild).

1 files changed, 2 insertions, 426 deletions

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 <root@HOSTNAME.onion>
-        | 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