module Gamgee.Effects.Crypto
(
Crypto(..)
, encryptSecret
, decryptSecret
, 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
data Crypto m a where
Encrypt :: Text
-> Text
-> Crypto m Token.TokenSecret
Decrypt :: Text
-> Text
-> Text
-> Crypto m Text
P.makeSem ''Crypto
encryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Token.TokenSpec
encryptSecret spec =
case Token.tokenSecret spec of
Token.TokenSecretAES256 _ _ -> return spec
Token.TokenSecretPlainText plainSecret -> do
password <- SI.secretInput "Password to encrypt (leave blank to skip encryption): "
if Text.null password
then return spec
else do
let secret = (Text.toUpper . Text.dropWhileEnd (== '=') . Text.replace " " "" . Text.replace "-" "" . Text.strip) plainSecret
secret' <- encrypt secret password
return spec { Token.tokenSecret = secret' }
decryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Text
decryptSecret spec =
case Token.tokenSecret spec of
Token.TokenSecretPlainText plainSecret -> return plainSecret
Token.TokenSecretAES256 encIV encSecret -> do
password <- SI.secretInput "Password: "
decrypt encIV encSecret password
runCrypto :: Members [CR.CryptoRandom, P.Error Err.EffError] r => Sem (Crypto : r) a -> Sem r a
runCrypto = P.interpret $ \case
Encrypt secret password -> do
iv <- genRandomIV
toTokenSecret iv secret password
Decrypt encIV encSecret password -> fromTokenSecret encIV encSecret password
genRandomIV :: Members [P.Error Err.EffError, CR.CryptoRandom] r => Sem r (CT.IV AES256)
genRandomIV = do
bytes <- CR.randomBytes $ CT.blockSize (error "Internal Error: This shouldn't be evaluated" :: AES256)
case CT.makeIV (bytes :: ByteString) of
Just iv -> return iv
Nothing -> error "Internal Error: Unable to generate random initial vector"
toTokenSecret :: Member (P.Error Err.EffError) r
=> CT.IV AES256
-> Text
-> Text
-> Sem r Token.TokenSecret
toTokenSecret iv secret password = do
cipher <- CE.onCryptoFailure (P.throw . Err.CryptoError) return $ CT.cipherInit (passwordToKey password)
return Token.TokenSecretAES256 {
Token.tokenSecretAES256IV = toBase64 $ BA.convert iv
, Token.tokenSecretAES256Data = toBase64 $ CT.ctrCombine cipher iv (encodeUtf8 secret)
}
fromTokenSecret :: Member (P.Error Err.EffError) r
=> Text
-> Text
-> Text
-> Sem r Text
fromTokenSecret encIV encSecret password = do
iv <- fromBase64 encIV
case CT.makeIV iv of
Nothing -> P.throw $ Err.CorruptIV iv
Just iv' -> do
secret <- fromBase64 encSecret
cipher <- CE.onCryptoFailure (P.throw . Err.CryptoError) return $ CT.cipherInit (passwordToKey password)
return $ decodeUtf8 $ CT.ctrCombine (cipher :: AES256) iv' secret
passwordToKey :: Text -> ByteString
passwordToKey password = toStrict $ LBS.take 32 $ LBS.cycle $ encodeUtf8 password
toBase64 :: ByteString -> Text
toBase64 = decodeUtf8 . B64.encode
fromBase64 :: Member (P.Error Err.EffError) r
=> Text
-> Sem r ByteString
fromBase64 = either (P.throw . Err.CorruptBase64Encoding . toText) return . B64.decode . encodeUtf8