-- | Cryptographic effect for securing tokens
module Gamgee.Effects.Crypto
    ( -- * Effect
      Crypto(..)

      -- * Programs
    , encryptSecret
    , decryptSecret

      -- * Interpretations
    , runCrypto
    ) where

import           Crypto.Cipher.AES           (AES256)
import qualified Crypto.Cipher.Types         as CT
import qualified Crypto.Error                as CE
import qualified Data.ByteArray              as BA
import qualified Data.ByteString.Base64      as B64
import qualified Data.ByteString.Lazy        as LBS
import qualified Data.Text                   as Text
import qualified Gamgee.Effects.CryptoRandom as CR
import qualified Gamgee.Effects.Error        as Err
import qualified Gamgee.Effects.SecretInput  as SI
import qualified Gamgee.Token                as Token
import           Polysemy                    (Member, Members, Sem)
import qualified Polysemy                    as P
import qualified Polysemy.Error              as P
import           Relude


----------------------------------------------------------------------------------------------------
-- Effect
----------------------------------------------------------------------------------------------------

-- | Effect for encrypting and decrypting secrets
data Crypto m a where
  -- | Encrypts a secret with an optional password
  Encrypt :: Text                        -- ^ The secret to encrypt
          -> Text                        -- ^ The password
          -> Crypto m Token.TokenSecret
  -- | Decrypt a secret with an optional password
  Decrypt :: Text              -- ^ Base64 encoded IV
          -> Text              -- ^ Base64 encoded encrypted secret
          -> Text              -- ^ The password for decryption
          -> Crypto m Text     -- ^ Decrypted secret

P.makeSem ''Crypto


----------------------------------------------------------------------------------------------------
-- Programs
----------------------------------------------------------------------------------------------------

encryptSecret :: Members [SI.SecretInput Text, Crypto] r
              => Token.TokenSpec
              -> Sem r Token.TokenSpec
encryptSecret :: TokenSpec -> Sem r TokenSpec
encryptSecret TokenSpec
spec =
  case TokenSpec -> TokenSecret
Token.tokenSecret TokenSpec
spec of
    -- Secret is already encrypted
    Token.TokenSecretAES256 Text
_ Text
_ -> TokenSpec -> Sem r TokenSpec
forall (m :: * -> *) a. Monad m => a -> m a
return TokenSpec
spec
    Token.TokenSecretPlainText Text
plainSecret -> do
      -- Ask the user for a password
      Text
password <- Text -> Sem r Text
forall i (r :: [Effect]).
MemberWithError (SecretInput i) r =>
Text -> Sem r i
SI.secretInput Text
"Password to encrypt (leave blank to skip encryption): "

      -- Sometimes the secret may contain extraneous chars - '=', '-', space etc. Clear those.
      let secret :: Text
secret = (Text -> Text
Text.toUpper (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
" " Text
"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"-" Text
"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip) Text
plainSecret

      TokenSecret
secret' <- if Text -> Bool
Text.null Text
password
                 then TokenSecret -> Sem r TokenSecret
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenSecret -> Sem r TokenSecret)
-> TokenSecret -> Sem r TokenSecret
forall a b. (a -> b) -> a -> b
$ Text -> TokenSecret
Token.TokenSecretPlainText Text
secret
                 else Text -> Text -> Sem r TokenSecret
forall (r :: [Effect]).
MemberWithError Crypto r =>
Text -> Text -> Sem r TokenSecret
encrypt Text
secret Text
password

      return TokenSpec
spec { tokenSecret :: TokenSecret
Token.tokenSecret = TokenSecret
secret' }

decryptSecret :: Members [SI.SecretInput Text, Crypto] r
              => Token.TokenSpec
              -> Sem r Text
decryptSecret :: TokenSpec -> Sem r Text
decryptSecret TokenSpec
spec =
  case TokenSpec -> TokenSecret
Token.tokenSecret TokenSpec
spec of
    Token.TokenSecretPlainText Text
plainSecret  -> Text -> Sem r Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
plainSecret
    Token.TokenSecretAES256 Text
encIV Text
encSecret -> do
      Text
password <- Text -> Sem r Text
forall i (r :: [Effect]).
MemberWithError (SecretInput i) r =>
Text -> Sem r i
SI.secretInput Text
"Password: "
      Text -> Text -> Text -> Sem r Text
forall (r :: [Effect]).
MemberWithError Crypto r =>
Text -> Text -> Text -> Sem r Text
decrypt Text
encIV Text
encSecret Text
password


----------------------------------------------------------------------------------------------------
-- Interpretations
----------------------------------------------------------------------------------------------------

runCrypto :: Members [CR.CryptoRandom, P.Error Err.EffError] r => Sem (Crypto : r) a -> Sem r a
runCrypto :: Sem (Crypto : r) a -> Sem r a
runCrypto = (forall x (rInitial :: [Effect]).
 Crypto (Sem rInitial) x -> Sem r x)
-> Sem (Crypto : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [Effect]). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret ((forall x (rInitial :: [Effect]).
  Crypto (Sem rInitial) x -> Sem r x)
 -> Sem (Crypto : r) a -> Sem r a)
-> (forall x (rInitial :: [Effect]).
    Crypto (Sem rInitial) x -> Sem r x)
-> Sem (Crypto : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Encrypt secret password -> do
    IV AES256
iv <- Sem r (IV AES256)
forall (r :: [Effect]).
Members '[Error EffError, CryptoRandom] r =>
Sem r (IV AES256)
genRandomIV
    IV AES256 -> Text -> Text -> Sem r TokenSecret
forall (r :: [Effect]).
Member (Error EffError) r =>
IV AES256 -> Text -> Text -> Sem r TokenSecret
toTokenSecret IV AES256
iv Text
secret Text
password

  Decrypt encIV encSecret password -> Text -> Text -> Text -> Sem r Text
forall (r :: [Effect]).
Member (Error EffError) r =>
Text -> Text -> Text -> Sem r Text
fromTokenSecret Text
encIV Text
encSecret Text
password

-- | Generate a random initialization vector
genRandomIV :: Members [P.Error Err.EffError, CR.CryptoRandom] r => Sem r (CT.IV AES256)
genRandomIV :: Sem r (IV AES256)
genRandomIV = do
  ByteString
bytes <- Int -> Sem r ByteString
forall (r :: [Effect]) b.
(MemberWithError CryptoRandom r, ByteArray b) =>
Int -> Sem r b
CR.randomBytes (Int -> Sem r ByteString) -> Int -> Sem r ByteString
forall a b. (a -> b) -> a -> b
$ AES256 -> Int
forall cipher. BlockCipher cipher => cipher -> Int
CT.blockSize (Text -> AES256
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Internal Error: This shouldn't be evaluated" :: AES256)
  case ByteString -> Maybe (IV AES256)
forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
CT.makeIV (ByteString
bytes :: ByteString) of
    Just IV AES256
iv -> IV AES256 -> Sem r (IV AES256)
forall (m :: * -> *) a. Monad m => a -> m a
return IV AES256
iv
    Maybe (IV AES256)
Nothing -> Text -> Sem r (IV AES256)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Internal Error: Unable to generate random initial vector"

-- | Generate an encrypted TokenSecret from an iv, a secret text and password
toTokenSecret :: Member (P.Error Err.EffError) r
              => CT.IV AES256
              -> Text                    -- ^ Secret
              -> Text                    -- ^ Password
              -> Sem r Token.TokenSecret
toTokenSecret :: IV AES256 -> Text -> Text -> Sem r TokenSecret
toTokenSecret IV AES256
iv Text
secret Text
password = do
  AES256
cipher <- (CryptoError -> Sem r AES256)
-> (AES256 -> Sem r AES256)
-> CryptoFailable AES256
-> Sem r AES256
forall r a. (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r
CE.onCryptoFailure (EffError -> Sem r AES256
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r AES256)
-> (CryptoError -> EffError) -> CryptoError -> Sem r AES256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> EffError
Err.CryptoError) AES256 -> Sem r AES256
forall (m :: * -> *) a. Monad m => a -> m a
return (CryptoFailable AES256 -> Sem r AES256)
-> CryptoFailable AES256 -> Sem r AES256
forall a b. (a -> b) -> a -> b
$ ByteString -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
CT.cipherInit (Text -> ByteString
passwordToKey Text
password)
  return TokenSecretAES256 :: Text -> Text -> TokenSecret
Token.TokenSecretAES256 {
    tokenSecretAES256IV :: Text
Token.tokenSecretAES256IV = ByteString -> Text
toBase64 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ IV AES256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert IV AES256
iv
    , tokenSecretAES256Data :: Text
Token.tokenSecretAES256Data = ByteString -> Text
toBase64 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ AES256 -> IV AES256 -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
CT.ctrCombine AES256
cipher IV AES256
iv (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
secret)
    }

-- | Extract the secret text from a TokenSecret given its password
fromTokenSecret :: Member (P.Error Err.EffError) r
                => Text       -- ^ Base64 encoded IV
                -> Text       -- ^ Base64 encoded encrypted secret
                -> Text       -- ^ The password
                -> Sem r Text -- ^ IV and secret
fromTokenSecret :: Text -> Text -> Text -> Sem r Text
fromTokenSecret Text
encIV Text
encSecret Text
password = do
  ByteString
iv <- Text -> Sem r ByteString
forall (r :: [Effect]).
Member (Error EffError) r =>
Text -> Sem r ByteString
fromBase64 Text
encIV
  case ByteString -> Maybe (IV AES256)
forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
CT.makeIV ByteString
iv of
    Maybe (IV AES256)
Nothing  -> EffError -> Sem r Text
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r Text) -> EffError -> Sem r Text
forall a b. (a -> b) -> a -> b
$ ByteString -> EffError
Err.CorruptIV ByteString
iv
    Just IV AES256
iv' -> do
      ByteString
secret <- Text -> Sem r ByteString
forall (r :: [Effect]).
Member (Error EffError) r =>
Text -> Sem r ByteString
fromBase64 Text
encSecret
      AES256
cipher <- (CryptoError -> Sem r AES256)
-> (AES256 -> Sem r AES256)
-> CryptoFailable AES256
-> Sem r AES256
forall r a. (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r
CE.onCryptoFailure (EffError -> Sem r AES256
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r AES256)
-> (CryptoError -> EffError) -> CryptoError -> Sem r AES256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoError -> EffError
Err.CryptoError) AES256 -> Sem r AES256
forall (m :: * -> *) a. Monad m => a -> m a
return (CryptoFailable AES256 -> Sem r AES256)
-> CryptoFailable AES256 -> Sem r AES256
forall a b. (a -> b) -> a -> b
$ ByteString -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
CT.cipherInit (Text -> ByteString
passwordToKey Text
password)
      return $ ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ AES256 -> IV AES256 -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
CT.ctrCombine (AES256
cipher :: AES256) IV AES256
iv' ByteString
secret

passwordToKey :: Text -> ByteString
passwordToKey :: Text -> ByteString
passwordToKey Text
password = ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
LBS.take Int64
32 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.cycle (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
password

toBase64 :: ByteString -> Text
toBase64 :: ByteString -> Text
toBase64 = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode

fromBase64 :: Member (P.Error Err.EffError) r
           => Text
           -> Sem r ByteString
fromBase64 :: Text -> Sem r ByteString
fromBase64 = (String -> Sem r ByteString)
-> (ByteString -> Sem r ByteString)
-> Either String ByteString
-> Sem r ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EffError -> Sem r ByteString
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r ByteString)
-> (String -> EffError) -> String -> Sem r ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> EffError
Err.CorruptBase64Encoding (Text -> EffError) -> (String -> Text) -> String -> EffError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText) ByteString -> Sem r ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> Sem r ByteString)
-> (Text -> Either String ByteString) -> Text -> Sem r ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8