espial-0.0.26: src/Import.hs

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

module Import
  ( module Import,
  )
where

import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B8
import Data.Type.Equality (type (~))
import Foundation as Import
import Import.NoFoundation as Import

-- 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)]