{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Password.Instances () where
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Password.Types (Password, PasswordHash(..), mkPassword)
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ((<>))
#endif
import Data.Text (pack)
import Data.Text.Encoding as TE (decodeUtf8')
import Database.Persist (PersistValue(..))
import Database.Persist.Class (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..))
import GHC.TypeLits (TypeError, ErrorMessage(..))
import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
instance FromJSON Password where
parseJSON :: Value -> Parser Password
parseJSON = (Text -> Password) -> Parser Text -> Parser Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Password
mkPassword (Parser Text -> Parser Password)
-> (Value -> Parser Text) -> Value -> Parser Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON
type ErrMsg e = 'Text "Warning! Tried to convert plain-text Password to " ':<>: 'Text e ':<>: 'Text "!"
':$$: 'Text " This is likely a security leak. Please make sure whether this was intended."
':$$: 'Text " If this is intended, please use 'unsafeShowPassword' before converting to " ':<>: 'Text e
':$$: 'Text ""
instance TypeError (ErrMsg "JSON") => ToJSON Password where
toJSON :: Password -> Value
toJSON = [Char] -> Password -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
instance FromHttpApiData Password where
parseUrlPiece :: Text -> Either Text Password
parseUrlPiece = (Text -> Password) -> Either Text Text -> Either Text Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Password
mkPassword (Either Text Text -> Either Text Password)
-> (Text -> Either Text Text) -> Text -> Either Text Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Text
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece
instance TypeError (ErrMsg "HttpApiData") => ToHttpApiData Password where
toUrlPiece :: Password -> Text
toUrlPiece = [Char] -> Password -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
instance PersistField (PasswordHash a) where
toPersistValue :: PasswordHash a -> PersistValue
toPersistValue (PasswordHash Text
hpw) = Text -> PersistValue
PersistText Text
hpw
fromPersistValue :: PersistValue -> Either Text (PasswordHash a)
fromPersistValue = \case
PersistText Text
txt -> PasswordHash a -> Either Text (PasswordHash a)
forall a b. b -> Either a b
Right (PasswordHash a -> Either Text (PasswordHash a))
-> PasswordHash a -> Either Text (PasswordHash a)
forall a b. (a -> b) -> a -> b
$ Text -> PasswordHash a
forall a. Text -> PasswordHash a
PasswordHash Text
txt
PersistByteString ByteString
bs ->
(UnicodeException -> Either Text (PasswordHash a))
-> (Text -> Either Text (PasswordHash a))
-> Either UnicodeException Text
-> Either Text (PasswordHash a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UnicodeException -> Either Text (PasswordHash a)
forall a b. Show a => a -> Either Text b
failed (PasswordHash a -> Either Text (PasswordHash a)
forall a b. b -> Either a b
Right (PasswordHash a -> Either Text (PasswordHash a))
-> (Text -> PasswordHash a) -> Text -> Either Text (PasswordHash a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PasswordHash a
forall a. Text -> PasswordHash a
PasswordHash) (Either UnicodeException Text -> Either Text (PasswordHash a))
-> Either UnicodeException Text -> Either Text (PasswordHash a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs
PersistValue
_ -> Text -> Either Text (PasswordHash a)
forall a b. a -> Either a b
Left Text
"did not parse PasswordHash from PersistValue"
where
failed :: a -> Either Text b
failed a
e = Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
forall a b. (a -> b) -> a -> b
$ Text
"Failed decoding PasswordHash to UTF8: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
e)
deriving newtype instance PersistFieldSql (PasswordHash a)
instance TypeError (ErrMsg "PersistValue") => PersistField Password where
toPersistValue :: Password -> PersistValue
toPersistValue = [Char] -> Password -> PersistValue
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
fromPersistValue :: PersistValue -> Either Text Password
fromPersistValue = [Char] -> PersistValue -> Either Text Password
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"