{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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" module for more information.
-}

module Data.Password.Instances () where

import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Password (Password, PasswordHash(..), mkPassword)
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 (Salt(..), unsafeShowPassword)
-- >>> import Data.Password.Scrypt (defaultParams, hashPasswordWithSalt)
-- >>> 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 "abcdefghijklmnopqrstuvwxyz012345"
-- >>> let pass = mkPassword "foobar"
-- >>> let hashedPassword = hashPasswordWithSalt defaultParams salt pass
-- >>> toPersistValue hashedPassword
-- PersistText "14|8|1|YWJjZGVmZ2hpamtsbW5vcHFyc3R1dnd4eXowMTIzNDU=|nENDaqWBmPKapAqQ3//H0iBImweGjoTqn5SvBS8Mc9FPFbzq6w65maYPZaO+SPamVZRXQjARQ8Y+5rhuDhjIhw=="
--
-- 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 (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
  fromPersistValue (PersistByteString ByteString
bs) = 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 -> PasswordHash a) -> Text -> PasswordHash a
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
bs
  fromPersistValue PersistValue
_ = Text -> Either Text (PasswordHash a)
forall a b. a -> Either a b
Left Text
"did not parse PasswordHash from PersistValue"

-- | 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"