{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE PatternSynonyms #-} module KeyRing.Types where import Data.Bits import Data.Char (isLower,toLower) import Data.Functor import Data.List (groupBy,find,isInfixOf) import Data.Map as Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList,isJust,fromJust,mapMaybe) 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) instance Semigroup KeyRingOperation where KeyRingOperation f p t h <> KeyRingOperation f' p' t' h' = KeyRingOperation (f <> f') (p <> p') (t <> t') (h <> h') instance Monoid KeyRingOperation where mempty = KeyRingOperation Map.empty [] [] Nothing 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 -- requiring the judgment 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 PacketsCodec = DetectAscii | BinaryPackets | AsciiArmor deriving (Eq,Ord,Show) data FileType = PGPPackets PacketsCodec | PEMFile | WalletFile | DNSPresentation | Hosts | SshFile deriving (Eq,Ord,Show) pattern KeyRingFile :: FileType pattern KeyRingFile = PGPPackets DetectAscii -- 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, Foldable, Traversable, 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 instance Monad KikiCondition where return = pure KikiSuccess a >>= f = f a kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f") 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. newtype KeyKey = KeyKey [(Char,MPI)] deriving (Eq,Ord,Show) keykey :: Packet -> KeyKey keykey k = KeyKey $ concatMap (\c -> (maybeToList $ find (\(f,x) -> f==c) (key k))) (public_key_fields $ key_algorithm k) isKey :: Packet -> Bool isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isSecretKey :: Packet -> Bool isSecretKey (SecretKeyPacket {}) = True isSecretKey _ = False isUserID :: Packet -> Maybe String isUserID (UserIDPacket str) = Just str isUserID _ = Nothing 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 (show $ 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) secretToPublic :: Packet -> Packet secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt -- , ecc_curve = ecc_curve pkt , key = let seckey = key pkt pubs = public_key_fields (key_algorithm pkt) in filter (\(k,v) -> k `elem` pubs) seckey , is_subkey = is_subkey pkt , v3_days_of_validity = Nothing } secretToPublic pkt = pkt seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) where (pre,subs) = break pred sec pred p@(SecretKeyPacket {}) = matchpr grip p == grip pred p@(PublicKeyPacket {}) = matchpr grip p == grip pred _ = False seek_key (KeyTag key tag) ps | null bs = (ps, []) | null qs = let (as', bs') = seek_key (KeyTag key tag) (tail bs) in (as ++ (head bs : as'), bs') | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (\p -> isSignaturePacket p && has_tag tag p && isJust (signature_issuer p) && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) ps (rs,qs) = break isKey (reverse as) has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) seek_key (KeyUidMatch pat) ps | null bs = (ps, []) | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in (as ++ (head bs : as'), bs') | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (isInfixOf pat . uidStr) ps (rs,qs) = break isKey (reverse as) uidStr (UserIDPacket s) = s uidStr _ = "" usageString :: PGPKeyFlags -> String usageString flgs = case flgs of Special -> "special" Vouch -> "vouch" -- signkey Sign -> "sign" VouchSign -> "vouch-sign" Communication -> "communication" VouchCommunication -> "vouch-communication" SignCommunication -> "sign-communication" VouchSignCommunication -> "vouch-sign-communication" Storage -> "storage" VouchStorage -> "vouch-storage" SignStorage -> "sign-storage" VouchSignStorage -> "vouch-sign-storage" Encrypt -> "encrypt" VouchEncrypt -> "vouch-encrypt" SignEncrypt -> "sign-encrypt" VouchSignEncrypt -> "vouch-sign-encrypt" usage :: SignatureSubpacket -> Maybe String usage (NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = u }) = Just u usage _ = Nothing data PGPKeyFlags = Special | Vouch -- 0001 C -- Signkey | Sign -- 0010 S | VouchSign -- 0011 | Communication -- 0100 E | VouchCommunication -- 0101 | SignCommunication -- 0110 | VouchSignCommunication -- 0111 | Storage -- 1000 E | VouchStorage -- 1001 | SignStorage -- 1010 | VouchSignStorage -- 1011 | Encrypt -- 1100 E | VouchEncrypt -- 1101 | SignEncrypt -- 1110 | VouchSignEncrypt -- 1111 deriving (Eq,Show,Read,Enum) -- XXX keyFlags and keyflags are different functions. keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags keyflags flgs@(KeyFlagsPacket {}) = Just . toEnum $ ( bit 0x1 certify_keys .|. bit 0x2 sign_data .|. bit 0x4 encrypt_communication .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags -- other flags: -- split_key -- authentication (ssh-client) -- group_key where bit v f = if f flgs then v else 0 keyflags _ = Nothing