Data.hs

{-# LANGUAGE TemplateHaskell #-}
module Network.Protocol.Http.Data where

import Data.List (intercalate)
import Data.Map (lookup, insert, Map, empty)
import Data.Record.Label
import Misc.Misc (safeRead, normalCase, split)
import Network.Protocol.Http.Status (Status (..))
import Network.Protocol.Uri
import Prelude hiding (lookup)

{- | List of HTTP request methods. -}

data Method =
    OPTIONS
  | GET
  | HEAD
  | POST
  | PUT
  | DELETE
  | TRACE
  | CONNECT
  deriving (Show, Eq)

{- | All `Method` constructors as a list. -}

methods :: [Method]
methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]

{- | HTTP protocol version. -}

data Version = Version {_major :: Int, _minor :: Int}

{- | Create HTTP 1.0 version. -}

http10 :: Version
http10 = Version 1 0

{- | Create HTTP 1.1 version. -}

http11 :: Version
http11 = Version 1 1

type HeaderKey   = String
type HeaderValue = String

{- | HTTP headers as mapping from keys to values. -}

type Headers     = Map HeaderKey HeaderValue

{- | Request or response specific part of HTTP messages. -}

data Direction =
    Request  {__method :: Method, __uri :: URI}
  | Response {__status :: Status}

{- | An HTTP message. -}

data Message =
  Message {
    _direction :: Direction
  , _version   :: Version
  , _headers   :: Headers
  , _body      :: String
  }

{- | Create an empty HTTP request object. -}

emptyRequest :: Message
emptyRequest = Message (Request GET (mkURI)) http11 empty ""

{- | Create an empty HTTP response object. -}

emptyResponse :: Message
emptyResponse = Message (Response OK) http11 empty ""

$(mkLabels [''Version, ''Direction, ''Message])

{- | Label to access the major part of the version. -}

major :: Label Version Int

{- | Label to access the minor part of the version. -}

minor :: Label Version Int

_status   :: Label Direction Status
_uri      :: Label Direction URI
_method   :: Label Direction Method

{- | Label to access the body part of an HTTP message. -}

body :: Label Message String

{- | Label to access the header of an HTTP message. -}

headers :: Label Message Headers

{- | Label to access the version part of an HTTP message. -}

version :: Label Message Version

{- | Label to access the direction part of an HTTP message. -}

direction :: Label Message Direction

{- | Label to access the method part of an HTTP message. -}

method :: Label Message Method
method = _method % direction

{- | Label to access the URI part of an HTTP message. -}

uri :: Label Message URI
uri = _uri % direction

{- | Label to access the status part of an HTTP message. -}

status :: Label Message Status
status = _status % direction





{- | Normalize the capitalization of an HTTP header key. -}

normalizeHeader :: String -> String
normalizeHeader = (intercalate "-") . (map normalCase) . (split '-')

{- | Generic label to access an HTTP header field by key. -}

header :: HeaderKey -> Label Message HeaderValue
header key =
  Label {
    lget = maybe "" id . lookup (normalizeHeader key) . lget headers
  , lset = lmod headers . insert (normalizeHeader key)
  }

{- | Simply /utf-8/. -}

utf8 :: String
utf8 = "utf-8"

{- | Access the /Content-Length/ header field. -}

contentLength :: (Read i, Integral i) => Label Message (Maybe i)
contentLength = comp safeRead (maybe "" show) (header "Content-Length")

{- | Access the /Connection/ header field. -}

connection :: Label Message String
connection = header "Connection"

{- | Access the /Keep-Alive/ header field. -}

keepAlive :: (Read i, Integral i) => Label Message (Maybe i)
keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")

{- | Access the /Cookie/ and /Set-Cookie/ header fields. -}

cookie :: Label Message String
cookie = Label (lget $ header "Cookie") (lset $ header "Set-Cookie")

{- | Access the /Location/ header field. -}

location :: Label Message (Maybe URI)
location = Label
  (parseURI . lget (header "Location"))
  (lset (header "Location") . maybe "" show)

{- | Access the /Content-Type/ header field. -}

contentType :: Label Message (String, Maybe String)
contentType = comp pa pr (header "Content-Type")
  where pr (t, c) = t ++ maybe "" ("; charset="++) c
        pa = error "no getter for contentType yet"

{- | Access the /Data/ header field. -}

date :: Label Message String
date = header "Date"

{- | Access the /Host/ header field. -}

hostname :: Label Message (Maybe Authority)
hostname = Label
  (parseAuthority . lget (header "Host"))
  (lset (header "Host") . maybe "" show)

{- | Access the /Server/ header field. -}

server :: Label Message String
server = header "Server"