{-# LANGUAGE MultiWayIf #-}

module Mensam.API.Data.User.Username where

import Mensam.API.Pretty

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 Username :: Type
newtype Username = MkUsernameUnsafe {Username -> Text
unUsername :: T.Text}
  deriving stock (Username -> Username -> Bool
(Username -> Username -> Bool)
-> (Username -> Username -> Bool) -> Eq Username
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Username -> Username -> Bool
== :: Username -> Username -> Bool
$c/= :: Username -> Username -> Bool
/= :: Username -> Username -> Bool
Eq, (forall x. Username -> Rep Username x)
-> (forall x. Rep Username x -> Username) -> Generic Username
forall x. Rep Username x -> Username
forall x. Username -> Rep Username x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Username -> Rep Username x
from :: forall x. Username -> Rep Username x
$cto :: forall x. Rep Username x -> Username
to :: forall x. Rep Username x -> Username
Generic, Eq Username
Eq Username =>
(Username -> Username -> Ordering)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Username)
-> (Username -> Username -> Username)
-> Ord Username
Username -> Username -> Bool
Username -> Username -> Ordering
Username -> Username -> Username
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 :: Username -> Username -> Ordering
compare :: Username -> Username -> Ordering
$c< :: Username -> Username -> Bool
< :: Username -> Username -> Bool
$c<= :: Username -> Username -> Bool
<= :: Username -> Username -> Bool
$c> :: Username -> Username -> Bool
> :: Username -> Username -> Bool
$c>= :: Username -> Username -> Bool
>= :: Username -> Username -> Bool
$cmax :: Username -> Username -> Username
max :: Username -> Username -> Username
$cmin :: Username -> Username -> Username
min :: Username -> Username -> Username
Ord)

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

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

mkUsername :: T.Text -> Either String Username
mkUsername :: Text -> Either String Username
mkUsername = Parser Username -> Text -> Either String Username
forall a. Parser a -> Text -> Either String a
P.parseOnly (Parser Username -> Text -> Either String Username)
-> Parser Username -> Text -> Either String Username
forall a b. (a -> b) -> a -> b
$ do
  let 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 -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
P.<?> String
"unexpected non-alphanumeric 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 Username
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 Username
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too short"
    | Bool
otherwise -> Username -> Parser Username
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Username -> Parser Username) -> Username -> Parser Username
forall a b. (a -> b) -> a -> b
$ Text -> Username
MkUsernameUnsafe (Text -> Username) -> Text -> Username
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
chars

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

deriving via PrettyTextViaShow T.Text instance ToPrettyText Username
deriving via PrettyHtml5ViaPrettyText Username instance ToPrettyHtml5 Username