From bc0458ee540da677a04eeddf9b4e0fe8a8991e93 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 1 Jul 2019 02:37:20 -0400 Subject: Attempted to merge 0bc53f99cfd70f3a18802604d7ef3174d004db4c. I left lib/Kiki.hs out for later. --- lib/KeyRing/Types.hs | 394 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 394 insertions(+) create mode 100644 lib/KeyRing/Types.hs (limited to 'lib/KeyRing/Types.hs') 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 + | 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) + -- cgit v1.2.3