{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contains functions specific to the [pgcrypto](https://www.postgresql.org/docs/current/pgcrypto.html) module

module Database.Esqueleto.PostgreSQL.Pgcrypto
    (HashAlgorithm(..),
     toCrypt,
     fromCrypt,
    ) where

import qualified Data.Text.Internal.Builder as TLB
import Database.Esqueleto.Experimental (toPersistValue)
import Database.Esqueleto.Internal.Internal

{- | pgcrypto hashing algorithms
see: https://www.postgresql.org/docs/current/pgcrypto.html

`bf` and `xdes` algorithms have an optional iterations count parameter. All limitations and considerations
mentioned in the `pgcrypto` module documentation regarding iteration count apply. It is possible to supply
an invalid iteration count, which will lead to an sql error.

/Requires/ the pgcrypto module.

-}
data HashAlgorithm
    = BF (Maybe Word)
    | MD5
    | XDES (Maybe Word)
    | DES
  deriving (HashAlgorithm -> HashAlgorithm -> Bool
(HashAlgorithm -> HashAlgorithm -> Bool)
-> (HashAlgorithm -> HashAlgorithm -> Bool) -> Eq HashAlgorithm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HashAlgorithm -> HashAlgorithm -> Bool
$c/= :: HashAlgorithm -> HashAlgorithm -> Bool
== :: HashAlgorithm -> HashAlgorithm -> Bool
$c== :: HashAlgorithm -> HashAlgorithm -> Bool
Eq, Int -> HashAlgorithm -> ShowS
[HashAlgorithm] -> ShowS
HashAlgorithm -> String
(Int -> HashAlgorithm -> ShowS)
-> (HashAlgorithm -> String)
-> ([HashAlgorithm] -> ShowS)
-> Show HashAlgorithm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashAlgorithm] -> ShowS
$cshowList :: [HashAlgorithm] -> ShowS
show :: HashAlgorithm -> String
$cshow :: HashAlgorithm -> String
showsPrec :: Int -> HashAlgorithm -> ShowS
$cshowsPrec :: Int -> HashAlgorithm -> ShowS
Show)

{- | (@crypt()@) Calculate a crypt-like hash from the provided password

/Requires/ the pgcrypto module.

/WARNING/: Using `toCrypt` may leak sensitive data via logging. Filtering logs in production environments
when using `toCrypt`, such as using `filterLogger` on `monad-logger` based stacks is highly advised.

example:

@
share
    [mkPersist sqlSettings]
    [persistLowerCase|
    UserAccount json
        name T.Text
        UniqueName name
        passwordHash T.Text
        deriving Show Read Eq

insertSelect $ do
    pure $
        UserAccount
            <# val "username"
            <&> toCrypt (BF Nothing) "1234password"
@

-}
toCrypt :: SqlString s => HashAlgorithm -> s -> SqlExpr (Value s)
toCrypt :: HashAlgorithm -> s -> SqlExpr (Value s)
toCrypt HashAlgorithm
algorithm s
pass =
    let alg :: Builder
alg = case HashAlgorithm
algorithm of
            BF Maybe Word
mIterCount ->
                Builder
"'bf'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Maybe Word
mIterCount of
                             Maybe Word
Nothing -> Builder
forall a. Monoid a => a
mempty
                             Just Word
iterCount ->
                                Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TLB.fromString (Word -> String
forall a. Show a => a -> String
show Word
iterCount)
            HashAlgorithm
MD5 -> Builder
"'md5'"
            XDES Maybe Word
mIterCount ->
                Builder
"'xdes'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Maybe Word
mIterCount of
                             Maybe Word
Nothing -> Builder
forall a. Monoid a => a
mempty
                             Just Word
iterCount ->
                                Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TLB.fromString (Word -> String
forall a. Show a => a -> String
show Word
iterCount)
            HashAlgorithm
DES -> Builder
"'des'"
    in SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value s)
forall a.
SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr a
ERaw SqlExprMeta
noMeta ((NeedParens -> IdentInfo -> (Builder, [PersistValue]))
 -> SqlExpr (Value s))
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value s)
forall a b. (a -> b) -> a -> b
$ \NeedParens
_ IdentInfo
_ -> (Builder
"crypt (?, gen_salt(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
alg Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"))", [s -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue s
pass])

{- | (@crypt()@) Retrieve a hashed password

/Requires/ the pgcrypto module.

example:

@
share
    [mkPersist sqlSettings]
    [persistLowerCase|
    UserAccount json
        name T.Text
        UniqueName name
        passwordHash T.Text
        deriving Show Read Eq


login name pwd = select $ do
    user <- from $ Table UserAccount
    where_ $ user ^. UserAccountName ==. val name
        &&. fromCrypt (user ^. UserAccountPasswordHash) pwd
    pure user
@

-}
fromCrypt :: SqlString s => SqlExpr (Value s) -> s -> SqlExpr (Value Bool)
fromCrypt :: SqlExpr (Value s) -> s -> SqlExpr (Value Bool)
fromCrypt SqlExpr (Value s)
expr s
pass =
    SqlExpr (Value s)
expr
        SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)
forall typ.
PersistField typ =>
SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)
==. SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr (Value s)
forall a.
SqlExprMeta
-> (NeedParens -> IdentInfo -> (Builder, [PersistValue]))
-> SqlExpr a
ERaw
            SqlExprMeta
noMeta
            ( \NeedParens
_ IdentInfo
info ->
                let name :: Builder
name = SqlExpr (Value s) -> IdentInfo -> Builder
forall a. SqlExpr a -> IdentInfo -> Builder
columnName SqlExpr (Value s)
expr IdentInfo
info
                in (Builder
"crypt (?, " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")", [s -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue s
pass])
            )
  where
    columnName :: SqlExpr a -> IdentInfo -> Builder
columnName (ERaw SqlExprMeta
_ NeedParens -> IdentInfo -> (Builder, [PersistValue])
f) IdentInfo
info =
            (Builder, [PersistValue]) -> Builder
forall a b. (a, b) -> a
fst ((Builder, [PersistValue]) -> Builder)
-> (Builder, [PersistValue]) -> Builder
forall a b. (a -> b) -> a -> b
$ NeedParens -> IdentInfo -> (Builder, [PersistValue])
f NeedParens
Never IdentInfo
info