module Crypto.Age.Identity
  ( -- * Identity
    Identity (..)

    -- ** @scrypt@
  , ScryptIdentity (..)

    -- ** X25519
  , X25519Identity (..)
  , bytesToX25519Identity
  , x25519IdentityToBytes
  , toX25519Recipient
  , generateX25519Identity
  , encodeX25519Identity
  , DecodeX25519IdentityError (..)
  , decodeX25519Identity
  ) where

import qualified Codec.Binary.Bech32 as Bech32
import Control.Monad ( when )
import Crypto.Age.Recipient ( X25519Recipient (..) )
import Crypto.Age.Scrypt ( Passphrase, WorkFactor )
import qualified Crypto.Error as Crypto
import qualified Crypto.PubKey.Curve25519 as Curve25519
import Data.Bifunctor ( first )
import Data.ByteArray ( ScrubbedBytes )
import qualified Data.ByteArray as BA
import Data.Text ( Text )
import qualified Data.Text as T
import Prelude

-- | [@scrypt@ identity](https://github.com/C2SP/C2SP/blob/91935d7157cb3860351ffebbad1e6f6153e8efc8/age.md#the-scrypt-recipient-type).
data ScryptIdentity = ScryptIdentity
  { -- | Passphrase.
    ScryptIdentity -> Passphrase
siPassphrase :: !Passphrase
  , -- | Maximum work factor permitted for this identity.
    ScryptIdentity -> WorkFactor
siMaxWorkFactor :: !WorkFactor
  } deriving stock (Int -> ScryptIdentity -> ShowS
[ScryptIdentity] -> ShowS
ScryptIdentity -> String
(Int -> ScryptIdentity -> ShowS)
-> (ScryptIdentity -> String)
-> ([ScryptIdentity] -> ShowS)
-> Show ScryptIdentity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScryptIdentity -> ShowS
showsPrec :: Int -> ScryptIdentity -> ShowS
$cshow :: ScryptIdentity -> String
show :: ScryptIdentity -> String
$cshowList :: [ScryptIdentity] -> ShowS
showList :: [ScryptIdentity] -> ShowS
Show, ScryptIdentity -> ScryptIdentity -> Bool
(ScryptIdentity -> ScryptIdentity -> Bool)
-> (ScryptIdentity -> ScryptIdentity -> Bool) -> Eq ScryptIdentity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScryptIdentity -> ScryptIdentity -> Bool
== :: ScryptIdentity -> ScryptIdentity -> Bool
$c/= :: ScryptIdentity -> ScryptIdentity -> Bool
/= :: ScryptIdentity -> ScryptIdentity -> Bool
Eq)

-- | [X25519 identity](https://github.com/C2SP/C2SP/blob/91935d7157cb3860351ffebbad1e6f6153e8efc8/age.md#the-x25519-recipient-type).
--
-- Note that this type's 'Eq' instance performs a constant-time equality
-- check.
newtype X25519Identity = X25519Identity
  { X25519Identity -> SecretKey
unX25519Identity :: Curve25519.SecretKey }
  deriving newtype (Int -> X25519Identity -> ShowS
[X25519Identity] -> ShowS
X25519Identity -> String
(Int -> X25519Identity -> ShowS)
-> (X25519Identity -> String)
-> ([X25519Identity] -> ShowS)
-> Show X25519Identity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> X25519Identity -> ShowS
showsPrec :: Int -> X25519Identity -> ShowS
$cshow :: X25519Identity -> String
show :: X25519Identity -> String
$cshowList :: [X25519Identity] -> ShowS
showList :: [X25519Identity] -> ShowS
Show, X25519Identity -> X25519Identity -> Bool
(X25519Identity -> X25519Identity -> Bool)
-> (X25519Identity -> X25519Identity -> Bool) -> Eq X25519Identity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: X25519Identity -> X25519Identity -> Bool
== :: X25519Identity -> X25519Identity -> Bool
$c/= :: X25519Identity -> X25519Identity -> Bool
/= :: X25519Identity -> X25519Identity -> Bool
Eq)

-- | Construct an 'X25519Identity' from the raw bytes of a Curve25519 secret
-- key.
--
-- If the provided byte string does not have a length of 32 (256 bits),
-- 'Nothing' is returned.
bytesToX25519Identity :: ScrubbedBytes -> Maybe X25519Identity
bytesToX25519Identity :: ScrubbedBytes -> Maybe X25519Identity
bytesToX25519Identity =
  (SecretKey -> X25519Identity
X25519Identity (SecretKey -> X25519Identity)
-> Maybe SecretKey -> Maybe X25519Identity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (Maybe SecretKey -> Maybe X25519Identity)
-> (ScrubbedBytes -> Maybe SecretKey)
-> ScrubbedBytes
-> Maybe X25519Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable SecretKey -> Maybe SecretKey
forall a. CryptoFailable a -> Maybe a
Crypto.maybeCryptoError
    (CryptoFailable SecretKey -> Maybe SecretKey)
-> (ScrubbedBytes -> CryptoFailable SecretKey)
-> ScrubbedBytes
-> Maybe SecretKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> CryptoFailable SecretKey
forall bs. ByteArrayAccess bs => bs -> CryptoFailable SecretKey
Curve25519.secretKey

-- | Get the raw Curve25519 secret key bytes associated with an
-- 'X25519Identity'.
x25519IdentityToBytes :: X25519Identity -> ScrubbedBytes
x25519IdentityToBytes :: X25519Identity -> ScrubbedBytes
x25519IdentityToBytes = SecretKey -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> ScrubbedBytes)
-> (X25519Identity -> SecretKey) -> X25519Identity -> ScrubbedBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X25519Identity -> SecretKey
unX25519Identity

-- | Get the 'X25519Recipient' which corresponds to the given 'X25519Identity'.
toX25519Recipient :: X25519Identity -> X25519Recipient
toX25519Recipient :: X25519Identity -> X25519Recipient
toX25519Recipient (X25519Identity SecretKey
sk) =
  PublicKey -> X25519Recipient
X25519Recipient (SecretKey -> PublicKey
Curve25519.toPublic SecretKey
sk)

-- | Randomly generate a 'X25519Identity'.
generateX25519Identity :: IO X25519Identity
generateX25519Identity :: IO X25519Identity
generateX25519Identity = SecretKey -> X25519Identity
X25519Identity (SecretKey -> X25519Identity) -> IO SecretKey -> IO X25519Identity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SecretKey
forall (m :: * -> *). MonadRandom m => m SecretKey
Curve25519.generateSecretKey

x25519IdentityBech32Hrp :: Bech32.HumanReadablePart
x25519IdentityBech32Hrp :: HumanReadablePart
x25519IdentityBech32Hrp =
  case Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText Text
"AGE-SECRET-KEY-" of
    Left HumanReadablePartError
_ -> String -> HumanReadablePart
forall a. HasCallStack => String -> a
error String
"x25519IdentityBech32Hrp: impossible: \"AGE-SECRET-KEY-\" is an invalid HRP"
    Right HumanReadablePart
hrp -> HumanReadablePart
hrp

-- | Encode an 'X25519Identity' as
-- [Bech32](https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki).
encodeX25519Identity :: X25519Identity -> Either Bech32.EncodingError Text
encodeX25519Identity :: X25519Identity -> Either EncodingError Text
encodeX25519Identity X25519Identity
i =
  Text -> Text
T.toUpper
    (Text -> Text)
-> Either EncodingError Text -> Either EncodingError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HumanReadablePart -> DataPart -> Either EncodingError Text
Bech32.encode
      HumanReadablePart
x25519IdentityBech32Hrp
      (ByteString -> DataPart
Bech32.dataPartFromBytes (ByteString -> DataPart)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> DataPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ScrubbedBytes -> DataPart) -> ScrubbedBytes -> DataPart
forall a b. (a -> b) -> a -> b
$ X25519Identity -> ScrubbedBytes
x25519IdentityToBytes X25519Identity
i)

-- | Error decoding an 'X25519Identity' from Bech32.
data DecodeX25519IdentityError
  = -- | Bech32 decoding error.
    DecodeX25519IdentityBech32DecodingError !Bech32.DecodingError
  | -- | Invalid Bech32 human-readable part.
    DecodeX25519IdentityInvalidHumanReadablePartError
      -- | Expected Bech32 human-readable part.
      !Bech32.HumanReadablePart
      -- | Actual Bech32 human-readable part.
      !Bech32.HumanReadablePart
  | -- | Invalid Bech32 data part.
    DecodeX25519IdentityInvalidDataPartError
  | -- | Invalid Curve25519 secret key size.
    DecodeX25519IdentityInvalidSecretKeySizeError
  deriving stock (Int -> DecodeX25519IdentityError -> ShowS
[DecodeX25519IdentityError] -> ShowS
DecodeX25519IdentityError -> String
(Int -> DecodeX25519IdentityError -> ShowS)
-> (DecodeX25519IdentityError -> String)
-> ([DecodeX25519IdentityError] -> ShowS)
-> Show DecodeX25519IdentityError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeX25519IdentityError -> ShowS
showsPrec :: Int -> DecodeX25519IdentityError -> ShowS
$cshow :: DecodeX25519IdentityError -> String
show :: DecodeX25519IdentityError -> String
$cshowList :: [DecodeX25519IdentityError] -> ShowS
showList :: [DecodeX25519IdentityError] -> ShowS
Show, DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool
(DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool)
-> (DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool)
-> Eq DecodeX25519IdentityError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool
== :: DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool
$c/= :: DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool
/= :: DecodeX25519IdentityError -> DecodeX25519IdentityError -> Bool
Eq)

-- | Decode an 'X25519Identity' from
-- [Bech32](https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki).
decodeX25519Identity :: Text -> Either DecodeX25519IdentityError X25519Identity
decodeX25519Identity :: Text -> Either DecodeX25519IdentityError X25519Identity
decodeX25519Identity Text
t = do
  (HumanReadablePart
hrp, DataPart
dp) <- (DecodingError -> DecodeX25519IdentityError)
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either DecodeX25519IdentityError (HumanReadablePart, DataPart)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecodingError -> DecodeX25519IdentityError
DecodeX25519IdentityBech32DecodingError (Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decode Text
t)
  Bool
-> Either DecodeX25519IdentityError ()
-> Either DecodeX25519IdentityError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (HumanReadablePart
x25519IdentityBech32Hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
/= HumanReadablePart
hrp)
    (DecodeX25519IdentityError -> Either DecodeX25519IdentityError ()
forall a b. a -> Either a b
Left (DecodeX25519IdentityError -> Either DecodeX25519IdentityError ())
-> DecodeX25519IdentityError -> Either DecodeX25519IdentityError ()
forall a b. (a -> b) -> a -> b
$ HumanReadablePart -> HumanReadablePart -> DecodeX25519IdentityError
DecodeX25519IdentityInvalidHumanReadablePartError HumanReadablePart
x25519IdentityBech32Hrp HumanReadablePart
hrp)
  ByteString
dpBs <-
    case DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dp of
      Maybe ByteString
Nothing -> DecodeX25519IdentityError
-> Either DecodeX25519IdentityError ByteString
forall a b. a -> Either a b
Left DecodeX25519IdentityError
DecodeX25519IdentityInvalidDataPartError
      Just ByteString
bs -> ByteString -> Either DecodeX25519IdentityError ByteString
forall a b. b -> Either a b
Right ByteString
bs
  case ScrubbedBytes -> Maybe X25519Identity
bytesToX25519Identity (ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
dpBs) of
    Maybe X25519Identity
Nothing -> DecodeX25519IdentityError
-> Either DecodeX25519IdentityError X25519Identity
forall a b. a -> Either a b
Left DecodeX25519IdentityError
DecodeX25519IdentityInvalidSecretKeySizeError
    Just X25519Identity
i -> X25519Identity -> Either DecodeX25519IdentityError X25519Identity
forall a b. b -> Either a b
Right X25519Identity
i

-- | age identity.
data Identity
  = -- | @scrypt@ identity.
    IdentityScrypt !ScryptIdentity
  | -- | X25519 identity.
    IdentityX25519 !X25519Identity
  deriving stock (Int -> Identity -> ShowS
[Identity] -> ShowS
Identity -> String
(Int -> Identity -> ShowS)
-> (Identity -> String) -> ([Identity] -> ShowS) -> Show Identity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Identity -> ShowS
showsPrec :: Int -> Identity -> ShowS
$cshow :: Identity -> String
show :: Identity -> String
$cshowList :: [Identity] -> ShowS
showList :: [Identity] -> ShowS
Show, Identity -> Identity -> Bool
(Identity -> Identity -> Bool)
-> (Identity -> Identity -> Bool) -> Eq Identity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Identity -> Identity -> Bool
== :: Identity -> Identity -> Bool
$c/= :: Identity -> Identity -> Bool
/= :: Identity -> Identity -> Bool
Eq)