{-# LANGUAGE
    OverloadedStrings
  , MultiParamTypeClasses
  , FlexibleInstances
  , TypeFamilies
  , BangPatterns
#-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Web.Scotty.Trans.Form where

import Data.Text (Text)
import Ditto.Core hiding (view)
import Ditto.Lucid
import Ditto.Types
import Lucid (HtmlT, ToHtml (toHtml))
import Web.Scotty.Trans
import Ditto.Backend
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Bifunctor (first)
import Lucid.Base (ToHtml (toHtmlRaw))

instance (ScottyError e, Monad m) => Environment (ActionT e m) [Param] where
  environment :: FormId -> ActionT e m (Value [Param])
environment FormId
formId = do
    [Param]
qp <- ActionT e m [Param]
forall (m :: * -> *) e. Monad m => ActionT e m [Param]
params
    let !formId' :: Text
formId' = Text -> Text
TL.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FormId -> Text
encodeFormId FormId
formId
    case (Param -> Bool) -> [Param] -> [Param]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
x,Text
_) -> Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
formId') [Param]
qp of
      [] -> Value [Param] -> ActionT e m (Value [Param])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value [Param]
forall a. Value a
Missing
      [Param]
xs -> Value [Param] -> ActionT e m (Value [Param])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Param] -> Value [Param]
forall a. a -> Value a
Found [Param]
xs)

instance FormInput [Param] where
  type FileType [Param] = ()
  getInputStrings :: [Param] -> [String]
getInputStrings [Param]
xs = (Param -> String) -> [Param] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
TL.unpack (Text -> String) -> (Param -> Text) -> Param -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
forall a b. (a, b) -> b
snd) [Param]
xs
  getInputFile :: [Param] -> Either err (FileType [Param])
getInputFile [Param]
_ = err -> Either err ()
forall a b. a -> Either a b
Left (err -> Either err ()) -> err -> Either err ()
forall a b. (a -> b) -> a -> b
$ CommonFormError [Param] -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (CommonFormError [Param] -> err) -> CommonFormError [Param] -> err
forall a b. (a -> b) -> a -> b
$ ([Param] -> CommonFormError [Param]
forall input. input -> CommonFormError input
NoFileFound [(Text
"",Text
"No support for file uploads")] :: CommonFormError [Param])

instance FormError [Param] ScottyFormError where
  commonFormError :: CommonFormError [Param] -> ScottyFormError
commonFormError = CommonFormError [Param] -> ScottyFormError
SFECommon

-- | the error case of running a 'ScottyForm'
data ScottyFormError
  = SFECommon (CommonFormError [Param])
  | SFEUnexpectedEmpty
  | SFEUnexpectedMultiple
  | SFEParseError Text

instance ToHtml ScottyFormError where
  toHtml :: ScottyFormError -> HtmlT m ()
toHtml (SFECommon CommonFormError [Param]
ps) = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ ([Param] -> Text) -> CommonFormError [Param] -> Text
forall input. (input -> Text) -> CommonFormError input -> Text
commonFormErrorText [Param] -> Text
forall a. [(a, Text)] -> Text
encQP CommonFormError [Param]
ps
  toHtml (SFEParseError Text
t) = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t
  toHtml ScottyFormError
SFEUnexpectedEmpty = HtmlT m ()
"Unexpected empty query param list"
  toHtml ScottyFormError
SFEUnexpectedMultiple = HtmlT m ()
"Unexpected multiple query param list"
  toHtmlRaw :: ScottyFormError -> HtmlT m ()
toHtmlRaw (SFECommon CommonFormError [Param]
ps) = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ ([Param] -> Text) -> CommonFormError [Param] -> Text
forall input. (input -> Text) -> CommonFormError input -> Text
commonFormErrorText [Param] -> Text
forall a. [(a, Text)] -> Text
encQP CommonFormError [Param]
ps
  toHtmlRaw (SFEParseError Text
t) = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw Text
t
  toHtmlRaw ScottyFormError
SFEUnexpectedEmpty = HtmlT m ()
"Unexpected empty query param list"
  toHtmlRaw ScottyFormError
SFEUnexpectedMultiple = HtmlT m ()
"Unexpected multiple query param list"

encQP :: [(a, TL.Text)] -> Text
encQP :: [(a, Text)] -> Text
encQP [] = Text
""
encQP [(a, Text)]
xs = Text -> [Text] -> Text
T.intercalate Text
", " (((a, Text) -> Text) -> [(a, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
TL.toStrict (Text -> Text) -> ((a, Text) -> Text) -> (a, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Text) -> Text
forall a b. (a, b) -> b
snd) [(a, Text)]
xs)

-- | a @ditto@ formlet for @scotty@
type ScottyForm e m a = Form (ActionT e m) [Param] ScottyFormError (HtmlT (ActionT e m) ()) a

ditto :: (Monoid view, Monad m, ScottyError e)
  => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a <form> tag
  -> Text -- ^ form name prefix
  -> Form (ActionT e m) [Param] err view a -- ^ the formlet
  -> ActionT e m (Result err a, view)
ditto :: ([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
ditto [(Text, Text)] -> view -> view
toForm Text
prefix Form (ActionT e m) [Param] err view a
formlet = do
  ([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
forall (m :: * -> *) e view err a.
(Monad m, ScottyError e) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
dittoSingle [(Text, Text)] -> view -> view
toForm' Text
prefix Form (ActionT e m) [Param] err view a
formlet
  where
  toForm' :: [(Text, Text)] -> view -> view
toForm' [(Text, Text)]
hidden view
view = [(Text, Text)] -> view -> view
toForm ((Text
"formname", Text
prefix) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
hidden) view
view

-- | a helpful wrapper around 'runForm'
dittoSingle
  :: (Monad m, ScottyError e)
  => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a <form> tag
  -> Text -- ^ form name prefix
  -> Form (ActionT e m) [Param] err view a -- ^ the formlet
  -> ActionT e m (Result err a, view)
dittoSingle :: ([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
dittoSingle [(Text, Text)] -> view -> view
toForm Text
prefix Form (ActionT e m) [Param] err view a
formlet = do
  (View [(FormRange, err)] -> view
viewf, Result err (Proved a)
res) <- Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Monad m =>
Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
prefix Form (ActionT e m) [Param] err view a
formlet
  case Result err (Proved a)
res of
    Error [(FormRange, err)]
errs -> (Result err a, view) -> ActionT e m (Result err a, view)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(FormRange, err)] -> Result err a
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormRange, err)]
errs, [(Text, Text)] -> view -> view
toForm [] (view -> view) -> view -> view
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)] -> view
viewf [(FormRange, err)]
errs)
    Ok (Proved FormRange
_ a
unProved') -> (Result err a, view) -> ActionT e m (Result err a, view)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Result err a
forall e ok. ok -> Result e ok
Ok a
unProved', [(Text, Text)] -> view -> view
toForm [] (view -> view) -> view -> view
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)] -> view
viewf [])

-- | create @\<form action=action method=\"GET\" enctype=\"application/xxx-form-urlencoded\"\>@
simpleDittoGET :: (Applicative f, Monad m, ScottyError e)
  => Text -- ^ action
  -> Form (ActionT e m) [Param] err (HtmlT f ()) b -- ^ formlet
  -> ActionT e m (Result err b, HtmlT f ())
simpleDittoGET :: Text
-> Form (ActionT e m) [Param] err (HtmlT f ()) b
-> ActionT e m (Result err b, HtmlT f ())
simpleDittoGET Text
action Form (ActionT e m) [Param] err (HtmlT f ()) b
form = ([(Text, Text)] -> HtmlT f () -> HtmlT f ())
-> Text
-> Form (ActionT e m) [Param] err (HtmlT f ()) b
-> ActionT e m (Result err b, HtmlT f ())
forall view (m :: * -> *) e err a.
(Monoid view, Monad m, ScottyError e) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
ditto (Text -> [(Text, Text)] -> HtmlT f () -> HtmlT f ()
forall (m :: * -> *) b.
Applicative m =>
Text -> [(Text, Text)] -> HtmlT m b -> HtmlT m b
formGenGET Text
action) Text
"ditto" Form (ActionT e m) [Param] err (HtmlT f ()) b
form

-- | create @\<form action=action method=\"POST\" enctype=\"application/xxx-form-urlencoded\"\>@
simpleDittoPOST :: (Applicative f, Monad m, ScottyError e)
  => Text -- ^ action
  -> Form (ActionT e m) [Param] err (HtmlT f ()) b -- ^ formlet
  -> ActionT e m (Result err b, HtmlT f ())
simpleDittoPOST :: Text
-> Form (ActionT e m) [Param] err (HtmlT f ()) b
-> ActionT e m (Result err b, HtmlT f ())
simpleDittoPOST Text
action Form (ActionT e m) [Param] err (HtmlT f ()) b
form = ([(Text, Text)] -> HtmlT f () -> HtmlT f ())
-> Text
-> Form (ActionT e m) [Param] err (HtmlT f ()) b
-> ActionT e m (Result err b, HtmlT f ())
forall view (m :: * -> *) e err a.
(Monoid view, Monad m, ScottyError e) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form (ActionT e m) [Param] err view a
-> ActionT e m (Result err a, view)
ditto (Text -> [(Text, Text)] -> HtmlT f () -> HtmlT f ()
forall (m :: * -> *) b.
Applicative m =>
Text -> [(Text, Text)] -> HtmlT m b -> HtmlT m b
formGenPOST Text
action) Text
"ditto" Form (ActionT e m) [Param] err (HtmlT f ()) b
form

-- | lift a function which parses strict @Text@ into a function which parses a @[Param]@
liftParser' :: (Text -> Either Text a) -> ([Param] -> Either ScottyFormError a)
liftParser' :: (Text -> Either Text a) -> [Param] -> Either ScottyFormError a
liftParser' Text -> Either Text a
f [(Text
_,Text
x)] = (Text -> ScottyFormError)
-> Either Text a -> Either ScottyFormError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ScottyFormError
SFEParseError (Either Text a -> Either ScottyFormError a)
-> Either Text a -> Either ScottyFormError a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
f (Text -> Text
TL.toStrict Text
x)
liftParser' Text -> Either Text a
_ [] = ScottyFormError -> Either ScottyFormError a
forall a b. a -> Either a b
Left ScottyFormError
SFEUnexpectedEmpty
liftParser' Text -> Either Text a
_ [Param]
_ = ScottyFormError -> Either ScottyFormError a
forall a b. a -> Either a b
Left ScottyFormError
SFEUnexpectedMultiple

-- | lift a function which parses lazy @Text@ into a function which parses a @[Param]@
-- e.g.
--
-- @
-- parserRead :: Read a => [Param] -> Either ScottyFormError a
-- parserRead = liftParser readEither
-- @
liftParser :: (TL.Text -> Either TL.Text a) -> ([Param] -> Either ScottyFormError a)
liftParser :: (Text -> Either Text a) -> [Param] -> Either ScottyFormError a
liftParser Text -> Either Text a
f [(Text
_,Text
x)] = (Text -> ScottyFormError)
-> Either Text a -> Either ScottyFormError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ScottyFormError
SFEParseError (Text -> ScottyFormError)
-> (Text -> Text) -> Text -> ScottyFormError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict) (Either Text a -> Either ScottyFormError a)
-> Either Text a -> Either ScottyFormError a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
f Text
x
liftParser Text -> Either Text a
_ [] = ScottyFormError -> Either ScottyFormError a
forall a b. a -> Either a b
Left ScottyFormError
SFEUnexpectedEmpty
liftParser Text -> Either Text a
_ [Param]
_ = ScottyFormError -> Either ScottyFormError a
forall a b. a -> Either a b
Left ScottyFormError
SFEUnexpectedMultiple