Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement