Add serversession code to Yesod+Persistent example.

Example doesn't showcase yesod-auth integration, though.

README.md

@@ -56,6 +56,11 @@ above, please send us a pull request!  The `serversession`
 package should work for any session that may be represented as a
 mapping of keys to values.
 
+Examples:
+
+  * Using Yesod frontend + Persistent backend:
+    [GitHub link](https://github.com/yesodweb/serversession/tree/master/examples/serversession-example-yesod-persistent/).
+
 
 ## Security notes
 
@@ -72,7 +77,13 @@ optimization).  The session ID can be invalidated in order to
 prevent
 [session fixation attacks](http://www.acrossecurity.com/papers/session_fixation.pdf),
 either automatically (see below) or manually (via
-`forceInvalidate`).
+`forceInvalidate`). On a session fixation attack, the attacker
+convinces the victim to use the same session ID as his and asks
+the victim to log in.  If the session is not invalidated upon
+login, the attacker will now be in possession of a session ID
+that is logged in as the victim.  If the session is invalidated,
+the victim receives a new session ID that the attacker doesn't
+have any knowledge of.
 
 We support both idle timeouts and absolute timeouts.  Idle
 timeouts invalidate the session if a given amount of time has

examples/serversession-example-yesod-persistent/Application.hs

@@ -28,6 +28,10 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 
+import qualified Data.Proxy as P
+import qualified Web.ServerSession.Core as SS
+import qualified Web.ServerSession.Backend.Persistent as SS
+
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
 import Handler.Common
@@ -38,6 +42,12 @@ import Handler.Home
 -- comments there for more details.
 mkYesodDispatch "App" resourcesApp
 
+
+-- Create migration function using both our entities and
+-- serversession-backend-persistent ones.
+mkMigrate "migrateAll" (SS.serverSessionDefs (P.Proxy :: P.Proxy SS.SessionMap) ++ entityDefs)
+
+
 -- | This function allocates resources (such as a database connection pool),
 -- performs initialization and return a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database

examples/serversession-example-yesod-persistent/Foundation.hs

@@ -4,11 +4,14 @@ import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
+import Web.ServerSession.Backend.Persistent
+import Web.ServerSession.Frontend.Yesod
 import Yesod.Auth.BrowserId (authBrowserId)
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
@@ -36,6 +39,10 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
 -- | A convenient synonym for creating forms.
 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
 
+-- | Cookie name used for the sessions of this example app.
+sessionCookieName :: Text
+sessionCookieName = "SESSION"
+
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod App where
@@ -43,11 +50,13 @@ instance Yesod App where
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
     approot = ApprootMaster $ appRoot . appSettings
 
-    -- Store session data on the client in encrypted cookies,
+    -- Store session data using server-side sessions.  Change the
-    -- default session idle timeout is 120 minutes
+    -- timeouts to small values as this is just an example (so
-    makeSessionBackend _ = Just <$> defaultClientSessionBackend
+    -- that you can wait for the idle timeout, for example).
-        120    -- timeout in minutes
+    makeSessionBackend = simpleBackend opts . SqlStorage . appConnPool
-        "config/client_session_key.aes"
+      where opts = setIdleTimeout     (Just $  5 * 60) -- 5  minutes
+                 . setAbsoluteTimeout (Just $ 20 * 60) -- 20 minutes
+                 . setCookieName      sessionCookieName
 
     defaultLayout widget = do
         master <- getYesod

examples/serversession-example-yesod-persistent/Handler/Home.hs

@@ -1,40 +1,106 @@
+-- | On this serversession example, we simply provide some ways
+-- users may interact with the session.
 module Handler.Home where
 
 import Import
-import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
+import Yesod.Form.Bootstrap3
-                              withSmallInput)
 
--- This is a handler function for the GET request method on the HomeR
+import qualified Data.Map as M
--- resource pattern. All of your resource patterns are defined in
+import qualified Web.ServerSession.Frontend.Yesod as SS
--- config/routes
+
---
+
--- The majority of the code you will write in Yesod lives in these handler
+-- | Homepage.
--- functions. You can spread them across multiple files if you are so
--- inclined, or create a single monolithic file.
 getHomeR :: Handler Html
 getHomeR = do
-    (formWidget, formEnctype) <- generateFormPost sampleForm
+  (forceFormWidget,      forceFormEnctype)      <- generateFormPost forceForm
-    let submission = Nothing :: Maybe (FileInfo, Text)
+  (sessionAddFormWidget, sessionAddFormEnctype) <- generateFormPost sessionAddForm
-        handlerName = "getHomeR" :: Text
+  msid <- getSessionId
-    defaultLayout $ do
+  vars <- M.toAscList <$> getSession
-        aDomId <- newIdent
+  defaultLayout $ do
-        setTitle "Welcome To Yesod!"
+    setTitle "Server-side session example"
-        $(widgetFile "homepage")
+    $(widgetFile "homepage")
 
-postHomeR :: Handler Html
-postHomeR = do
-    ((result, formWidget), formEnctype) <- runFormPost sampleForm
-    let handlerName = "postHomeR" :: Text
-        submission = case result of
-            FormSuccess res -> Just res
-            _ -> Nothing
 
-    defaultLayout $ do
+-- | Invalidate the session as requested via 'forceForm'.
-        aDomId <- newIdent
+postForceR :: Handler ()
-        setTitle "Welcome To Yesod!"
+postForceR =
-        $(widgetFile "homepage")
+  processForm "Force form" forceForm $ \force -> do
+    msid <- getSessionId
+    SS.forceInvalidate force
+    return $ concat
+      [ "Forced session invalidation using "
+      , show force
+      , " [old session ID was "
+      , show msid
+      , "]." ]
 
-sampleForm :: Form (FileInfo, Text)
+
-sampleForm = renderBootstrap3 BootstrapBasicForm $ (,)
+-- | Add (or modify) a session variable.
-    <$> fileAFormReq "Choose a file"
+postSessionAddR :: Handler ()
-    <*> areq textField (withSmallInput "What's on the file?") Nothing
+postSessionAddR =
+  processForm "Add session form" sessionAddForm $ \(key, val) -> do
+    setSession key val
+    return $ concat
+      [ "Set session key "
+      , show key
+      , " to value "
+      , show val
+      , "." ]
+
+
+-- | Delete a session variable.
+postSessionDeleteR :: Text -> Handler ()
+postSessionDeleteR key = do
+  deleteSession key
+  setMessage $ toHtml $ "Deleted session key " ++ show key ++ "."
+  redirect HomeR
+
+
+----------------------------------------------------------------------
+
+
+-- | Helper function for form processing handlers.
+processForm :: String -> Form a -> (a -> Handler String) -> Handler ()
+processForm formName form act = do
+  ((result, _), _) <- runFormPost form
+  (>>= setMessage . toHtml) $
+    case result of
+      FormSuccess ret  -> act ret
+      FormFailure errs -> return $ formName ++ " has errors: " ++ show errs ++ "."
+      FormMissing      -> return $ formName ++ " is missing."
+  redirect HomeR
+
+
+-- | Form for session invalidation.
+forceForm :: Form SS.ForceInvalidate
+forceForm =
+  identifyForm "forceForm" $
+  renderBootstrap3 horizontal $
+       areq (selectField optionsEnum) "Kind of invalidation" (Just SS.DoNotForceInvalidate)
+    <* submit "Force session invalidation!"
+
+
+-- | Form for adding or modifying session variables.
+sessionAddForm :: Form (Text, Text)
+sessionAddForm =
+  identifyForm "sessionAddForm" $
+  renderBootstrap3 horizontal $
+    (,)
+      <$> areq textField "Session key"   Nothing
+      <*> areq textField "Session value" Nothing
+      <*  submit "Add/modify session variable"
+
+
+-- | Our definition of horizontal form.
+horizontal :: BootstrapFormLayout
+horizontal = BootstrapHorizontalForm (ColSm 0) (ColSm 4) (ColSm 0) (ColSm 6)
+
+
+-- | Our definition of submit button.
+submit :: MonadHandler m => Text -> AForm m ()
+submit t = bootstrapSubmit (BootstrapSubmit t "btn-primary" [])
+
+
+-- | Retrieve the session ID from the cookie.
+getSessionId :: Handler (Maybe Text)
+getSessionId = lookupCookie sessionCookieName

examples/serversession-example-yesod-persistent/Model.hs

@@ -7,5 +7,5 @@ import Database.Persist.Quasi
 -- You can find more information on persistent and how to declare entities
 -- at:
 -- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkMigrate "migrateAll"]
+share [mkPersist sqlSettings, mkSave "entityDefs"]
     $(persistFileWith lowerCaseSettings "config/models")

examples/serversession-example-yesod-persistent/config/routes

@@ -4,4 +4,7 @@
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
 
-/ HomeR GET POST
+/                    HomeR          GET
+/force               ForceR             POST
+/sessionAdd          SessionAddR        POST
+/sessionDelete/#Text SessionDeleteR     POST

examples/serversession-example-yesod-persistent/serversession-example-yesod-persistent.cabal

@@ -27,7 +27,7 @@ library
         cpp-options:   -DDEVELOPMENT
         ghc-options:   -Wall -fwarn-tabs -O0
     else
-        ghc-options:   -Wall -fwarn-tabs -O2
+        ghc-options:   -Wall -fwarn-tabs -O
 
     extensions: TemplateHaskell
                 QuasiQuotes
@@ -82,6 +82,11 @@ library
                  , vector
                  , time
 
+                 , tagged
+                 , serversession                    == 1.0.*
+                 , serversession-frontend-yesod     == 1.0.*
+                 , serversession-backend-persistent == 1.0.*
+
 executable         serversession-example-yesod-persistent
     if flag(library-only)
         Buildable: False
@@ -90,7 +95,7 @@ executable         serversession-example-yesod-persistent
     hs-source-dirs:    app
     build-depends:     base, serversession-example-yesod-persistent
 
-    ghc-options:       -threaded -O2 -rtsopts -with-rtsopts=-N
+    ghc-options:       -threaded -O -rtsopts -with-rtsopts=-N
 
 test-suite test
     type:              exitcode-stdio-1.0

examples/serversession-example-yesod-persistent/templates/default-layout.hamlet

@@ -1,3 +1,3 @@
 $maybe msg <- mmsg
-  <div #message>#{msg}
+  <div .alert .alert-info #message>#{msg}
 ^{widget}

examples/serversession-example-yesod-persistent/templates/homepage.hamlet

@@ -1,41 +1,69 @@
-<h1>Welcome to Yesod!
+<h1>
+  Server-side session example
 
-<ol>
+<p>
-  <li>Now that you have a working project you should use the #
+  This example site demonstrates using #
-    \<a href="http://www.yesodweb.com/book/">Yesod book<span class="glyphicon glyphicon-book"></span></a> to learn more. #
+  <a href="https://github.com/yesodweb/serversession"><code>serversession</code></a> #
-    You can also use this scaffolded site to explore some basic concepts.
+  with Yesod and Persistent.
 
-  <li> This page was generated by the #{handlerName} handler in #
+<section>
-    \<em>Handler/Home.hs</em>.
+  <h2>
+    Current session properties
 
-  <li> The #{handlerName} handler is set to generate your site's home screen in Routes file #
+  <dl>
-    <em>config/routes
+    <dt>Session ID
+    <dd>#{maybe "-- no session --" id msid}
 
-  <li> The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
+    <dt>Session variables
-    most of them are brought together by the <em>defaultLayout</em> function which #
+    <dd>
-    is defined in the <em>Foundation.hs</em> module, and used by <em>#{handlerName}</em>. #
+      $if null vars
-    All the files for templates and wigdets are in <em>templates</em>.
+        -- no session variables --
+      $else
+        <table .table .session-vars>
+          <thead>
+            <tr>
+              <td>Key
+              <td>Value
+          <tbody>
+            $forall (key, val) <- vars
+              <tr>
+                <td>#{show key}
+                <td>#{show val}
+                <td>
+                  <form method=POST action=@{SessionDeleteR key}>
+                    <button .btn .btn-danger type=submit>
+                      Delete #
+                      <i .glyphicon .glyphicon-trash>
 
-  <li>
-    A Widget's Html, Css and Javascript are separated in three files with the #
-    \<em>.hamlet</em>, <em>.lucius</em> and <em>.julius</em> extensions.
 
-  <li ##{aDomId}>If you had javascript enabled then you wouldn't be seeing this.
+<section>
+  <h2>
+    Adding or modifying session variables
 
-  <hr />
+  <form .form-horizontal method=POST action=@{SessionAddR} enctype=#{sessionAddFormEnctype}>
-  <li #form>
+    ^{sessionAddFormWidget}
-    This is an example trivial Form. Read the #
-    \<a href="http://www.yesodweb.com/book/forms">Forms chapter<span class="glyphicon glyphicon-bookmark"></span></a> #
-    on the yesod book to learn more about them.
-    $maybe (info,con) <- submission
-      <div .message .alert .alert-success>
-        Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
-    <form method=post action=@{HomeR}#form enctype=#{formEnctype}>
-      ^{formWidget}
-      <button .btn .btn-primary type="submit">
-         Send it! <span class="glyphicon glyphicon-upload"></span>
-  <hr />
 
-  <li> And last but not least, Testing. In <em>tests/main.hs</em> you will find a #
+
-    test suite that performs tests on this page. #
+<section>
-    You can run your tests by doing: <pre>yesod test</pre>
+  <h2>
+    Forcing invalidation of the session
+
+  <p>
+    The <code>serversession</code> package supports session         #
+    invalidation destroying the current session ID and creating a   #
+    new one.  This is used to avoid session fixation attacks, where #
+    an attacker convinces a victim to use the same session ID as    #
+    his and asks the victim to log in.  If the session is not       #
+    invalidated upon login, the attacker will now be in possession  #
+    of a session ID that is logged in as the victim.  If the        #
+    session is invalidated, the victim receives a new session ID    #
+    that the attacker doesn't have any knowledge of.  Session       #
+    invalidation is also useful to logout the user from all of its  #
+    sessions after changing their password, for example.
+
+  <p>
+    Use the form below to force a session invalidation to occur.    #
+    Note that the contents of this session are not lost!
+
+  <form .form-horizontal method=POST action=@{ForceR} enctype=#{forceFormEnctype}>
+    ^{forceFormWidget}

examples/serversession-example-yesod-persistent/templates/homepage.julius

@@ -1 +1 @@
-document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
+

examples/serversession-example-yesod-persistent/templates/homepage.lucius

@@ -1,10 +1,10 @@
+body {
+    padding-top: 10px
+}
 h1 {
     text-align: center;
     margin-bottom: 30px
 }
-h2##{aDomId} {
-    color: #990
-}
 li {
     line-height: 2em;
     font-size: 16px
@@ -18,3 +18,16 @@ footer {
 .input-sm {
     margin-left: 20px
 }
+dt {
+    margin-top: 10px;
+    font-size: 16px
+}
+dd {
+    margin-left: 20px
+}
+.session-vars {
+    width: 60%;
+}
+thead {
+    font-weight: bold;
+}