espial-0.0.9: src/Import.hs

{-# 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 form = do
  mct <- lookupHeader "content-type"
  case fmap (B8.takeWhile (/= ';')) mct of
    Just "application/json" ->
      parseCheckJsonBody >>= \case
        A.Success a -> pure $ FormSuccess a
        A.Error e -> pure $ FormFailure [pack e]
    Just "application/x-www-form-urlencoded" ->
      runInputPostResult form
    _ -> pure FormMissing

runInputPostJSON
  :: (FromJSON a, MonadHandlerForm m)
  => FormInput m a -> m a
runInputPostJSON form =
  runInputPostJSONResult form >>=
  \case
    FormSuccess a -> pure a
    FormFailure e -> invalidArgs e
    FormMissing -> invalidArgs []

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

aFormToMaybeGetSuccess
  :: MonadHandler f
  => AForm f a -> f (Maybe a)
aFormToMaybeGetSuccess =
  fmap (maybeSuccess . fst) . runFormGet . const . fmap fst . aFormToForm

aFormToMaybePostSuccess
  :: MonadHandlerForm f
  => AForm f a -> f (Maybe a)
aFormToMaybePostSuccess =
  fmap (maybeSuccess . fst) . runFormPostNoToken . const . fmap fst . aFormToForm

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


-- FieldSettings

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

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

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

cls :: [Text] -> FieldSettings master -> FieldSettings master
cls n = attrs [("class", unwords n)]