Scotty cookies example

cookies.hs

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (forM_)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Blaze.ByteString.Builder as B

import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Web.Scotty
import Web.Cookie

makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie
makeCookie n v = def { setCookieName = n, setCookieValue = v }

renderSetCookie' :: SetCookie -> Text
renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie

setCookie :: BS.ByteString -> BS.ByteString -> ActionM ()
setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v))

getCookies :: ActionM (Maybe CookiesText)
getCookies =
    fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $
        reqHeader "Cookie"
    where
        lazyToStrict = BS.concat . BSL.toChunks

renderCookiesTable :: CookiesText -> H.Html
renderCookiesTable cs =
    H.table $ do
        H.tr $ do
            H.th "name"
            H.th "value"
        forM_ cs $ \(name, val) -> do
            H.tr $ do
                H.td (H.toMarkup name)
                H.td (H.toMarkup val)

main :: IO ()
main = scotty 3000 $ do
    get "/" $ do
        cookies <- getCookies
        html $ renderHtml $ do
            case cookies of
                Just cs -> renderCookiesTable cs
                Nothing -> return ()
            H.form H.! method "post" H.! action "/set-a-cookie" $ do
                H.input H.! type_ "text" H.! name "name"
                H.input H.! type_ "text" H.! name "value"
                H.input H.! type_ "submit" H.! value "set a cookie"

    post "/set-a-cookie" $ do
        name <- param "name"
        value <- param "value"
        setCookie name value
        redirect "/"

{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}

module Lib where

import qualified Blaze.ByteString.Builder      as B
import           Control.Monad                 (forM_)
import           Control.Monad.IO.Class        (liftIO)
import           Control.Monad.Logger          (runStdoutLoggingT)
import           Control.Monad.Reader          (runReaderT)
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Lazy          as BSL
import           Data.String                   (fromString)
import           Data.Text.Lazy                (Text)
import qualified Data.Text.Lazy                as T
import qualified Data.Text.Lazy.Encoding       as T
import           Database.Persist.Postgresql
import           Database.Persist.TH           (mkMigrate, mkPersist,
                                                persistLowerCase, share,
                                                sqlSettings)
import           System.Environment            (getArgs)
import           Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Blaze.Html5              as H
import           Text.Blaze.Html5.Attributes
import           Web.Cookie
import qualified Web.Scotty                    as Scotty

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User json
    name Text
    email Text
    deriving Show Eq
|]

makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie
makeCookie n v = def { setCookieName = n, setCookieValue = v }

renderSetCookie' :: SetCookie -> Text
renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie

setCookie :: BS.ByteString -> BS.ByteString -> Scotty.ActionM ()
setCookie n v = Scotty.setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v))

getCookies :: Scotty.ActionM (Maybe CookiesText)
getCookies =
    fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $
      Scotty.header "Cookie"
  where
    lazyToStrict = BS.concat . BSL.toChunks


renderCookiesTable :: CookiesText -> H.Html
renderCookiesTable cs =
  H.table $ do
    H.tr $ do
      H.th "name"
      H.th "value"
    forM_ cs $ \(name, val) ->
      H.tr $ do
        H.td (H.toMarkup name)
        H.td (H.toMarkup val)

main :: IO ()
main = do
  args <- getArgs
  case args of
    [connStr] ->
      runStdoutLoggingT $ withPostgresqlConn (fromString connStr) $ \conn -> do
        runReaderT (runMigration migrateAll) conn

        liftIO . Scotty.scotty 3000 $ do
          Scotty.get "/" $ do
            cookies <- getCookies
            Scotty.html $ renderHtml $ do
              case cookies of
                Just cs -> renderCookiesTable cs
                Nothing -> return ()
              H.form H.! method "post" H.! action "/set-a-cookie" $ do
                H.input H.! type_ "text" H.! name "name"
                H.input H.! type_ "text" H.! name "value"
                H.input H.! type_ "submit" H.! value "set a cookie"

          Scotty.post "/set-a-cookie" $ do
            name <- Scotty.param "name"
            value <- Scotty.param "value"
            setCookie name value
            Scotty.redirect "/"

    _ -> putStrLn "Usage: lumi-postgres-server <connection string>"