SHARE
TWEET

Untitled

a guest Oct 21st, 2019 70 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE FlexibleContexts #-}
  2. {-# LANGUAGE ExistentialQuantification #-}
  3. {-# LANGUAGE LambdaCase #-}
  4. {-# LANGUAGE GADTs #-}
  5.  
  6. -- | A restricted web type.
  7.  
  8. module Web
  9.   ( Web(..)
  10.   , runWebHandler
  11.   , ResultWithRedirect(..)
  12.   , runWebHandlerUpToRedirect
  13.   ) where
  14.  
  15. import Control.Monad
  16. import Control.Monad.IO.Class
  17. import Data.Text (Text)
  18. import Network.Wai
  19. import Yesod
  20.   (waiRequest, runInputPost, FormInput, runFormPost, generateFormPost, FormMessage, RenderMessage, Enctype, FormResult, MForm, Yesod, defaultLayout,  HandlerFor
  21.   , Html
  22.   , RedirectUrl
  23.   , WidgetFor
  24.   , YesodDB
  25.   , YesodPersist
  26.   , getYesod
  27.   , lookupSession
  28.   , redirect
  29.   , runDB
  30.   , setSession
  31.   )
  32.  
  33. -- | A restricted, explicit form of Yesod's handler monad.
  34. data Web site a where
  35.   BindW :: Web site a -> (a -> Web site b) -> Web site b
  36.   PureW :: a -> Web site a
  37.   GetYesodW :: Web site site
  38.   WaiRequestW :: Web site Request
  39.   LookupSessionW :: Text -> Web site (Maybe Text)
  40.   SetSessionW :: Text -> Text -> Web site ()
  41.   RunDBW :: YesodPersist site => YesodDB site a -> Web site a
  42.   RedirectW :: RedirectUrl site url => url -> Web site a
  43.   LiftIOW :: IO a -> Web site a
  44.   DefaultLayoutW :: WidgetFor site () -> Web site Html
  45.   GenerateFormPostW
  46.     :: (RenderMessage site FormMessage)
  47.     => (Html -> MForm (HandlerFor site) (FormResult a, xml))
  48.     -> Web site (xml, Enctype)
  49.   RunFormPostW
  50.     :: (RenderMessage site FormMessage)
  51.     => (Html -> MForm (HandlerFor site) (FormResult a, xml))
  52.     -> Web site ((FormResult a, xml), Enctype)
  53.   RunInputPostW :: FormInput (HandlerFor site) a -> Web site a
  54.  
  55. instance Monad (Web site) where
  56.   (>>=) = BindW
  57.   return = PureW
  58.  
  59. instance Applicative (Web site) where
  60.   (<*>) = ap
  61.   pure = return
  62.  
  63. instance Functor (Web site) where
  64.   fmap = liftM
  65.  
  66. instance MonadIO (Web site) where
  67.   liftIO = LiftIOW
  68.  
  69. runWebHandler :: Yesod site => Web site a -> HandlerFor site a
  70. runWebHandler m = do
  71.   result <- runWebHandlerUpToRedirect m
  72.   case result of
  73.     Redirect u -> redirect u
  74.     NoRedirect a -> pure a
  75.  
  76. data ResultWithRedirect site a
  77.   = forall url. RedirectUrl site url =>
  78.                 Redirect url
  79.   | NoRedirect a
  80.  
  81. runWebHandlerUpToRedirect ::
  82.      Yesod site => Web site a -> HandlerFor site (ResultWithRedirect site a)
  83. runWebHandlerUpToRedirect = go
  84.   where
  85.     go ::
  86.          Yesod site => Web site a -> HandlerFor site (ResultWithRedirect site a)
  87.     go =
  88.       \case
  89.         BindW m f -> do
  90.           eith <- go m
  91.           case eith of
  92.             Redirect e -> pure (Redirect e)
  93.             NoRedirect a -> go (f a)
  94.         PureW x -> pure (NoRedirect x)
  95.         GetYesodW -> fmap NoRedirect getYesod
  96.         WaiRequestW -> fmap NoRedirect waiRequest
  97.         LookupSessionW key -> fmap NoRedirect (lookupSession key)
  98.         RunDBW m -> fmap NoRedirect (runDB m)
  99.         SetSessionW key v -> fmap NoRedirect (setSession key v)
  100.         RedirectW url -> pure (Redirect url)
  101.         LiftIOW m -> fmap NoRedirect (liftIO m)
  102.         DefaultLayoutW m -> fmap NoRedirect (defaultLayout m)
  103.         GenerateFormPostW form -> fmap NoRedirect (generateFormPost form)
  104.         RunFormPostW form -> fmap NoRedirect (runFormPost form)
  105.         RunInputPostW input -> fmap NoRedirect (runInputPost input)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top