{-# LANGUAGE MultiWayIf #-}

module Mensam.API.Data.User.Password where

import Control.Applicative
import Data.Aeson qualified as A
import Data.Attoparsec.Combinator qualified as P
import Data.Attoparsec.Text qualified as P
import Data.Kind
import Data.Text qualified as T
import GHC.Generics
import Servant.API

type Password :: Type
newtype Password = MkPasswordUnsafe {Password -> Text
unPassword :: T.Text}
  deriving stock (Password -> Password -> Bool
(Password -> Password -> Bool)
-> (Password -> Password -> Bool) -> Eq Password
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
/= :: Password -> Password -> Bool
Eq, (forall x. Password -> Rep Password x)
-> (forall x. Rep Password x -> Password) -> Generic Password
forall x. Rep Password x -> Password
forall x. Password -> Rep Password x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Password -> Rep Password x
from :: forall x. Password -> Rep Password x
$cto :: forall x. Rep Password x -> Password
to :: forall x. Rep Password x -> Password
Generic, Eq Password
Eq Password =>
(Password -> Password -> Ordering)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Password)
-> (Password -> Password -> Password)
-> Ord Password
Password -> Password -> Bool
Password -> Password -> Ordering
Password -> Password -> Password
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Password -> Password -> Ordering
compare :: Password -> Password -> Ordering
$c< :: Password -> Password -> Bool
< :: Password -> Password -> Bool
$c<= :: Password -> Password -> Bool
<= :: Password -> Password -> Bool
$c> :: Password -> Password -> Bool
> :: Password -> Password -> Bool
$c>= :: Password -> Password -> Bool
>= :: Password -> Password -> Bool
$cmax :: Password -> Password -> Password
max :: Password -> Password -> Password
$cmin :: Password -> Password -> Password
min :: Password -> Password -> Password
Ord)

deriving newtype instance Show Password
instance Read Password where
  readsPrec :: Int -> ReadS Password
readsPrec Int
p String
string = do
    (Text
passwordText, String
rest) <- forall a. Read a => Int -> ReadS a
readsPrec @T.Text Int
p String
string
    case Text -> Either String Password
mkPassword Text
passwordText of
      Left String
err -> ReadS Password
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
      Right Password
password -> (Password, String) -> [(Password, String)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Password
password, String
rest)

deriving newtype instance A.ToJSON Password
instance A.FromJSON Password where
  parseJSON :: Value -> Parser Password
parseJSON Value
value = do
    Text
text <- forall a. FromJSON a => Value -> Parser a
A.parseJSON @T.Text Value
value
    case Text -> Either String Password
mkPassword Text
text of
      Left String
err -> String -> Parser Password
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
      Right Password
password -> Password -> Parser Password
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Password
password

mkPassword :: T.Text -> Either String Password
mkPassword :: Text -> Either String Password
mkPassword = Parser Password -> Text -> Either String Password
forall a. Parser a -> Text -> Either String a
P.parseOnly (Parser Password -> Text -> Either String Password)
-> Parser Password -> Text -> Either String Password
forall a b. (a -> b) -> a -> b
$ do
  let
    symbol :: Parser Text Char
symbol = [Parser Text Char] -> Parser Text Char
forall (f :: * -> *) a. Alternative f => [f a] -> f a
P.choice ([Parser Text Char] -> Parser Text Char)
-> [Parser Text Char] -> Parser Text Char
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
P.char (Char -> Parser Text Char) -> String -> [Parser Text Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
passwordValidSymbols
    alphanumeric :: Parser Text Char
alphanumeric = (Parser Text Char
P.digit Parser Text Char -> Parser Text Char -> Parser Text Char
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
P.letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
symbol) Parser Text Char -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
P.<?> String
"unexpected non-alphanumeric and non-symbol character"
  String
chars <- Parser Text Char -> Parser Text () -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill Parser Text Char
alphanumeric Parser Text ()
forall t. Chunk t => Parser t ()
P.endOfInput
  if
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
32 -> String -> Parser Password
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too long"
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> String -> Parser Password
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too short"
    | Bool
otherwise -> Password -> Parser Password
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Password -> Parser Password) -> Password -> Parser Password
forall a b. (a -> b) -> a -> b
$ Text -> Password
MkPasswordUnsafe (Text -> Password) -> Text -> Password
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
chars

deriving newtype instance ToHttpApiData Password
instance FromHttpApiData Password where
  parseUrlPiece :: Text -> Either Text Password
parseUrlPiece Text
input = do
    Text
text <- forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @T.Text Text
input
    case Text -> Either String Password
mkPassword Text
text of
      Left String
err -> Text -> Either Text Password
forall a b. a -> Either a b
Left (Text -> Either Text Password) -> Text -> Either Text Password
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err
      Right Password
parsed -> Password -> Either Text Password
forall a b. b -> Either a b
Right Password
parsed

passwordValidSymbols :: [Char]
passwordValidSymbols :: String
passwordValidSymbols =
  [ Char
' '
  , Char
'~'
  , Char
'`'
  , Char
'!'
  , Char
'?'
  , Char
'@'
  , Char
'#'
  , Char
'$'
  , Char
'%'
  , Char
'^'
  , Char
'&'
  , Char
'*'
  , Char
'_'
  , Char
'-'
  , Char
'+'
  , Char
'='
  , Char
'<'
  , Char
'>'
  , Char
'('
  , Char
')'
  , Char
'{'
  , Char
'}'
  , Char
'['
  , Char
']'
  , Char
'|'
  , Char
'\''
  , Char
'"'
  , Char
','
  , Char
'.'
  , Char
':'
  , Char
';'
  , Char
'/'
  , Char
'\\'
  ]