Semiring Validation example

Main.purs

module Main where

import Prelude
import Control.Alt ((<|>))
import Control.Apply (lift2)
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.Reader as Reader
import Data.Array as Array
import Data.Maybe (Maybe(..))
import Data.Maybe as Maybe
import Data.Semiring.Free (Free(..))
import Data.Semiring.Free as Free
import Data.String as String
import Data.String.Regex as Regex
import Data.String.Regex.Unsafe as Regex.Unsafe
import Data.Validation.Semiring (V)
import Data.Validation.Semiring as V
import Effect (Effect)
import Effect.Exception as Exception
import React.Basic.DOM as R
import React.Basic.DOM.Events as DOM.Events
import React.Basic.Events as Events
import React.Basic.Hooks (Component, (/\))
import React.Basic.Hooks as React
import Web.HTML as HTML
import Web.HTML.HTMLDocument as HTMLDocument
import Web.HTML.HTMLElement as HTMLElement
import Web.HTML.Window as Window

main :: Effect Unit
main = do
  maybeBody <- HTMLDocument.body =<< Window.document =<< HTML.window
  case maybeBody of
    Nothing -> Exception.throw "Could not find body."
    Just body -> do
      app <- mkApp
      R.render (app unit) (HTMLElement.toElement body)

mkApp :: Component Unit
mkApp = do
  React.component "App" \_ -> React.do
    value /\ setValue <- React.useState' ""
    pure
      ( R.div_
          [ R.input
              { onChange:
                  Events.handler DOM.Events.targetValue \targetValue -> do
                    setValue (Maybe.fromMaybe "" targetValue)
              , value
              }
          , R.div_
              [ R.p_
                  [ R.text "Output of "
                  , R.code_ [ R.text "validate" ]
                  , R.pre_
                      [ R.text (toString (Reader.runReaderT validate value)) ]
                  ]
              ]
          , R.div_
              [ R.p_
                  [ R.text "Output of "
                  , R.code_ [ R.text "validate'" ]
                  , R.pre_
                      [ R.text (toString (Reader.runReaderT validate' value)) ]
                  ]
              ]
          ]
      )

validate :: Validator String
validate =
  ( -- | This is saying "A password is valid if it has *both* mixed case AND it
    -- | contains a number ...
    hasMixedCase
      <* hasNumber
      -- | ... OR it's valid if it's between 4 & 8 characters long"
      <|> hasLengthBetween 4 8
  )
    -- | This special-character requirement is "multiplied" across both branches (this
    -- | is effectively the same as "adding" this requirement to each path individually)
    <* hasSpecialChar

validate' :: Validator String
validate' =
  ( -- | This says "A password is valid if it has mixed case ...
    hasMixedCase
      -- | ... OR it can be valid if it has a number and length between 4 & 8 characters ...
      <|> hasNumber
      <* hasLengthBetween 4 8
  )
    -- | ... OR it can just contain a special character"
    <|> hasSpecialChar

toString :: V (Free String) String -> String
toString =
  V.unV
    ( ("Password must " <> _)
        <<< String.joinWith "\nOR "
        <<< map (String.joinWith "\nAND ")
        <<< \(Free as) ->
            Array.fromFoldable
              (map Array.fromFoldable as)
    )
    ("Success: " <> _)

type Validator
  = ReaderT String (V (Free String))

hasMixedCase :: Validator String
hasMixedCase =
  fromPredicate
    ( lift2 (&&)
        (Regex.test (Regex.Unsafe.unsafeRegex "[A-Z]" mempty))
        (Regex.test (Regex.Unsafe.unsafeRegex "[a-z]" mempty))
    )
    "contain upper & lower-case letters"

hasNumber :: Validator String
hasNumber =
  fromPredicate
    (Regex.test (Regex.Unsafe.unsafeRegex "\\d" mempty))
    "contain a number"

hasLengthBetween :: Int -> Int -> Validator String
hasLengthBetween n m =
  fromPredicate
    (\x -> String.length x >= n && String.length x <= m)
    ("be between " <> show n <> "—" <> show m <> " characters long")

hasSpecialChar :: Validator String
hasSpecialChar =
  fromPredicate
    (Regex.test (Regex.Unsafe.unsafeRegex "[^A-Za-z0-9]" mempty))
    "contain a special character"

fromPredicate :: (String -> Boolean) -> String -> Validator String
fromPredicate p err =
  ReaderT \s ->
    if p s then
      pure s
    else
      V.invalid (Free.free err)