serversession-wai-example.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad (when)
import qualified Data.Vault.Lazy as Vault
import Data.ByteString.Char8 (ByteString, pack)
import Data.ByteString.Lazy.Char8 (fromStrict)
import Data.Text (Text)

import Network.Wai
import Network.Wai.Session (Session)
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types (ok200)

import Web.ServerSession.Frontend.Wai (withServerSession)
import Web.ServerSession.Backend.Redis (RedisStorage(..))
import qualified Database.Redis as Redis

app :: Vault.Key (Session IO Text ByteString) -> Application
app session env = (>>=) $ do
  u <- sessionLookup "u"
  when (["favicon.ico"] /= pathInfo env) $
    sessionInsert "u" insertThis
  return $ responseLBS ok200 [] $ maybe "Nothing" fromStrict u
  where
  insertThis = pack . show $ pathInfo env
  Just (sessionLookup, sessionInsert) = Vault.lookup session (vault env)

main :: IO ()
main = do
  session <- Vault.newKey
  conn <- RedisStorage <$> Redis.connect Redis.defaultConnectInfo
  mid <- withServerSession session id conn
  run 3000 . mid . app $ session