Types.hs

-- |
-- Module:     Network.IHttp.Types
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  beta
--
-- Types for ihttp.

{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

module Network.IHttp.Types
    ( -- * Protocol data
      HeaderMap,
      HttpMethod(..),
      HttpVersion(..),
      Request(..),
      Response(..),

      -- * Header keys
      HeaderKey(..),
      headerKey,
      recaseHeaderKey,

      -- * Miscellaneous types
      HttpError(..)
    )
    where

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Control.Arrow
import Control.Exception as Ex
import Data.ByteString.Char8 (ByteString)
import Data.Data
import Data.Map (Map)
import Data.Monoid
import Data.String
import Text.Printf


-- TODO: Common HTTP headers with correct types.

-- data CommonHeaders =
--     CommonHeaders {
--       contentCharsetHeader :: Maybe ByteString,  -- ^ Document character set.
--       contentLengthHeader  :: Maybe Integer,     -- ^ Length of document in bytes.
--       contentTypeHeader    :: Maybe ByteString   -- ^ MIME type of document.
--     }


-- | A HTTP header key.  This is just a 'ByteString', but with
-- case-insensitive ordering and a pretty 'IsString' instance.

newtype HeaderKey = HeaderKey { getHeaderKey :: ByteString }
    deriving (Data, Monoid, Read, Typeable)

instance Eq HeaderKey where
    HeaderKey str1 == HeaderKey str2 =
        B.map wordToUpper str1 == B.map wordToUpper str2

instance IsString HeaderKey where
    fromString = HeaderKey . recaseHeaderKey . BC.pack

instance Ord HeaderKey where
    compare (HeaderKey str1) (HeaderKey str2) =
        compare (caseConvert str1) (caseConvert str2)

        where
        caseConvert :: ByteString -> ByteString
        caseConvert = B.map wordToUpper

instance Show HeaderKey where
    show = ("HeaderKey " ++) . show . getHeaderKey


-- | Map of HTTP headers.

type HeaderMap = Map HeaderKey ByteString


-- | HTTP error.

data HttpError
    -- | Non-OK response.
    = ResponseNotOkError { httpErrorResponse :: Response }

    -- | Invalid headers from client/server.
    | InvalidHeaderError { httpErrorMessage :: String }

    -- | Invalid requests from client.
    | InvalidRequestError { httpErrorMessage :: String }

    -- | Invalid responses from server.
    | InvalidResponseError { httpErrorMessage :: String }

    -- | Unsupported HTTP version.
    | UnsupportedVersionError { httpErrorMessage :: String }
    deriving (Eq, Typeable)

instance Exception HttpError

instance Show HttpError where
    show (ResponseNotOkError resp)     =
        let code = responseCode resp
            msg  = responseMessage resp
        in printf "Non-OK response: %i %s" code (BC.unpack msg)
    show (InvalidHeaderError msg)      = "Invalid HTTP header: " ++ msg
    show (InvalidRequestError msg)     = "Invalid HTTP request: " ++ msg
    show (InvalidResponseError msg)    = "Invalid HTTP response: " ++ msg
    show (UnsupportedVersionError msg) = "Unsupported HTTP version: " ++ msg


-- | HTTP request method.

data HttpMethod
    = ConnectMethod  -- ^ CONNECT
    | DeleteMethod   -- ^ DELETE
    | GetMethod      -- ^ GET
    | HeadMethod     -- ^ HEAD
    | OptionsMethod  -- ^ OPTIONS
    | PatchMethod    -- ^ PATCH
    | PostMethod     -- ^ POST
    | PutMethod      -- ^ PUT
    | TraceMethod    -- ^ TRACE
    | XMethod ByteString  -- ^ Methods this library doesn't know.
    deriving (Eq, Read, Show)


-- | HTTP protocol version.

data HttpVersion
    = Http1_0  -- ^ Version 1.0 of HTTP.
    | Http1_1  -- ^ Version 1.1 of HTTP.
    deriving (Eq, Ord, Read, Show)


-- | HTTP request line with status code.

data Request =
    Request {
      requestHeaders :: HeaderMap,   -- ^ Request headers.
      requestMethod  :: HttpMethod,  -- ^ Request method.
      requestUri     :: ByteString,  -- ^ Request URI.
      requestVersion :: HttpVersion  -- ^ HTTP version of request.
    }
    deriving (Eq, Read, Show)


-- | HTTP response line with the status code.

data Response =
    Response {
      responseCode    :: Int,         -- ^ HTTP response code.
      responseHeaders :: HeaderMap,   -- ^ Response headers.
      responseMessage :: ByteString,  -- ^ Response message.
      responseVersion :: HttpVersion  -- ^ Protocol version of response.
    }
    deriving (Eq, Read, Show)


-- | Turn a 'ByteString' with 'recaseHeaderKey' case conversion to a
-- 'HeaderKey'.

headerKey :: ByteString -> HeaderKey
headerKey = HeaderKey . recaseHeaderKey


-- | Convert an arbitrary case header key to dashed camel case
-- ("content-type" -> "Content-Type").

recaseHeaderKey :: ByteString -> ByteString
recaseHeaderKey =
    B.intercalate (BC.singleton '-') .
    map (maybe B.empty (uncurry B.cons . (wordToUpper *** B.map wordToLower)) .
         B.uncons) .
    BC.split '-'


-- | Convert upper case characters to lower case (ASCII).

wordToLower :: (Num a, Ord a) => a -> a
wordToLower c = if c >= 65 && c <= 90 then c + 32 else c


-- | Convert lower case characters to upper case (ASCII).

wordToUpper :: (Num a, Ord a) => a -> a
wordToUpper c = if c >= 97 && c <= 122 then c - 32 else c