Handler.hs

{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}

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

  , config
  , request
  , response
  , sock
  , address
  , queue

  , mkContext

  , Handler
  , ResourceHandler
  , UriHandler
  ) where

import Control.Applicative (Applicative, pure, (<*>))
import Control.Monad.State (StateT, ap)
import Data.Record.Label
import Network.Protocol.Http (Message, emptyRequest, emptyResponse)
import Network.Protocol.Uri (URI)
import Network.Salvia.Core.Config
import Network.Socket (SockAddr)
import System.IO

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

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

data Context =
  Context {
    _config   :: HttpdConfig -- ^ The HTTP server configuration.
  , _request  :: Message     -- ^ The HTTP request header.
  , _response :: Message     -- ^ The HTTP response header.
  , _sock     :: Handle      -- ^ The socket handle for the connection with the client.
  , _address  :: SockAddr    -- ^ The client addres.
  , _queue    :: SendQueue   -- ^ The queue of send actions.
  }

$(mkLabels [''Context])

queue    :: Label Context SendQueue
address  :: Label Context SockAddr
sock     :: Label Context Handle
response :: Label Context Message
request  :: Label Context Message
config   :: Label Context HttpdConfig

-- Create and empty server context.
mkContext :: HttpdConfig -> SockAddr -> Handle -> Context
mkContext 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