Environment.hs

module Network.Salvia.Handler.Environment (
    hDefaultEnv
  , hSessionEnv
  ) where

import Control.Concurrent.STM
import Network.Protocol.Http
import Network.Salvia.Handler.Banner
import Network.Salvia.Handler.Counter
import Network.Salvia.Handler.Close
import Network.Salvia.Handler.Error
import Network.Salvia.Handler.Head
import Network.Salvia.Handler.Log
import Network.Salvia.Handler.Parser
import Network.Salvia.Handler.Printer
import Network.Salvia.Handler.Session
import Network.Salvia.Httpd
import System.IO

{- |
This is the default stateless handler evnironment. It takes care of request
parsing (`hParser`), response printing (`hPrinter`), request logging (`hLog`),
connection keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and
printing the `salvia-httpd` server banner (`hBanner`).
-}

hDefaultEnv
  :: Handler ()  -- ^ Handler to run in the default environment.
  -> Handler ()
hDefaultEnv handler =
  hKeepAlive $ 
    hParser (1000 * 15)
      (wrapper Nothing . parseError)
      (wrapper Nothing $ hHead handler)

{- |
This function is a more advanced version of the `hDefaultEnv` handler
environment that takes a global state into account. It takes a shared variable
containg the connection counter (used by `hCounter`) and a variable containing
all session information (used by `hSession`). Handlers that run in this
environment take should be parametrized with a session.
-}

hSessionEnv
  :: TVar Int             -- ^ Request count variable.
  -> Sessions a           -- ^ Session collection variable.
  -> SessionHandler a ()  -- ^ Handler parametrized with current session.
  -> Handler ()
hSessionEnv count sessions handler =
  hKeepAlive $ 
    hParser (1000 * 15)
     (wrapper (Just count) . parseError)
     (wrapper (Just count) $
       do session <- hSession sessions 300
          hHead (handler session))

-- Helper functions.

before :: Handler ()
before = hBanner "salvia-httpd"

after :: Maybe (TVar Int) -> Handler ()
after mc = 
  do hPrinter
     maybe
       (hLog stdout)
       (\c -> hCounter c >> hLogWithCounter c stdout)
       mc

wrapper :: Maybe (TVar Int) -> Handler a -> Handler ()
wrapper c h = before >> h >> after c

parseError :: String -> Handler ()
parseError err = 
  do hError BadRequest
     sendStrLn []
     sendStrLn err