Created
March 20, 2012 16:29
-
-
Save MgaMPKAy/2137934 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} | |
| {-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} | |
| import Yesod | |
| import Control.Applicative ((<$>), (<*>)) | |
| data SessionExample = SessionExample | |
| mkYesod "SessionExample" [parseRoutes| | |
| / Root GET POST | |
| |] | |
| getRoot :: Handler RepHtml | |
| getRoot = do | |
| sess <- getSession | |
| hamletToRepHtml [hamlet| | |
| <form method=post> | |
| <input type=text name=key> | |
| <input type=text name=val> | |
| <input type=submit> | |
| <h1>#{show sess} | |
| |] | |
| postRoot :: Handler RepHtml | |
| postRoot = do | |
| (key, mval) <- runInputPost $ (,) <$> ireq textField "key" <*> iopt textField "val" | |
| case mval of | |
| Nothing -> deleteSession key | |
| Just val -> setSession key val | |
| liftIO $ print (key, mval) | |
| redirect Root | |
| instance Yesod SessionExample where | |
| clientSessionDuration _ = 1 | |
| instance RenderMessage SessionExample FormMessage where | |
| renderMessage _ _ = defaultFormMessage | |
| main :: IO () | |
| main = warpDebug 3000 SessionExample |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} | |
| {-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} | |
| import Yesod | |
| data Messages = Messages | |
| mkYesod "Messages" [parseRoutes| | |
| / RootR GET | |
| /set-message SetMessageR POST | |
| |] | |
| instance Yesod Messages where | |
| defaultLayout widget = do | |
| pc <- widgetToPageContent widget | |
| mmsg <- getMessage | |
| hamletToRepHtml [hamlet| | |
| $doctype 5 | |
| <html> | |
| <head> | |
| <title>#{pageTitle pc} | |
| ^{pageHead pc} | |
| <body> | |
| $maybe msg <- mmsg | |
| <p>Your message was: #{msg} | |
| ^{pageBody pc} | |
| |] | |
| instance RenderMessage Messages FormMessage where | |
| renderMessage _ _ = defaultFormMessage | |
| getRootR :: Handler RepHtml | |
| getRootR = defaultLayout [whamlet| | |
| <form method=post action=@{SetMessageR}> | |
| My message is:# | |
| <input type=text name=message> | |
| <input type=submit> | |
| |] | |
| postSetMessageR :: Handler () | |
| postSetMessageR = do | |
| msg <- runInputPost $ ireq textField "message" | |
| setMessage $ toHtml msg | |
| redirect RootR | |
| main :: IO () | |
| main = warpDebug 3000 Messages |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment