Code from Success & Failure Book

Main.hs

{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE UnicodeSyntax              #-}

module Main where

import Control.Lens
import Control.Monad ((>=>))
import Data.Char (isAlphaNum, isSpace)
import Data.Coerce
import Data.Validation

main ∷ IO ()
main = do
  putStr "Please enter a username\n> "
  username ← Username <$> getLine
  putStr "Please enter a password\n> "
  password ← Password <$> getLine

  let user = mkUser @Either username password

  print user

data User = User Username Password deriving Show

newtype Error = Error [String] deriving (Semigroup, Show)

mkUser ∷ Validate v ⇒ Username → Password → v Error User
mkUser username password =
    review _Validation $ mkUserValidation username password

mkUserValidation ∷ Username → Password → Validation Error User
mkUserValidation username password = do
    username' ← validateUsername username
    password' ← validatePassword password
    return (User username' password')

newtype Username = Username String deriving (Show)
newtype Password = Password String deriving (Show)

type Rule a = a → Validation Error a

prependError ∷ String → Error → Error
prependError msg (Error errs) = Error (msg : errs)

validateUsername ∷ Username → Validation Error Username
validateUsername username =
    over _Failure
         (prependError "Username errors:")
         ((coerce checkInput ∷ Rule Username) username)

validatePassword ∷ Password → Validation Error Password
validatePassword password =
    over _Failure
         (prependError "Password errors:")
         ((coerce checkInput ∷ Rule Password) password)

checkInput ∷ String → Validation Error String
checkInput xs =
    case cleanWhitespace xs of
      Success xs' → validateLength xs' *> requireAlphaNum xs'
      err → err

checkInput' ∷ String → Validation Error String
checkInput' xs =
    case cleanWhitespace xs of
      Success cleaned → validateLength cleaned *> requireAlphaNum cleaned
      err             → err

validateLength ∷ Validate v ⇒ String → v Error String
validateLength = validate (Error ["Invalid length"]) checkLength

checkLength ∷ String → Bool
checkLength xs = length xs >= 10 && length xs <= 20

requireAlphaNum ∷ Validate v ⇒ String → v Error String
requireAlphaNum = validate (Error ["Invlid characters"]) (all isAlphaNum)

cleanWhitespace ∷ Validate v ⇒ String → v Error String
cleanWhitespace "" = review _Validation $ Failure $ Error ["Empty string"]
cleanWhitespace (x : xs) =
    if isSpace x
      then cleanWhitespace xs
      else review _Validation $ Success (x : xs)