Web yesod wrapper

Web.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}

-- | A restricted web type.

module Web
  ( Web(..)
  , runWebHandler
  , ResultWithRedirect(..)
  , runWebHandlerUpToRedirect
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Data.Text (Text)
import Network.Wai
import Yesod
  (waiRequest, runInputPost, FormInput, runFormPost, generateFormPost, FormMessage, RenderMessage, Enctype, FormResult, MForm, Yesod, defaultLayout,  HandlerFor
  , Html
  , RedirectUrl
  , WidgetFor
  , YesodDB
  , YesodPersist
  , getYesod
  , lookupSession
  , redirect
  , runDB
  , setSession
  )

-- | A restricted, explicit form of Yesod's handler monad.
data Web site a where
  BindW :: Web site a -> (a -> Web site b) -> Web site b
  PureW :: a -> Web site a
  GetYesodW :: Web site site
  WaiRequestW :: Web site Request
  LookupSessionW :: Text -> Web site (Maybe Text)
  SetSessionW :: Text -> Text -> Web site ()
  RunDBW :: YesodPersist site => YesodDB site a -> Web site a
  RedirectW :: RedirectUrl site url => url -> Web site a
  LiftIOW :: IO a -> Web site a
  DefaultLayoutW :: WidgetFor site () -> Web site Html
  GenerateFormPostW
    :: (RenderMessage site FormMessage)
    => (Html -> MForm (HandlerFor site) (FormResult a, xml))
    -> Web site (xml, Enctype)
  RunFormPostW
    :: (RenderMessage site FormMessage)
    => (Html -> MForm (HandlerFor site) (FormResult a, xml))
    -> Web site ((FormResult a, xml), Enctype)
  RunInputPostW :: FormInput (HandlerFor site) a -> Web site a

instance Monad (Web site) where
  (>>=) = BindW
  return = PureW

instance Applicative (Web site) where
  (<*>) = ap
  pure = return

instance Functor (Web site) where
  fmap = liftM

instance MonadIO (Web site) where
  liftIO = LiftIOW

runWebHandler :: Yesod site => Web site a -> HandlerFor site a
runWebHandler m = do
  result <- runWebHandlerUpToRedirect m
  case result of
    Redirect u -> redirect u
    NoRedirect a -> pure a

data ResultWithRedirect site a
  = forall url. RedirectUrl site url =>
                Redirect url
  | NoRedirect a

runWebHandlerUpToRedirect ::
     Yesod site => Web site a -> HandlerFor site (ResultWithRedirect site a)
runWebHandlerUpToRedirect = go
  where
    go ::
         Yesod site => Web site a -> HandlerFor site (ResultWithRedirect site a)
    go =
      \case
        BindW m f -> do
          eith <- go m
          case eith of
            Redirect e -> pure (Redirect e)
            NoRedirect a -> go (f a)
        PureW x -> pure (NoRedirect x)
        GetYesodW -> fmap NoRedirect getYesod
        WaiRequestW -> fmap NoRedirect waiRequest
        LookupSessionW key -> fmap NoRedirect (lookupSession key)
        RunDBW m -> fmap NoRedirect (runDB m)
        SetSessionW key v -> fmap NoRedirect (setSession key v)
        RedirectW url -> pure (Redirect url)
        LiftIOW m -> fmap NoRedirect (liftIO m)
        DefaultLayoutW m -> fmap NoRedirect (defaultLayout m)
        GenerateFormPostW form -> fmap NoRedirect (generateFormPost form)
        RunFormPostW form -> fmap NoRedirect (runFormPost form)
        RunInputPostW input -> fmap NoRedirect (runInputPost input)