module Network.Protocol.Http.Data where
import Control.Category
import Data.Char
import Data.List
import Data.List.Split
import Data.Record.Label
import Network.Protocol.Http.Status
import Network.Protocol.Uri
import Prelude hiding ((.), id, lookup, mod)
data Method =
OPTIONS
| GET
| HEAD
| POST
| PUT
| DELETE
| TRACE
| CONNECT
| OTHER String
deriving (Show, Eq)
data Version = Version {_major :: Int, _minor :: Int}
deriving (Eq, Ord)
type Key = String
type Value = String
newtype Headers = Headers { unHeaders :: [(Key, Value)] }
deriving Eq
data Request = Request { __method :: Method, __uri :: String }
deriving Eq
data Response = Response { __status :: Status }
deriving Eq
data Http a = Http
{ _headline :: a
, _version :: Version
, _headers :: Headers
} deriving Eq
methods :: [Method]
methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]
http10 :: Version
http10 = Version 1 0
http11 :: Version
http11 = Version 1 1
emptyHeaders :: Headers
emptyHeaders = Headers []
emptyRequest :: Http Request
emptyRequest = Http (Request GET "") http11 emptyHeaders
emptyResponse :: Http Response
emptyResponse = Http (Response OK) http11 emptyHeaders
$(mkLabels [''Version, ''Request, ''Response, ''Http])
major :: Version :-> Int
minor :: Version :-> Int
_uri :: Request :-> String
_method :: Request :-> Method
_status :: Response :-> Status
headers :: Http a :-> Headers
version :: Http a :-> Version
headline :: Http a :-> a
method :: Http Request :-> Method
method = _method . headline
uri :: Http Request :-> String
uri = _uri . headline
asUri :: Http Request :-> Uri
asUri = (toUri <-> show) `iso` uri
status :: Http Response :-> Status
status = _status . headline
normalizeHeader :: Key -> Key
normalizeHeader = intercalate "-" . map casing . splitOn "-"
where
casing "" = ""
casing (x:xs) = toUpper x : map toLower xs
header :: Key -> Http a :-> Maybe Value
header key = label
(lookup (normalizeHeader key) . unHeaders . get headers)
(\x -> mod headers (Headers . alter (normalizeHeader key) x . unHeaders))
where
alter :: Eq a => a -> Maybe b -> [(a, b)] -> [(a, b)]
alter k v [] = maybe [] (\w -> (k, w):[]) v
alter k v ((x, y):xs) | k == x = maybe xs (\w -> (k, w):xs) v
| otherwise = (x, y) : alter k v xs