path: root/lib/KeyRing/Types.hs

{-# 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           Data.Word
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.
    , preferredPGPVersion :: Word8
    -- ^ Newly created PGP key packets will use this version.  It should be set
    -- to either 4 or 5.
    }
  deriving (Eq,Show)
instance Semigroup KeyRingOperation where
  KeyRingOperation f p t h v <> KeyRingOperation f' p' t' h' v' =
    KeyRingOperation (f <> f') (p <> p') (t <> t') (h <> h') (max v v')
instance Monoid KeyRingOperation where
  mempty = KeyRingOperation Map.empty [] [] Nothing 4

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 KeySpec
    -- ^ 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"
    show PassphraseAgent        = "PassphraseAgent"
instance Eq PassphraseSpec where
    PassphraseSpec a b c == PassphraseSpec d e f
        = and [a==d,b==e,c==f]
    PassphraseAgent == PassphraseAgent
        = True
    _ == _
        = 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
    compare (PassphraseSpec Nothing Nothing _) (PassphraseSpec _ _ _) = GT
    compare (PassphraseSpec Nothing Nothing _) (PassphraseMemoizer _) = GT
    compare (PassphraseSpec Nothing Nothing _) PassphraseAgent        = LT

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 <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 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 :: Word8 -> String -> Packet -> String
matchpr ver fp k =
    let (rev,v) = case ver of
                    4 -> (reverse, 4)
                    5 -> (id, 5)
                    _ -> case auto_fp_version k of
                            5 -> (id, 5)
                            v -> (reverse, v)
    in rev $ zipWith const (rev (show $ fingerprintv v k)) fp




data KeySpec =
      KeyFP { fpVer     :: Word8  -- 5 or 4 to select fingerprint style, 0 to match either.
            , fpPartial :: String -- partial fingerprint, matches trailing for 4, or leading for 5
            }              -- fp:
    | KeyTag Packet String -- fp:????/t:
    | KeyUidMatch String   -- u:
 deriving (Show,Eq)

instance Ord KeySpec where
    compare (KeyFP av af) (KeyFP bv bf) = compare (av,af) (bv,bf)
    compare (KeyTag ap a) (KeyTag bp b) = compare (fingerprint ap,a) (fingerprint bp,b)
    compare (KeyUidMatch a) (KeyUidMatch b) = compare a b
    compare (KeyFP {})  _ = LT
    compare (KeyTag {}) _ = LT
    compare _           _ = GT


{-
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 deriving (Show,Eq,Ord,Enum)

data SingleKeySpec = FingerprintMatch Word8 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

matchKeySpec :: KeySpec -> Packet -> Bool
matchKeySpec spec pkt = not $ null $ snd $ seek_key spec [pkt]

seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
seek_key (KeyFP ver grip) sec = (pre, subs)
  where
    (pre,subs) = break pred sec
    pred p@(SecretKeyPacket {}) = matchpr ver grip p == grip
    pred p@(PublicKeyPacket {}) = matchpr ver 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 (version p) (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