path: root/lib/KeyRing/Types.hs

{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE PatternSynonyms #-}
module KeyRing.Types where

import           Data.Char (isLower,toLower)
import           Data.List (groupBy,find)
import           Data.Map as Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (maybeToList)
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,Semigroup,Monoid)

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 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, 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.
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 -> 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)