Attempted to merge 0bc53f99cfd70f3a18802604d7ef3174d004db4c.

I left lib/Kiki.hs out for later.

1 files changed, 394 insertions, 0 deletions

diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
new file mode 100644
index 0000000..2383140
--- /dev/null
+++ b/lib/KeyRing/Types.hs
@@ -0,0 +1,394 @@
+{-# LANGUAGE DeriveFunctor #-}
+module KeyRing.Types where
+
+import           Data.Char (isLower,toLower)
+import           Data.List (groupBy)
+import           Data.Map as Map (Map)
+import qualified Data.Map as Map
+import           Data.OpenPGP
+import           Data.OpenPGP.Util
+import           Data.Time.Clock
+import           FunctorToMaybe
+import qualified Data.ByteString.Lazy as L
+import qualified System.Posix.Types as Posix
+
+-- | 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 { passSpecTranscoder :: 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
+
+-- Ord instance for PassphraseSpec generally orders by generality with the most
+-- general being greatest and the least general being least.  The one exception
+-- is the 'PassphraseMemoizer' which is considered least of all even though it
+-- is very general.  This is so an existing memoizer will be tried first, and
+-- if there is none, one will be created that tries the others in order of
+-- increasing generality.  Key-specialization is considered less general than
+-- file-specialization.
+instance Ord PassphraseSpec where
+    compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ
+    compare PassphraseAgent PassphraseAgent               = EQ
+    compare (PassphraseMemoizer _) _                      = LT
+    compare (PassphraseSpec a b c) (PassphraseSpec d e f)
+        | fmap (const ()) a == fmap (const ()) d
+          && fmap (const ()) b == fmap (const ()) e       = compare (a,b,c) (d,e,f)
+    compare (PassphraseSpec (Just _) (Just _) _)  _       = LT
+    compare (PassphraseSpec Nothing (Just _) _) _         = LT
+    compare (PassphraseSpec (Just _) _  _) _              = LT
+    compare PassphraseAgent _                             = GT
+
+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 usage tag and any
+        -- associated signatures on that key.
+        | RenameSubkeys String String
+        -- ^ Replace all subkey signatures matching the first usage tag with
+        -- fresh signatures that match the second usage tag.
+ 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
+              | SshFile
+ deriving (Eq,Ord,Enum,Show)
+
+-- type UsageTag = String
+data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing 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
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket :: FilePath -> Packet -> MappedPacket
+mappedPacket filename p = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
+
+-- | 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
+    | AgentConnectionFailure
+    | OperationCanceled
+ 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
+
+uncamel :: String -> String
+uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
+  where
+    (.:) = fmap . fmap
+    ( firstWord  ,
+      otherWords ) = splitAt 1 ws
+    ws             = camel >>= groupBy (\_ c -> isLower c)
+    ( camel, args) = splitAt 1 $ words str
+
+errorString :: KikiCondition a -> String
+errorString (KikiSuccess {}) = "success"
+errorString e = uncamel . show $ fmap (const ()) e
+
+
+
+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
+
+isSecretKey :: Packet -> Bool
+isSecretKey (SecretKeyPacket {}) = True
+isSecretKey _                    = False
+
+
+isUserID :: Packet -> Bool
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isTrust :: Packet -> Bool
+isTrust (TrustPacket {}) = True
+isTrust _                = False
+
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+--
+-- matchpr fp = Data.List.Extra.takeEnd (length fp)
+--
+matchpr :: String -> Packet -> String
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+
+
+
+data KeySpec =
+      KeyGrip String       -- fp:
+    | KeyTag Packet String -- fp:????/t:
+    | KeyUidMatch String   -- u:
+ deriving Show
+
+{-
+RSAPrivateKey ::= SEQUENCE {
+  version           Version,
+  modulus           INTEGER,  -- n
+  publicExponent    INTEGER,  -- e
+  privateExponent   INTEGER,  -- d
+  prime1            INTEGER,  -- p
+  prime2            INTEGER,  -- q
+  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
+  exponent2         INTEGER,  -- d mod (q-1)
+  coefficient       INTEGER,  -- (inverse of q) mod p
+  otherPrimeInfos   OtherPrimeInfos OPTIONAL
+  }
+-}
+data RSAPrivateKey = RSAPrivateKey
+    { rsaN :: MPI
+    , rsaE :: MPI
+    , rsaD :: MPI
+    , rsaP :: MPI
+    , rsaQ :: MPI
+    , rsaDmodP1 :: MPI
+    , rsaDmodQminus1 :: MPI
+    , rsaCoefficient :: MPI
+    }
+ deriving Show
+
+data ParsedCert = ParsedCert
+    { pcertKey :: Packet
+    , pcertTimestamp :: UTCTime
+    , pcertBlob :: L.ByteString
+    }
+ deriving (Show,Eq)
+
+data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
+ deriving (Eq,Ord,Enum,Show,Read)
+
+data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
+ deriving (Show,Eq)
+
+data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
+
+data SingleKeySpec = FingerprintMatch String
+                   | SubstringMatch (Maybe MatchingField) String
+                   | EmptyMatch
+                   | AnyMatch
+                   | WorkingKeyMatch
+ deriving (Show,Eq,Ord)
+