{-# LANGUAGE OverloadedStrings #-}
module Crypto.Gpgme.Key.Gen (
genKey
, GenKeyParams (..)
, BitSize
, Crypto.Gpgme.Key.Gen.bitSize
, UsageList (..)
, Encrypt (..)
, Sign (..)
, Auth (..)
, ExpireDate (..)
, CreationDate (..)
, 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
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
, :: 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
}
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
""
newtype BitSize = BitSize Int
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
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
}
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
data ExpireDate =
ExpireT UTCTime | ExpireD Positive | ExpireW Positive |
ExpireM Positive | ExpireY Positive | ExpireS Positive
data CreationDate = CreationT UTCTime
| CreationS Positive
newtype Positive = Positive { Positive -> Int
unPositive :: Int }
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)
genKey :: Ctx
-> GenKeyParams
-> 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
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
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
, 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
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