{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Crypto.Gpgme.Key.Gen
License     : Public Domain

Maintainer  : daveparrish@tutanota.com
Stability   : experimental
Portability : untested

Key generation for h-gpgme.

It is suggested to import as qualified. For example:

> import qualified  Crypto.Gpgme.Key.Gen as G
-}

module Crypto.Gpgme.Key.Gen (
    -- * Usage
      genKey

    -- * Parameters
    , GenKeyParams (..)
    -- ** BitSize
    , BitSize
    , Crypto.Gpgme.Key.Gen.bitSize
    -- ** UsageList
    , UsageList (..)
    , Encrypt (..)
    , Sign (..)
    , Auth (..)
    -- ** ExpireDate
    , ExpireDate (..)
    -- ** CreationDate
    , CreationDate (..)
    -- * Other
    , Positive (unPositive)
    , toPositive
    , toParamsString
    ) where

import            Crypto.Gpgme.Types
import            Crypto.Gpgme.Internal

import qualified  Data.ByteString        as BS
import qualified  Data.ByteString.Char8  as BSC8
import            Text.Email.Validate
import            Foreign                as F
import            Foreign.C.String       as FCS
import            Bindings.Gpgme
import            Data.Time.Clock
import            Data.Time.Format
import            Data.Default

-- | Key generation parameters.
--
-- See: https://www.gnupg.org/documentation/manuals/gnupg/Unattended-GPG-key-generation.html
data GenKeyParams = GenKeyParams {
      GenKeyParams -> Maybe PubKeyAlgo
keyType       :: Maybe PubKeyAlgo
    , GenKeyParams -> Maybe BitSize
keyLength     :: Maybe BitSize
    , GenKeyParams -> ByteString
keyGrip       :: BS.ByteString
    , GenKeyParams -> Maybe UsageList
keyUsage      :: Maybe UsageList
    , GenKeyParams -> Maybe PubKeyAlgo
subkeyType    :: Maybe PubKeyAlgo
    , GenKeyParams -> Maybe BitSize
subkeyLength  :: Maybe BitSize
    , GenKeyParams -> ByteString
passphrase    :: BS.ByteString
    , GenKeyParams -> ByteString
nameReal      :: BS.ByteString
    , GenKeyParams -> ByteString
nameComment   :: BS.ByteString
    , GenKeyParams -> Maybe EmailAddress
nameEmail     :: Maybe EmailAddress
    , GenKeyParams -> Maybe ExpireDate
expireDate    :: Maybe ExpireDate
    , GenKeyParams -> Maybe CreationDate
creationDate  :: Maybe CreationDate
    , GenKeyParams -> ByteString
preferences   :: BS.ByteString
    , GenKeyParams -> ByteString
revoker       :: BS.ByteString
    , GenKeyParams -> ByteString
keyserver     :: BS.ByteString
    , GenKeyParams -> ByteString
handle        :: BS.ByteString
    , GenKeyParams -> ByteString
rawParams     :: BS.ByteString  -- ^ Add custom XML
    }

-- | Default parameters
--
-- Intended to be used to build custom paramemters.
--
-- > params = (def :: GenKeyParams) { keyType = Just Dsa }
--
-- See tests for working example of all parameters in use.
instance Default GenKeyParams where
  def :: GenKeyParams
def = Maybe PubKeyAlgo
-> Maybe BitSize
-> ByteString
-> Maybe UsageList
-> Maybe PubKeyAlgo
-> Maybe BitSize
-> ByteString
-> ByteString
-> ByteString
-> Maybe EmailAddress
-> Maybe ExpireDate
-> Maybe CreationDate
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> GenKeyParams
GenKeyParams Maybe PubKeyAlgo
forall a. Maybe a
Nothing Maybe BitSize
forall a. Maybe a
Nothing ByteString
"" Maybe UsageList
forall a. Maybe a
Nothing Maybe PubKeyAlgo
forall a. Maybe a
Nothing Maybe BitSize
forall a. Maybe a
Nothing ByteString
"" ByteString
"" ByteString
""
    Maybe EmailAddress
forall a. Maybe a
Nothing Maybe ExpireDate
forall a. Maybe a
Nothing Maybe CreationDate
forall a. Maybe a
Nothing ByteString
"" ByteString
"" ByteString
"" ByteString
"" ByteString
""

-- | Key-Length parameter
newtype BitSize = BitSize Int

-- | Bit size constrained to 1024-4096 bits
bitSize :: Int -> Either String BitSize
bitSize :: Int -> Either String BitSize
bitSize Int
x
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1024  = String -> Either String BitSize
forall a b. a -> Either a b
Left String
"BitSize must be greater than 1024"
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4096  = String -> Either String BitSize
forall a b. a -> Either a b
Left String
"BitSize must be less than 4096"
  | Bool
otherwise = BitSize -> Either String BitSize
forall a b. b -> Either a b
Right (BitSize -> Either String BitSize)
-> BitSize -> Either String BitSize
forall a b. (a -> b) -> a -> b
$ Int -> BitSize
BitSize Int
x

-- Key-Usage types
data Encrypt = Encrypt
data Sign    = Sign
data Auth    = Auth
data UsageList = UsageList {
      UsageList -> Maybe Encrypt
encrypt  :: Maybe Encrypt
    , UsageList -> Maybe Sign
sign     :: Maybe Sign
    , UsageList -> Maybe Auth
auth     :: Maybe Auth
    }

-- | Default UsageList
--
-- Intended to be used to build custom UsageList parameter
--
-- > usageListParam = (def :: UsageList) (Just Encrypt)
--
-- See tests for working example of all parameters in use.
instance Default UsageList where
  def :: UsageList
def = Maybe Encrypt -> Maybe Sign -> Maybe Auth -> UsageList
UsageList Maybe Encrypt
forall a. Maybe a
Nothing Maybe Sign
forall a. Maybe a
Nothing Maybe Auth
forall a. Maybe a
Nothing

-- | Expire-Date parameter
--
-- Beware, 'genKey' will not check that ExpireDate is after
-- CreationDate of generated key.
data ExpireDate =
  ExpireT UTCTime | ExpireD Positive | ExpireW Positive |
  ExpireM Positive | ExpireY Positive | ExpireS Positive
-- TODO: Constrain ExpireDate to something that is valid.
--       No ISODate before today or creation date.

-- | Creation-Date parameter
data CreationDate = CreationT UTCTime
                  | CreationS Positive  -- ^ Seconds since epoch

-- | Only a positive Int
newtype Positive = Positive { Positive -> Int
unPositive :: Int }
-- | Create a Positive type as long as the Int is greater than @-1@
toPositive :: Int -> Maybe Positive
toPositive :: Int -> Maybe Positive
toPositive Int
n = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Maybe Positive
forall a. Maybe a
Nothing else Positive -> Maybe Positive
forall a. a -> Maybe a
Just (Int -> Positive
Positive Int
n)

-- | Generate a GPG key
genKey :: Ctx           -- ^ context to operate in
       -> GenKeyParams  -- ^ parameters to use for generating key
       -> IO (Either GpgmeError Fpr)
genKey :: Ctx -> GenKeyParams -> IO (Either GpgmeError ByteString)
genKey Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx=Ptr C'gpgme_ctx_t
ctxPtr} GenKeyParams
params = do
  C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
F.peek Ptr C'gpgme_ctx_t
ctxPtr
  C'gpgme_error_t
ret <- ByteString -> (CString -> IO C'gpgme_error_t) -> IO C'gpgme_error_t
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (GenKeyParams -> ByteString
toParamsString GenKeyParams
params) ((CString -> IO C'gpgme_error_t) -> IO C'gpgme_error_t)
-> (CString -> IO C'gpgme_error_t) -> IO C'gpgme_error_t
forall a b. (a -> b) -> a -> b
$ \CString
p -> do
    let nullGpgmeData :: C'gpgme_ctx_t
nullGpgmeData = C'gpgme_ctx_t
0  -- Using 0 as NULL for gpgme_data_t
    C'gpgme_ctx_t
-> CString -> C'gpgme_ctx_t -> C'gpgme_ctx_t -> IO C'gpgme_error_t
c'gpgme_op_genkey C'gpgme_ctx_t
ctx CString
p C'gpgme_ctx_t
nullGpgmeData C'gpgme_ctx_t
nullGpgmeData
  if C'gpgme_error_t
ret C'gpgme_error_t -> C'gpgme_error_t -> Bool
forall a. Eq a => a -> a -> Bool
== C'gpgme_error_t
forall a. Num a => a
noError
    then do
      C'gpgme_genkey_result_t
rPtr <- C'gpgme_ctx_t -> IO C'gpgme_genkey_result_t
c'gpgme_op_genkey_result C'gpgme_ctx_t
ctx
      C'_gpgme_op_genkey_result
r <- C'gpgme_genkey_result_t -> IO C'_gpgme_op_genkey_result
forall a. Storable a => Ptr a -> IO a
F.peek C'gpgme_genkey_result_t
rPtr
      let fprPtr :: CString
fprPtr = C'_gpgme_op_genkey_result -> CString
c'_gpgme_op_genkey_result'fpr C'_gpgme_op_genkey_result
r
      String
fpr <- CString -> IO String
FCS.peekCString CString
fprPtr

      Either GpgmeError ByteString -> IO (Either GpgmeError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GpgmeError ByteString -> IO (Either GpgmeError ByteString))
-> (ByteString -> Either GpgmeError ByteString)
-> ByteString
-> IO (Either GpgmeError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either GpgmeError ByteString
forall a b. b -> Either a b
Right (ByteString -> IO (Either GpgmeError ByteString))
-> ByteString -> IO (Either GpgmeError ByteString)
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC8.pack String
fpr
    else Either GpgmeError ByteString -> IO (Either GpgmeError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GpgmeError ByteString -> IO (Either GpgmeError ByteString))
-> (GpgmeError -> Either GpgmeError ByteString)
-> GpgmeError
-> IO (Either GpgmeError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GpgmeError -> Either GpgmeError ByteString
forall a b. a -> Either a b
Left (GpgmeError -> IO (Either GpgmeError ByteString))
-> GpgmeError -> IO (Either GpgmeError ByteString)
forall a b. (a -> b) -> a -> b
$ C'gpgme_error_t -> GpgmeError
GpgmeError C'gpgme_error_t
ret

-- | Used by 'genKey' generate a XML string for GPG
toParamsString :: GenKeyParams -> BS.ByteString
toParamsString :: GenKeyParams -> ByteString
toParamsString GenKeyParams
params = ([ByteString] -> ByteString
BSC8.unlines ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString
"" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=))
    [ ByteString
"<GnupgKeyParms format=\"internal\">"
    , ByteString
"Key-Type: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (PubKeyAlgo -> ByteString) -> Maybe PubKeyAlgo -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"default" PubKeyAlgo -> ByteString
keyTypeToString (GenKeyParams -> Maybe PubKeyAlgo
keyType GenKeyParams
params)
    , ByteString
-> (BitSize -> ByteString) -> Maybe BitSize -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Key-Length: " BitSize -> ByteString
keyLengthToString (Maybe BitSize -> ByteString) -> Maybe BitSize -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe BitSize
keyLength GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Key-Grip: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
keyGrip GenKeyParams
params
    , ByteString
-> (UsageList -> ByteString) -> Maybe UsageList -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Key-Usage: " UsageList -> ByteString
keyUsageListToString (Maybe UsageList -> ByteString) -> Maybe UsageList -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe UsageList
keyUsage GenKeyParams
params
    , ByteString
-> (PubKeyAlgo -> ByteString) -> Maybe PubKeyAlgo -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Subkey-Type: " PubKeyAlgo -> ByteString
keyTypeToString (Maybe PubKeyAlgo -> ByteString) -> Maybe PubKeyAlgo -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe PubKeyAlgo
subkeyType GenKeyParams
params
    , ByteString
-> (BitSize -> ByteString) -> Maybe BitSize -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Subkey-Length: " BitSize -> ByteString
keyLengthToString (Maybe BitSize -> ByteString) -> Maybe BitSize -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe BitSize
subkeyLength GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Passphrase: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
passphrase GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Name-Real: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
nameReal GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Name-Comment: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
nameComment GenKeyParams
params
    , ByteString
-> (EmailAddress -> ByteString) -> Maybe EmailAddress -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Name-Email: " EmailAddress -> ByteString
toByteString (Maybe EmailAddress -> ByteString)
-> Maybe EmailAddress -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe EmailAddress
nameEmail GenKeyParams
params
    , ByteString
-> (ExpireDate -> ByteString) -> Maybe ExpireDate -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Expire-Date: " ExpireDate -> ByteString
expireDateToString (Maybe ExpireDate -> ByteString) -> Maybe ExpireDate -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe ExpireDate
expireDate GenKeyParams
params
    , ByteString
-> (CreationDate -> ByteString) -> Maybe CreationDate -> ByteString
forall a. ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
"Creation-Date: " CreationDate -> ByteString
creationDateToString (Maybe CreationDate -> ByteString)
-> Maybe CreationDate -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> Maybe CreationDate
creationDate GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Preferences: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
preferences GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Revoker: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
revoker GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Keyserver: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
keyserver GenKeyParams
params
    , ByteString -> ByteString -> ByteString
addLabel ByteString
"Handle: " (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GenKeyParams -> ByteString
handle GenKeyParams
params
    -- Allow for additional parameters as a raw ByteString
    , GenKeyParams -> ByteString
rawParams GenKeyParams
params
    , ByteString
"</GnupgKeyParms>"
    ]
  where
    maybeLine :: BS.ByteString -> (a -> BS.ByteString) -> Maybe a -> BS.ByteString
    maybeLine :: ByteString -> (a -> ByteString) -> Maybe a -> ByteString
maybeLine ByteString
h a -> ByteString
f Maybe a
p = ByteString -> ByteString -> ByteString
addLabel ByteString
h (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (a -> ByteString) -> Maybe a -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" a -> ByteString
f Maybe a
p
    -- Add label if not an empty string
    addLabel :: BS.ByteString -> BS.ByteString -> BS.ByteString
    addLabel :: ByteString -> ByteString -> ByteString
addLabel ByteString
_ ByteString
"" = ByteString
""
    addLabel ByteString
h ByteString
s  = ByteString
h ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
s
    keyTypeToString :: PubKeyAlgo -> BS.ByteString
    keyTypeToString :: PubKeyAlgo -> ByteString
keyTypeToString PubKeyAlgo
Rsa   = ByteString
"RSA"
    keyTypeToString PubKeyAlgo
RsaE  = ByteString
"RSA-E"
    keyTypeToString PubKeyAlgo
RsaS  = ByteString
"RSA-S"
    keyTypeToString PubKeyAlgo
ElgE  = ByteString
"ELG-E"
    keyTypeToString PubKeyAlgo
Dsa   = ByteString
"DSA"
    keyTypeToString PubKeyAlgo
Elg   = ByteString
"ELG"
    keyLengthToString :: BitSize -> BS.ByteString
    keyLengthToString :: BitSize -> ByteString
keyLengthToString (BitSize Int
i) = String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
    keyUsageListToString :: UsageList -> BS.ByteString
    keyUsageListToString :: UsageList -> ByteString
keyUsageListToString (UsageList Maybe Encrypt
e Maybe Sign
s Maybe Auth
a) =
      let eStr :: ByteString
eStr = ByteString
-> (Encrypt -> ByteString) -> Maybe Encrypt -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
""::BS.ByteString) (ByteString -> Encrypt -> ByteString
forall a b. a -> b -> a
const ByteString
"encrypt") Maybe Encrypt
e
          sStr :: ByteString
sStr = ByteString -> (Sign -> ByteString) -> Maybe Sign -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
""::BS.ByteString) (ByteString -> Sign -> ByteString
forall a b. a -> b -> a
const ByteString
"sign") Maybe Sign
s
          aStr :: ByteString
aStr = ByteString -> (Auth -> ByteString) -> Maybe Auth -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
""::BS.ByteString) (ByteString -> Auth -> ByteString
forall a b. a -> b -> a
const ByteString
"auth") Maybe Auth
a
      in (ByteString -> [ByteString] -> ByteString
BSC8.intercalate ByteString
"," ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString
"" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=)) [ByteString
eStr, ByteString
sStr, ByteString
aStr]
    expireDateToString :: ExpireDate -> BS.ByteString
    expireDateToString :: ExpireDate -> ByteString
expireDateToString (ExpireD Positive
p) = String -> ByteString
BSC8.pack (Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"d")
    expireDateToString (ExpireW Positive
p) = String -> ByteString
BSC8.pack (Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"w")
    expireDateToString (ExpireM Positive
p) = String -> ByteString
BSC8.pack (Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"m")
    expireDateToString (ExpireY Positive
p) = String -> ByteString
BSC8.pack (Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"y")
    expireDateToString (ExpireS Positive
p) =
      String -> ByteString
BSC8.pack (String
"seconds=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p))
    expireDateToString (ExpireT UTCTime
t) =
      String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%dT%H%M%S" UTCTime
t
    creationDateToString :: CreationDate -> BS.ByteString
    creationDateToString :: CreationDate -> ByteString
creationDateToString (CreationS Positive
p) =
      String -> ByteString
BSC8.pack (String
"seconds=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Positive -> Int
unPositive Positive
p))
    creationDateToString (CreationT UTCTime
t) =
      String -> ByteString
BSC8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%dT%H%M%S" UTCTime
t