{-# 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 <- forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"content-type"
  case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> ByteString -> ByteString
B8.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';')) Maybe ByteString
mct of
    Just ByteString
"application/json" ->
      forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        A.Success a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> FormResult a
FormSuccess a
a
        A.Error String
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Text] -> FormResult a
FormFailure [forall seq. IsSequence seq => [Element seq] -> seq
pack String
e]
    Just ByteString
"application/x-www-form-urlencoded" ->
      forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult FormInput m a
form
    Maybe ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 =
  forall a (m :: * -> *).
(FromJSON a, MonadHandlerForm m) =>
FormInput m a -> m (FormResult a)
runInputPostJSONResult FormInput m a
form forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \case
    FormSuccess a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    FormFailure [Text]
e -> forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [Text]
e
    FormResult a
FormMissing -> 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. FormResult a -> Maybe a
maybeSuccess forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormGet forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. FormResult a -> Maybe a
maybeSuccess forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormPostNoToken forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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) = forall a. a -> Maybe a
Just a
a
maybeSuccess FormResult 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 :: Maybe Text
fsName = forall a. a -> Maybe a
Just Text
n
  , fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
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 :: [(Text, Text)]
fsAttrs = (Text, Text)
n forall a. a -> [a] -> [a]
: forall master. FieldSettings master -> [(Text, Text)]
fsAttrs FieldSettings master
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 :: [(Text, Text)]
fsAttrs = [(Text, Text)]
n forall m. Monoid m => m -> m -> m
++ forall master. FieldSettings master -> [(Text, Text)]
fsAttrs FieldSettings master
f
  }

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