{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Web.Forma
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides a tool for validation of forms in the JSON format.
-- Sending forms in the JSON format via an AJAX request instead of
-- traditional submitting of forms has a number of advantages:
--
--     * Smoother user experience: no need to reload the whole page.
--     * Form rendering is separated and lives only in GET handler, POST (or
--       whatever method you deem appropriate for your use case) handler
--       only handles validation and effects that form submission should
--       initiate.
--     * You get a chance to organize form input the way you want.
--
-- The task of validation of a form in the JSON format may seem simple, but
-- it's not trivial to get it right. The library allows you to:
--
--     * Define a form parser using type-safe applicative notation with field
--       labels stored on the type label which guards against typos
--       and will force all your field labels be always up to date.
--     * Parse JSON 'Value' according to the definition of form you created.
--     * Stop parsing immediately if a form is malformed and cannot be
--       processed.
--     * Validate forms using any number of composable checkers that you
--       write for your specific problem domain. Once you have a vocabulary
--       of checkers, creation of new forms is just a matter of combining
--       them.
--     * Collect validation errors from multiple branches of parsing (one
--       branch per form field) in parallel, so that validation errors in
--       one branch do not prevent us from collecting validation errors from
--       other branches. This allows for better user experience as the
--       user can see all validation errors at the same time.
--     * Use 'optional' and @('<|>')@ from "Control.Applicative" in your
--       form definitions instead of ad-hoc helpers.
--     * Perform validation using several form fields at once. You choose
--       which “sub-region” of your form a given check will have access to,
--       see 'withCheck'.
--
-- You need to enable at least @DataKinds@ and @OverloadedLabels@ language
-- extensions to use this library.
--
-- __Note__: version /1.0.0/ is completely different from older versions.
module Web.Forma
  ( -- * Constructing a form
    field,
    field',
    value,
    subParser,
    withCheck,

    -- * Running a form\/inspecting result
    runForm,
    runFormPure,
    unFieldName,
    showFieldName,

    -- * Types and type functions
    FormParser,
    FormResult (..),
    FieldName,
    InSet,
  )
where

import Control.Applicative
import Control.Monad.Except
import Data.Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
import qualified Data.Aeson.Types as A
import Data.Functor.Identity (Identity (..))
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits

----------------------------------------------------------------------------
-- Types

-- | Result of parsing. @names@ is the collection of allowed field names,
-- @e@ is the type of validation errors, and @a@ is the type of parsing
-- result.
data FormResult (names :: [Symbol]) e a
  = -- | Parsing of JSON failed, this is fatal, we shut down and report the
    -- parsing error. The first component specifies the path to a
    -- problematic field and the second component is the text of error
    -- message.
    ParsingFailed (Maybe (FieldName names)) Text
  | -- | Validation of a field failed. This is also fatal but we still try
    -- to validate other branches (fields) to collect as many validation
    -- errors as possible.
    ValidationFailed (Map (FieldName names) e)
  | -- | Success, we've got a result to return.
    Succeeded a
  deriving (FormResult names e a -> FormResult names e a -> Bool
(FormResult names e a -> FormResult names e a -> Bool)
-> (FormResult names e a -> FormResult names e a -> Bool)
-> Eq (FormResult names e a)
forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormResult names e a -> FormResult names e a -> Bool
$c/= :: forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
== :: FormResult names e a -> FormResult names e a -> Bool
$c== :: forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
Eq, Int -> FormResult names e a -> ShowS
[FormResult names e a] -> ShowS
FormResult names e a -> String
(Int -> FormResult names e a -> ShowS)
-> (FormResult names e a -> String)
-> ([FormResult names e a] -> ShowS)
-> Show (FormResult names e a)
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
Int -> FormResult names e a -> ShowS
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
[FormResult names e a] -> ShowS
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
FormResult names e a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormResult names e a] -> ShowS
$cshowList :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
[FormResult names e a] -> ShowS
show :: FormResult names e a -> String
$cshow :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
FormResult names e a -> String
showsPrec :: Int -> FormResult names e a -> ShowS
$cshowsPrec :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
Int -> FormResult names e a -> ShowS
Show, a -> FormResult names e b -> FormResult names e a
(a -> b) -> FormResult names e a -> FormResult names e b
(forall a b.
 (a -> b) -> FormResult names e a -> FormResult names e b)
-> (forall a b. a -> FormResult names e b -> FormResult names e a)
-> Functor (FormResult names e)
forall (names :: [Symbol]) e a b.
a -> FormResult names e b -> FormResult names e a
forall (names :: [Symbol]) e a b.
(a -> b) -> FormResult names e a -> FormResult names e b
forall a b. a -> FormResult names e b -> FormResult names e a
forall a b.
(a -> b) -> FormResult names e a -> FormResult names e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FormResult names e b -> FormResult names e a
$c<$ :: forall (names :: [Symbol]) e a b.
a -> FormResult names e b -> FormResult names e a
fmap :: (a -> b) -> FormResult names e a -> FormResult names e b
$cfmap :: forall (names :: [Symbol]) e a b.
(a -> b) -> FormResult names e a -> FormResult names e b
Functor)

instance (ToJSON e, ToJSON a) => ToJSON (FormResult names e a) where
  toJSON :: FormResult names e a -> Value
toJSON = \case
    ParsingFailed Maybe (FieldName names)
path Text
msg ->
      Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f ((Maybe (FieldName names), Text)
-> Maybe (Maybe (FieldName names), Text)
forall a. a -> Maybe a
Just (Maybe (FieldName names)
path, Text
msg)) Maybe (Map (FieldName names) e)
forall a. Maybe a
Nothing Maybe a
forall a. Maybe a
Nothing
    ValidationFailed Map (FieldName names) e
verr ->
      Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
forall a. Maybe a
Nothing (Map (FieldName names) e -> Maybe (Map (FieldName names) e)
forall a. a -> Maybe a
Just Map (FieldName names) e
verr) Maybe a
forall a. Maybe a
Nothing
    Succeeded a
x ->
      Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
forall a. Maybe a
Nothing Maybe (Map (FieldName names) e)
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    where
      f ::
        Maybe (Maybe (FieldName names), Text) ->
        Maybe (Map (FieldName names) e) ->
        Maybe a ->
        Value
      f :: Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
perr Maybe (Map (FieldName names) e)
verr Maybe a
result =
        [Pair] -> Value
object
          [ Key
"parse_error"
              Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= case Maybe (Maybe (FieldName names), Text)
perr of
                Maybe (Maybe (FieldName names), Text)
Nothing -> Value
Null
                Just (Maybe (FieldName names)
path, Text
msg) ->
                  [Pair] -> Value
object
                    [ Key
"field" Key -> Maybe (FieldName names) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (FieldName names)
path,
                      Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg
                    ],
            Key
"field_errors"
              Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= let g :: (FieldName names, v) -> kv
g (FieldName names
fieldName, v
err) =
                       Text -> Key
Aeson.Key.fromText (FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName FieldName names
fieldName) Key -> v -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
err
                  in Value
-> (Map (FieldName names) e -> Value)
-> Maybe (Map (FieldName names) e)
-> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                       (Object -> Value
Object Object
forall v. KeyMap v
Aeson.KeyMap.empty)
                       ([Pair] -> Value
object ([Pair] -> Value)
-> (Map (FieldName names) e -> [Pair])
-> Map (FieldName names) e
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName names, e) -> Pair) -> [(FieldName names, e)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName names, e) -> Pair
forall kv v (names :: [Symbol]).
(KeyValue kv, ToJSON v) =>
(FieldName names, v) -> kv
g ([(FieldName names, e)] -> [Pair])
-> (Map (FieldName names) e -> [(FieldName names, e)])
-> Map (FieldName names) e
-> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (FieldName names) e -> [(FieldName names, e)]
forall k a. Map k a -> [(k, a)]
M.toAscList)
                       Maybe (Map (FieldName names) e)
verr,
            Key
"result" Key -> Maybe a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe a
result
          ]

instance Applicative (FormResult names e) where
  pure :: a -> FormResult names e a
pure = a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded
  (ParsingFailed Maybe (FieldName names)
l Text
msg) <*> :: FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b
<*> FormResult names e a
_ = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
  (ValidationFailed Map (FieldName names) e
_) <*> (ParsingFailed Maybe (FieldName names)
l Text
msg) = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
  (ValidationFailed Map (FieldName names) e
e0) <*> (ValidationFailed Map (FieldName names) e
e1) = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed (Map (FieldName names) e
e0 Map (FieldName names) e
-> Map (FieldName names) e -> Map (FieldName names) e
forall a. Semigroup a => a -> a -> a
<> Map (FieldName names) e
e1)
  (ValidationFailed Map (FieldName names) e
e) <*> Succeeded a
_ = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e
  Succeeded a -> b
_ <*> (ParsingFailed Maybe (FieldName names)
l Text
msg) = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
  Succeeded a -> b
_ <*> (ValidationFailed Map (FieldName names) e
e) = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e
  Succeeded a -> b
f <*> Succeeded a
x = b -> FormResult names e b
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded (a -> b
f a
x)

-- | The type represents the parser that you can run on a 'Value' with help
-- of 'runForm'. The only way for the user of the library to create a parser
-- is via the 'field' function and its friends, see below. Users can combine
-- existing parsers using applicative notation.
--
-- 'FormParser' is parametrized by four type variables:
--
--     * @names@—collection of field names we can use in a form to be parsed
--       with this parser.
--     * @e@—type of validation errors.
--     * @m@—underlying monad, 'FormParser' is not a monad itself, so it's
--       not a monad transformer, but validation can make use of the @m@
--       monad.
--     * @a@—result of parsing.
--
-- 'FormParser' is not a monad because it's not possible to write a 'Monad'
-- instance with the properties that we want (validation errors should not
-- lead to short-cutting behavior).
newtype FormParser (names :: [Symbol]) e m a = FormParser
  { FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
unFormParser ::
      Value ->
      Maybe (FieldName names) ->
      m (FormResult names e a)
  }

instance Functor m => Functor (FormParser names e m) where
  fmap :: (a -> b) -> FormParser names e m a -> FormParser names e m b
fmap a -> b
f (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) = (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e b))
 -> FormParser names e m b)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
    (FormResult names e a -> FormResult names e b)
-> m (FormResult names e a) -> m (FormResult names e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> FormResult names e a -> FormResult names e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path)

instance Applicative m => Applicative (FormParser names e m) where
  pure :: a -> FormParser names e m a
pure a
x = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
_ Maybe (FieldName names)
_ ->
    FormResult names e a -> m (FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
x)
  (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e (a -> b))
f) <*> :: FormParser names e m (a -> b)
-> FormParser names e m a -> FormParser names e m b
<*> (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) = (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e b))
 -> FormParser names e m b)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
    (FormResult names e (a -> b)
 -> FormResult names e a -> FormResult names e b)
-> m (FormResult names e (a -> b)
      -> FormResult names e a -> FormResult names e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) m (FormResult names e (a -> b)
   -> FormResult names e a -> FormResult names e b)
-> m (FormResult names e (a -> b))
-> m (FormResult names e a -> FormResult names e b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e (a -> b))
f Value
v Maybe (FieldName names)
path m (FormResult names e a -> FormResult names e b)
-> m (FormResult names e a) -> m (FormResult names e b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path

instance Applicative m => Alternative (FormParser names e m) where
  empty :: FormParser names e m a
empty = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
_ Maybe (FieldName names)
_ ->
    FormResult names e a -> m (FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
forall a. Maybe a
Nothing Text
"empty")
  (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) <|> :: FormParser names e m a
-> FormParser names e m a -> FormParser names e m a
<|> (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
y) = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
    let g :: FormResult names e a
-> FormResult names e a -> FormResult names e a
g FormResult names e a
x' FormResult names e a
y' =
          case FormResult names e a
x' of
            ParsingFailed Maybe (FieldName names)
_ Text
_ -> FormResult names e a
y'
            ValidationFailed Map (FieldName names) e
_ -> FormResult names e a
x'
            Succeeded a
_ -> FormResult names e a
x'
     in (FormResult names e a
 -> FormResult names e a -> FormResult names e a)
-> m (FormResult names e a
      -> FormResult names e a -> FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormResult names e a
-> FormResult names e a -> FormResult names e a
forall (names :: [Symbol]) e a.
FormResult names e a
-> FormResult names e a -> FormResult names e a
g m (FormResult names e a
   -> FormResult names e a -> FormResult names e a)
-> m (FormResult names e a)
-> m (FormResult names e a -> FormResult names e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path m (FormResult names e a -> FormResult names e a)
-> m (FormResult names e a) -> m (FormResult names e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
y Value
v Maybe (FieldName names)
path

-- | @'FieldName' names@ represents a non-empty vector of 'Text' components
-- that serve as a path to some field in a JSON structure. Every component
-- is guaranteed to be in the @names@, which is a set of strings on type
-- level. The purpose if this type is to avoid typos and to force users to
-- update field names everywhere when they decide to change them. The only
-- way to obtain a value of the type 'FieldName' is by using
-- @OverloadedLabels@. Note that you can combine field names using @('<>')@.
--
-- > showFieldName (#login_form <> #username) = "login_form.username"
newtype FieldName (names :: [Symbol])
  = FieldName (NonEmpty Text)
  deriving (FieldName names -> FieldName names -> Bool
(FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> Eq (FieldName names)
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldName names -> FieldName names -> Bool
$c/= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
== :: FieldName names -> FieldName names -> Bool
$c== :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
Eq, Eq (FieldName names)
Eq (FieldName names)
-> (FieldName names -> FieldName names -> Ordering)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> FieldName names)
-> (FieldName names -> FieldName names -> FieldName names)
-> Ord (FieldName names)
FieldName names -> FieldName names -> Bool
FieldName names -> FieldName names -> Ordering
FieldName names -> FieldName names -> FieldName names
forall (names :: [Symbol]). Eq (FieldName names)
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Ordering
forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
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
min :: FieldName names -> FieldName names -> FieldName names
$cmin :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
max :: FieldName names -> FieldName names -> FieldName names
$cmax :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
>= :: FieldName names -> FieldName names -> Bool
$c>= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
> :: FieldName names -> FieldName names -> Bool
$c> :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
<= :: FieldName names -> FieldName names -> Bool
$c<= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
< :: FieldName names -> FieldName names -> Bool
$c< :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
compare :: FieldName names -> FieldName names -> Ordering
$ccompare :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Ordering
$cp1Ord :: forall (names :: [Symbol]). Eq (FieldName names)
Ord, Int -> FieldName names -> ShowS
[FieldName names] -> ShowS
FieldName names -> String
(Int -> FieldName names -> ShowS)
-> (FieldName names -> String)
-> ([FieldName names] -> ShowS)
-> Show (FieldName names)
forall (names :: [Symbol]). Int -> FieldName names -> ShowS
forall (names :: [Symbol]). [FieldName names] -> ShowS
forall (names :: [Symbol]). FieldName names -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldName names] -> ShowS
$cshowList :: forall (names :: [Symbol]). [FieldName names] -> ShowS
show :: FieldName names -> String
$cshow :: forall (names :: [Symbol]). FieldName names -> String
showsPrec :: Int -> FieldName names -> ShowS
$cshowsPrec :: forall (names :: [Symbol]). Int -> FieldName names -> ShowS
Show)

instance
  (KnownSymbol name, InSet name names) =>
  IsLabel (name :: Symbol) (FieldName names)
  where
  fromLabel :: FieldName names
fromLabel =
    (NonEmpty Text -> FieldName names
forall (names :: [Symbol]). NonEmpty Text -> FieldName names
FieldName (NonEmpty Text -> FieldName names)
-> (Proxy name -> NonEmpty Text) -> Proxy name -> FieldName names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NonEmpty Text
forall a. a -> NonEmpty a
nes (Text -> NonEmpty Text)
-> (Proxy name -> Text) -> Proxy name -> NonEmpty Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Proxy name -> String) -> Proxy name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal) (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)
    where
      nes :: a -> NonEmpty a
nes a
x = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []

instance Semigroup (FieldName names) where
  FieldName NonEmpty Text
x <> :: FieldName names -> FieldName names -> FieldName names
<> FieldName NonEmpty Text
y = NonEmpty Text -> FieldName names
forall (names :: [Symbol]). NonEmpty Text -> FieldName names
FieldName (NonEmpty Text
x NonEmpty Text -> NonEmpty Text -> NonEmpty Text
forall a. Semigroup a => a -> a -> a
<> NonEmpty Text
y)

instance ToJSON (FieldName names) where
  toJSON :: FieldName names -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value)
-> (FieldName names -> Text) -> FieldName names -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName

-- | Project field path from a 'FieldName'.
unFieldName :: FieldName names -> NonEmpty Text
unFieldName :: FieldName names -> NonEmpty Text
unFieldName (FieldName NonEmpty Text
path) = NonEmpty Text
path

-- | Project textual representation of path to a field.
showFieldName :: FieldName names -> Text
showFieldName :: FieldName names -> Text
showFieldName = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text)
-> (FieldName names -> [Text]) -> FieldName names -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Text -> [Text])
-> (FieldName names -> NonEmpty Text) -> FieldName names -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName names -> NonEmpty Text
forall (names :: [Symbol]). FieldName names -> NonEmpty Text
unFieldName

-- | The type function computes a 'Constraint' which is satisfied when its
-- first argument is contained in its second argument. Otherwise a friendly
-- type error is displayed.
type family InSet (n :: Symbol) (ns :: [Symbol]) :: Constraint where
  InSet n '[] =
    TypeError
      ( 'Text "The name " ':<>: 'ShowType n ':<>: 'Text " is not in the given set."
          ':$$: 'Text "Either it's a typo or you need to add it to the set first."
      )
  InSet n (n : ns) = ()
  InSet n (m : ns) = InSet n ns

----------------------------------------------------------------------------
-- Constructing a form

-- | Construct a parser for a field. Combine multiple 'field's using
-- applicative syntax like so:
--
-- > type LoginFields = '["username", "password", "remember_me"]
-- >
-- > data LoginForm = LoginForm
-- >   { loginUsername   :: Text
-- >   , loginPassword   :: Text
-- >   , loginRememberMe :: Bool
-- >   }
-- >
-- > loginForm :: Monad m => FormParser LoginFields Text m LoginForm
-- > loginForm = LoginForm
-- >   <$> field #username notEmpty
-- >   <*> field #password notEmpty
-- >   <*> field' #remember_me
-- >
-- > notEmpty :: Monad m => Text -> ExceptT Text m Text
-- > notEmpty txt =
-- >   if T.null txt
-- >     then throwError "This field cannot be empty"
-- >     else return txt
--
-- Referring to the types in the function's signature, @s@ is extracted from
-- JSON 'Value' for you automatically using its 'FromJSON' instance. The
-- field value is taken in assumption that top level 'Value' is a
-- dictionary, and field name is a key in that dictionary. So for example a
-- valid JSON input for the form shown above could be this:
--
-- > {
-- >   "username": "Bob",
-- >   "password": "123",
-- >   "remember_me": true
-- > }
--
-- Once the value of type @s@ is extracted, the validation phase beings. The
-- supplied checker (you can easily compose them with @('>=>')@, as they are
-- Kleisli arrows) is applied to the @s@ value and validation either
-- succeeds producing an @a@ value, or we collect an error as a value of @e@
-- type.
--
-- To run a form composed from 'field's, see 'runForm'.
--
-- > field fieldName check = withCheck fieldName check (field' fieldName)
field ::
  forall (names :: [Symbol]) e m a s.
  (Monad m, FromJSON s) =>
  -- | Name of the field
  FieldName names ->
  -- | Checker that performs validation and possibly transformation of
  -- the field value
  (s -> ExceptT e m a) ->
  FormParser names e m a
field :: FieldName names -> (s -> ExceptT e m a) -> FormParser names e m a
field FieldName names
fieldName s -> ExceptT e m a
check = FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a s.
Monad m =>
FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
withCheck FieldName names
fieldName s -> ExceptT e m a
check (FieldName names -> FormParser names e m s
forall (names :: [Symbol]) e (m :: * -> *) a.
(Monad m, FromJSON a) =>
FieldName names -> FormParser names e m a
field' FieldName names
fieldName)

-- | The same as 'field', but does not require a checker.
--
-- > field' fieldName = subParser fieldName value
field' ::
  forall (names :: [Symbol]) e m a.
  (Monad m, FromJSON a) =>
  -- | Name of the field
  FieldName names ->
  FormParser names e m a
field' :: FieldName names -> FormParser names e m a
field' FieldName names
fieldName = FieldName names -> FormParser names e m a -> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
Monad m =>
FieldName names -> FormParser names e m a -> FormParser names e m a
subParser FieldName names
fieldName FormParser names e m a
forall (m :: * -> *) a (names :: [Symbol]) e.
(Monad m, FromJSON a) =>
FormParser names e m a
value

-- | Interpret the current field as a value of type @a@.
value :: (Monad m, FromJSON a) => FormParser names e m a
value :: FormParser names e m a
value = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
  case (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v of
    Left String
msg ->
      FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult names e a -> m (FormResult names e a))
-> FormResult names e a -> m (FormResult names e a)
forall a b. (a -> b) -> a -> b
$
        Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path (String -> Text
fixupAesonError String
msg)
    Right a
x -> FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
x)

-- | Use a given parser to parse a field. Suppose that you have a parser
-- @loginForm@ that parses a structure like this one:
--
-- > {
-- >   "username": "Bob",
-- >   "password": "123",
-- >   "remember_me": true
-- > }
--
-- Then @subParser #login loginForm@ will parse this:
--
-- > {
-- >   "login": {
-- >      "username": "Bob",
-- >      "password": "123",
-- >      "remember_me": true
-- >    }
-- > }
subParser ::
  forall (names :: [Symbol]) e m a.
  Monad m =>
  -- | Field name to descend to
  FieldName names ->
  -- | Subparser
  FormParser names e m a ->
  -- | Wrapped parser
  FormParser names e m a
subParser :: FieldName names -> FormParser names e m a -> FormParser names e m a
subParser FieldName names
fieldName FormParser names e m a
p = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path -> do
  let f :: Value -> Parser Value
f =
        String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
          String
"form field"
          (Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Text -> Key
Aeson.Key.fromText (FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName FieldName names
fieldName))
      path' :: Maybe (FieldName names)
path' = Maybe (FieldName names)
path Maybe (FieldName names)
-> Maybe (FieldName names) -> Maybe (FieldName names)
forall a. Semigroup a => a -> a -> a
<> FieldName names -> Maybe (FieldName names)
forall a. a -> Maybe a
Just FieldName names
fieldName
  case (Value -> Parser Value) -> Value -> Either String Value
forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither Value -> Parser Value
f Value
v of
    Left String
msg -> do
      let msg' :: Text
msg' = String -> Text
fixupAesonError String
msg
      FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path' Text
msg')
    Right Value
v' ->
      FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
forall (names :: [Symbol]) e (m :: * -> *) a.
FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
unFormParser FormParser names e m a
p Value
v' Maybe (FieldName names)
path'

-- | Transform a form by applying a checker on its result.
--
-- > passwordsMatch (a, b) = do
-- >   if a == b
-- >     then return a
-- >     else throwError "Passwords don't match!"
-- >
-- > passwordForm =
-- >   withCheck #password_confirmation passwordsMatch
-- >     ((,) <$> field #password notEmpty
-- >          <*> field #password_confirmation notEmpty)
--
-- Note that you must specify the field name on which to add a validation
-- error message in case the check fails. The field name should be relative
-- and point to a field in the argument parser, not full path from top-level
-- of the form. For example this form:
--
-- > biggerForm = subParser #password_form passwordForm
--
-- will report validation error for the field
-- @\"password_form.password_confirmation\"@ if the check fails (note that
-- @\"password_form\"@ is correctly prepended to the field path).
withCheck ::
  forall (names :: [Symbol]) e m a s.
  Monad m =>
  -- | Field to assign validation error to
  FieldName names ->
  -- | The check to perform
  (s -> ExceptT e m a) ->
  -- | Original parser
  FormParser names e m s ->
  -- | Parser with the check attached
  FormParser names e m a
withCheck :: FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
withCheck FieldName names
fieldName s -> ExceptT e m a
check (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e s)
f) = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
 -> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path -> do
  FormResult names e s
r <- Value -> Maybe (FieldName names) -> m (FormResult names e s)
f Value
v Maybe (FieldName names)
path
  case FormResult names e s
r of
    Succeeded s
x -> do
      Either e a
res <- ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (s -> ExceptT e m a
check s
x)
      FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult names e a -> m (FormResult names e a))
-> FormResult names e a -> m (FormResult names e a)
forall a b. (a -> b) -> a -> b
$ case Either e a
res of
        Left e
verr -> do
          let path' :: Maybe (FieldName names)
path' = Maybe (FieldName names)
path Maybe (FieldName names)
-> Maybe (FieldName names) -> Maybe (FieldName names)
forall a. Semigroup a => a -> a -> a
<> FieldName names -> Maybe (FieldName names)
forall a. a -> Maybe a
Just FieldName names
fieldName
          Map (FieldName names) e -> FormResult names e a
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed (FieldName names -> e -> Map (FieldName names) e
forall k a. k -> a -> Map k a
M.singleton (FieldName names -> Maybe (FieldName names) -> FieldName names
forall a. a -> Maybe a -> a
fromMaybe FieldName names
fieldName Maybe (FieldName names)
path') e
verr)
        Right a
y ->
          a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
y
    ValidationFailed Map (FieldName names) e
e ->
      FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (FieldName names) e -> FormResult names e a
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e)
    ParsingFailed Maybe (FieldName names)
path' Text
msg ->
      FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path' Text
msg)

----------------------------------------------------------------------------
-- Running a form

-- | Run a parser on given input.
runForm ::
  Monad m =>
  -- | The form parser to run
  FormParser names e m a ->
  -- | Input for the parser
  Value ->
  -- | The result of parsing
  m (FormResult names e a)
runForm :: FormParser names e m a -> Value -> m (FormResult names e a)
runForm (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
p) Value
v = Value -> Maybe (FieldName names) -> m (FormResult names e a)
p Value
v Maybe (FieldName names)
forall a. Maybe a
Nothing

-- | Run form purely.
--
-- @since 1.1.0
runFormPure ::
  -- | The form parser to run
  FormParser names e Identity a ->
  -- | Input for the parser
  Value ->
  -- | The result of parsing
  FormResult names e a
runFormPure :: FormParser names e Identity a -> Value -> FormResult names e a
runFormPure FormParser names e Identity a
p Value
v = Identity (FormResult names e a) -> FormResult names e a
forall a. Identity a -> a
runIdentity (FormParser names e Identity a
-> Value -> Identity (FormResult names e a)
forall (m :: * -> *) (names :: [Symbol]) e a.
Monad m =>
FormParser names e m a -> Value -> m (FormResult names e a)
runForm FormParser names e Identity a
p Value
v)

----------------------------------------------------------------------------
-- Helpers

-- | Fixup an error message returned by Aeson.
fixupAesonError :: String -> Text
fixupAesonError :: String -> Text
fixupAesonError String
msg = String -> Text
T.pack (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
msg))