Validation.hs

{-# LANGUAGE LambdaCase #-}

module Lib where

import Data.Char
import Data.List.NonEmpty ( NonEmpty )
import Validation

data PasswordError
  = TooShort
  | TooLong
  | MissingLowercase
  | MissingUppercase
  | MissingDigit
  | MissingSymbol
  | HasSpace
  deriving Show

newtype Password = Password { unPassword :: String } deriving Show

validatePassword :: String -> Validation (NonEmpty PasswordError) Password
validatePassword s = Password s
  <$ failureIf (length s < 8) TooShort
  <* failureIf (length s > 64) TooLong
  <* failureUnless (any isLower s) MissingLowercase
  <* failureUnless (any isUpper s) MissingUppercase
  <* failureUnless (any isDigit s) MissingDigit
  <* failureUnless (any isSymbol' s) MissingSymbol
  <* failureIf (any isSpace s) HasSpace
    where isSymbol' = (||) <$> isSymbol <*> isPunctuation

data EmailError
  = InvalidError
  deriving Show

newtype Email = Email { unEmail :: String } deriving Show

validateEmail :: String -> Validation (NonEmpty EmailError) Email
validateEmail s = Email s
  <$ failureUnless (elem '@' s) InvalidError

data UserError
  = PasswordError PasswordError
  | EmailError EmailError
  deriving Show

data User = User
  { userEmail :: Email
  , userPassword :: Password
  } deriving Show

parseUser :: String -> String -> Validation (NonEmpty UserError) User
parseUser email password = User
  <$> mapFailure (fmap EmailError) (validateEmail email)
  <*> mapFailure (fmap PasswordError) (validatePassword password)

mapFailure :: (e -> e') -> Validation e a -> Validation e' a
mapFailure f = \case
  Failure e -> Failure (f e)
  Success a -> Success a