{-# 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
Copyright   : (c) Dennis Gosnell, 2019; Felix Paulusma, 2020
License     : BSD-style (see LICENSE file)
Maintainer  : cdep.illabout@gmail.com
Stability   : experimental
Portability : POSIX

This module provides additional typeclass instances
for 'Password' and 'PasswordHash'.

See the "Data.Password.Types" module for more information.
-}

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(..))


-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XDataKinds
--
-- Import needed functions.
--
-- >>> import Data.Aeson (decode)
-- >>> import Data.Password.Bcrypt (Salt(..), hashPasswordWithSalt, unsafeShowPassword)
-- >>> import Database.Persist.Class (PersistField(toPersistValue))
-- >>> import Web.HttpApiData (parseUrlPiece)

-- | This instance allows a 'Password' to be created from a JSON blob.
--
-- >>> let maybePassword = decode "\"foobar\"" :: Maybe Password
-- >>> fmap unsafeShowPassword maybePassword
-- Just "foobar"
--
-- There is no instance for 'ToJSON' for 'Password' because we don't want to
-- accidentally encode a plain-text 'Password' to JSON and send it to the end-user.
--
-- Similarly, there is no 'ToJSON' and 'FromJSON' instance for 'PasswordHash'
-- because we don't want to accidentally send the password hash to the end
-- user.
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 ""

-- | Type error! Do not use 'toJSON' on a 'Password'!
instance TypeError (ErrMsg "JSON") => ToJSON Password where
  toJSON :: Password -> Value
toJSON = [Char] -> Password -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"

-- | This instance allows a 'Password' to be created with functions like
-- 'Web.HttpApiData.parseUrlPiece' or 'Web.HttpApiData.parseQueryParam'.
--
-- >>> let eitherPassword = parseUrlPiece "foobar"
-- >>> fmap unsafeShowPassword eitherPassword
-- Right "foobar"
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

-- | Type error! Do not transmit plain-text 'Password's over HTTP!
instance TypeError (ErrMsg "HttpApiData") => ToHttpApiData Password where
  toUrlPiece :: Password -> Text
toUrlPiece = [Char] -> Password -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"

-- | This instance allows a 'PasswordHash' to be stored as a field in a database using
-- "Database.Persist".
--
-- >>> let salt = Salt "abcdefghijklmnop"
-- >>> let pass = mkPassword "foobar"
-- >>> let hashedPassword = hashPasswordWithSalt 10 salt pass
-- >>> toPersistValue hashedPassword
-- PersistText "$2b$10$WUHhXETkX0fnYkrqZU3ta.N8Utt4U77kW4RVbchzgvBvBBEEdCD/u"
--
-- In the example above, the long 'PersistText' will be the value you store in
-- the database.
--
-- We don't provide an instance of 'PersistField' for 'Password', because we don't
-- want to make it easy to store a plain-text password in the database.
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)

-- | This instance allows a 'PasswordHash' to be stored as a field in an SQL
-- database in "Database.Persist.Sql".
deriving newtype instance PersistFieldSql (PasswordHash a)

-- | Type error! Do not store plain-text 'Password's in your database!
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"