Handler.hs

{-# LANGUAGE FlexibleInstances #-}

module Network.Salvia.Core.Handler (
    SendAction
  , SendQueue
  , Context (..)
  , makeContext

  , Handler
  , ResourceHandler
  , UriHandler
  , putRequest, putResponse, putQueue
  , modRequest, modResponse, modQueue
  , withRequest, withResponse
  ) where

import Control.Applicative (Applicative, pure, (<*>))
import Control.Monad.State (StateT, ap, modify, gets)
import Network.Socket (SockAddr)
import System.IO

import Network.Salvia.Core.Config
import Network.Protocol.Http (Message, emptyRequest, emptyResponse)
import Network.Protocol.Uri (URI)

-------- single request/response context --------------------------------------

type SendAction = Handle -> IO ()
type SendQueue  = [SendAction]

data Context =
  Context {
  -- | The HTTP server configuration.
    config   :: HttpdConfig
  -- | The HTTP request header.
  , request  :: Message
  -- | The HTTP response header.
  , response :: Message
  -- | The socket handle for the connection with the client.
  , sock     :: Handle
  -- | The client addres.
  , address  :: SockAddr
  -- | The queue of send actions.
  , queue    :: SendQueue
  }

-- Create and empty server context.
makeContext :: HttpdConfig -> SockAddr -> Handle -> Context
makeContext c a s = Context {
    config   = c
  , request  = emptyRequest
  , response = emptyResponse  -- 200 OK, by default.
  , sock     = s
  , address  = a
  , queue    = []
  }

-------- request handlers -----------------------------------------------------

-- HTTP handler types.
type Handler         a = StateT Context IO a
type ResourceHandler a = FilePath -> Handler a
type UriHandler      a = URI -> Handler a

-- Make handlers applicative.
instance Applicative (StateT Context IO) where
  pure  = return
  (<*>) = ap

-- Domain specific setters and modifiers.

putRequest :: Message -> Handler ()
putRequest  r = modify (\m -> m { request  = r })

modRequest :: (Message -> Message) -> Handler ()
modRequest  f = gets request  >>= putRequest  . f

putResponse :: Message -> Handler ()
putResponse r = modify (\m -> m { response = r })

modResponse :: (Message -> Message) -> Handler ()
modResponse f = gets response >>= putResponse . f

putQueue :: SendQueue -> Handler ()
putQueue    q = modify (\m -> m { queue = q })

modQueue :: (SendQueue -> SendQueue) -> Handler ()
modQueue    f = gets queue >>= putQueue . f

-- Execute handlers in a modified environment, but restore the original state.
-- This is comparable to the `local' function from the Reader monad.
withModified :: (Monad m) => m d -> (t -> m a) -> (d -> m b) -> t -> m c -> m c
withModified get m put f h =
  do { o <- get ; m f ; r <- h ; put o ; return r }

withRequest :: (Message -> Message) -> Handler a -> Handler a
withRequest = withModified (gets request) modRequest putRequest

withResponse :: (Message -> Message) -> Handler a -> Handler a
withResponse = withModified (gets response) modResponse putResponse