{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Import
    ( module Import
    ) where

import Foundation            as Import
import Import.NoFoundation   as Import

import qualified Data.ByteString.Char8 as B8
import qualified Data.Aeson as A

-- Forms

type MonadHandlerForm m = (RenderMessage App FormMessage, HandlerSite m ~ App, MonadHandler m)

type Form f = Html -> MForm Handler (FormResult f, Widget)

runInputPostJSONResult
  :: (FromJSON a, MonadHandlerForm m)
  => FormInput m a -> m (FormResult a)
runInputPostJSONResult :: forall a (m :: * -> *).
(FromJSON a, MonadHandlerForm m) =>
FormInput m a -> m (FormResult a)
runInputPostJSONResult FormInput m a
form = do
  Maybe ByteString
mct <- CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"content-type"
  case (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> ByteString -> ByteString
B8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';')) Maybe ByteString
mct of
    Just ByteString
"application/json" ->
      m (Result a)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody m (Result a) -> (Result a -> m (FormResult a)) -> m (FormResult a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        A.Success a
a -> FormResult a -> m (FormResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormResult a -> m (FormResult a))
-> FormResult a -> m (FormResult a)
forall a b. (a -> b) -> a -> b
$ a -> FormResult a
forall a. a -> FormResult a
FormSuccess a
a
        A.Error String
e -> FormResult a -> m (FormResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormResult a -> m (FormResult a))
-> FormResult a -> m (FormResult a)
forall a b. (a -> b) -> a -> b
$ [Text] -> FormResult a
forall a. [Text] -> FormResult a
FormFailure [[Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack String
[Element Text]
e]
    Just ByteString
"application/x-www-form-urlencoded" ->
      FormInput m a -> m (FormResult a)
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult FormInput m a
form
    Maybe ByteString
_ -> FormResult a -> m (FormResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormResult a
forall a. FormResult a
FormMissing

runInputPostJSON
  :: (FromJSON a, MonadHandlerForm m)
  => FormInput m a -> m a
runInputPostJSON :: forall a (m :: * -> *).
(FromJSON a, MonadHandlerForm m) =>
FormInput m a -> m a
runInputPostJSON FormInput m a
form =
  FormInput m a -> m (FormResult a)
forall a (m :: * -> *).
(FromJSON a, MonadHandlerForm m) =>
FormInput m a -> m (FormResult a)
runInputPostJSONResult FormInput m a
form m (FormResult a) -> (FormResult a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \case
    FormSuccess a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    FormFailure [Text]
e -> [Text] -> m a
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [Text]
e
    FormResult a
FormMissing -> [Text] -> m a
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs []

class MkIForm a where
  mkIForm :: MonadHandlerForm m => FormInput m a

aFormToMaybeGetSuccess
  :: MonadHandler f
  => AForm f a -> f (Maybe a)
aFormToMaybeGetSuccess :: forall (f :: * -> *) a. MonadHandler f => AForm f a -> f (Maybe a)
aFormToMaybeGetSuccess =
  ((FormResult a, Enctype) -> Maybe a)
-> f (FormResult a, Enctype) -> f (Maybe a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FormResult a -> Maybe a
forall a. FormResult a -> Maybe a
maybeSuccess (FormResult a -> Maybe a)
-> ((FormResult a, Enctype) -> FormResult a)
-> (FormResult a, Enctype)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FormResult a, Enctype) -> FormResult a
forall a b. (a, b) -> a
fst) (f (FormResult a, Enctype) -> f (Maybe a))
-> (AForm f a -> f (FormResult a, Enctype))
-> AForm f a
-> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Markup -> MForm f (FormResult a)) -> f (FormResult a, Enctype)
forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormGet ((Markup -> MForm f (FormResult a)) -> f (FormResult a, Enctype))
-> (AForm f a -> Markup -> MForm f (FormResult a))
-> AForm f a
-> f (FormResult a, Enctype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MForm f (FormResult a) -> Markup -> MForm f (FormResult a)
forall a b. a -> b -> a
const (MForm f (FormResult a) -> Markup -> MForm f (FormResult a))
-> (AForm f a -> MForm f (FormResult a))
-> AForm f a
-> Markup
-> MForm f (FormResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((FormResult a,
  [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
 -> FormResult a)
-> RWST
     (Maybe (Env, FileEnv), HandlerSite f, [Text])
     Enctype
     Ints
     f
     (FormResult a,
      [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
-> MForm f (FormResult a)
forall a b.
(a -> b)
-> RWST
     (Maybe (Env, FileEnv), HandlerSite f, [Text]) Enctype Ints f a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite f, [Text]) Enctype Ints f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FormResult a,
 [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
-> FormResult a
forall a b. (a, b) -> a
fst (RWST
   (Maybe (Env, FileEnv), HandlerSite f, [Text])
   Enctype
   Ints
   f
   (FormResult a,
    [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
 -> MForm f (FormResult a))
-> (AForm f a
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite f, [Text])
         Enctype
         Ints
         f
         (FormResult a,
          [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)]))
-> AForm f a
-> MForm f (FormResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AForm f a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite f, [Text])
     Enctype
     Ints
     f
     (FormResult a,
      [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm

aFormToMaybePostSuccess
  :: MonadHandlerForm f
  => AForm f a -> f (Maybe a)
aFormToMaybePostSuccess :: forall (f :: * -> *) a.
MonadHandlerForm f =>
AForm f a -> f (Maybe a)
aFormToMaybePostSuccess =
  ((FormResult a, Enctype) -> Maybe a)
-> f (FormResult a, Enctype) -> f (Maybe a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FormResult a -> Maybe a
forall a. FormResult a -> Maybe a
maybeSuccess (FormResult a -> Maybe a)
-> ((FormResult a, Enctype) -> FormResult a)
-> (FormResult a, Enctype)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FormResult a, Enctype) -> FormResult a
forall a b. (a, b) -> a
fst) (f (FormResult a, Enctype) -> f (Maybe a))
-> (AForm f a -> f (FormResult a, Enctype))
-> AForm f a
-> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Markup -> MForm f (FormResult a)) -> f (FormResult a, Enctype)
(Markup
 -> RWST
      (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
-> f (FormResult a, Enctype)
forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormPostNoToken ((Markup
  -> RWST
       (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
 -> f (FormResult a, Enctype))
-> (AForm f a
    -> Markup
    -> RWST
         (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
-> AForm f a
-> f (FormResult a, Enctype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RWST
  (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
-> Markup
-> RWST
     (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
forall a b. a -> b -> a
const (RWST
   (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
 -> Markup
 -> RWST
      (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
-> (AForm f a
    -> RWST
         (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
-> AForm f a
-> Markup
-> RWST
     (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((FormResult a,
  [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
 -> FormResult a)
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     f
     (FormResult a,
      [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
-> RWST
     (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
forall a b.
(a -> b)
-> RWST (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f a
-> RWST (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FormResult a,
 [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
-> FormResult a
forall a b. (a, b) -> a
fst (RWST
   (Maybe (Env, FileEnv), App, [Text])
   Enctype
   Ints
   f
   (FormResult a,
    [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
 -> RWST
      (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a))
-> (AForm f a
    -> RWST
         (Maybe (Env, FileEnv), App, [Text])
         Enctype
         Ints
         f
         (FormResult a,
          [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)]))
-> AForm f a
-> RWST
     (Maybe (Env, FileEnv), App, [Text]) Enctype Ints f (FormResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AForm f a
-> MForm
     f
     (FormResult a,
      [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
AForm f a
-> RWST
     (Maybe (Env, FileEnv), App, [Text])
     Enctype
     Ints
     f
     (FormResult a,
      [FieldView (HandlerSite f)] -> [FieldView (HandlerSite f)])
forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm

maybeSuccess :: FormResult a -> Maybe a
maybeSuccess :: forall a. FormResult a -> Maybe a
maybeSuccess (FormSuccess a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
maybeSuccess FormResult a
_ = Maybe a
forall a. Maybe a
Nothing


-- FieldSettings

named :: Text -> FieldSettings master -> FieldSettings master
named :: forall master. Text -> FieldSettings master -> FieldSettings master
named Text
n FieldSettings master
f =
  FieldSettings master
f
  { fsName = Just n
  , fsId = Just n
  }

attr :: (Text,Text) -> FieldSettings master -> FieldSettings master
attr :: forall master.
(Text, Text) -> FieldSettings master -> FieldSettings master
attr (Text, Text)
n FieldSettings master
f =
  FieldSettings master
f
  { fsAttrs = n : fsAttrs f
  }

attrs :: [(Text,Text)] -> FieldSettings master -> FieldSettings master
attrs :: forall master.
[(Text, Text)] -> FieldSettings master -> FieldSettings master
attrs [(Text, Text)]
n FieldSettings master
f =
  FieldSettings master
f
  { fsAttrs = n ++ fsAttrs f
  }

cls :: [Text] -> FieldSettings master -> FieldSettings master
cls :: forall master.
[Text] -> FieldSettings master -> FieldSettings master
cls [Text]
n = [(Text, Text)] -> FieldSettings master -> FieldSettings master
forall master.
[(Text, Text)] -> FieldSettings master -> FieldSettings master
attrs [(Text
"class", [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords [Text]
n)]