{-# LANGUAGE FlexibleInstances #-}

module Network.Protocol.Http(

    Status (..)
  , Method (..)
  , methods
  , Version (..)
  , Headers
  , Direction (..)
  , Message (..)

  , utf8
  , http10
  , http11
  , emptyRequest
  , emptyResponse

  , method
  , setMethod
  , uri
  , setUri
  , modUri
  , status
  , setStatus
  , setVersion
  , setBody
  , modBody
  , header
  , setHeader
  , modHeader
  , getLocation
  , getHost
  , getContentLength
  , getKeepAlive
  , getCookie
  , setContentType
  , setContentLength
  , setLocation
  , setDate
  , setServer
  , setCookie
  , normalizeHeader

  , pRequest
  , pResponse

  , showVersion
  , showHeaders
  , showMessageHeader

  , statusCodes
  , statusFailure
  , statusFromCode
  , codeFromStatus
  ) where

import Control.Applicative hiding (empty)
import Data.Char
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import qualified Data.Bimap as Bm
import qualified Data.Map as M

import Misc.Misc
import Network.Protocol.Uri (URI, mkURI, pUriReference)
import Network.Protocol.Cookie ()

-------- HTTP message data-types ----------------------------------------------

data Status =
    Continue                      | SwitchingProtocols
  | OK                            | Created
  | Accepted                      | NonAuthoritativeInformation
  | NoContent                     | ResetContent
  | PartialContent                | MultipleChoices
  | MovedPermanently              | Found
  | SeeOther                      | NotModified
  | UseProxy                      | TemporaryRedirect
  | BadRequest                    | Unauthorized
  | PaymentRequired               | Forbidden
  | NotFound                      | MethodNotAllowed
  | NotAcceptable                 | ProxyAuthenticationRequired
  | RequestTimeOut                | Conflict
  | Gone                          | LengthRequired
  | PreconditionFailed            | RequestEntityTooLarge
  | RequestURITooLarge            | UnsupportedMediaType
  | RequestedRangeNotSatisfiable  | ExpectationFailed
  | InternalServerError           | NotImplemented
  | BadGateway                    | ServiceUnavailable
  | GatewayTimeOut                | HTTPVersionNotSupported
  | CustomStatus Int
  deriving (Eq, Ord)

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

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

data Version = Version {major :: Int, minor :: Int}
type Headers = M.Map String String

data Direction =
    Request  {_method :: Method, _uri :: URI}
  | Response {_status :: Status}

data Message =
  Message {
    direction :: Direction
  , version :: Version
  , headers :: Headers
  , body :: String
  }

utf8 :: String
utf8 = "utf-8"

-------- HTTP message creation and alteration ---------------------------------

-- Create HTTP versions.
http10, http11 :: Version
http10 = Version 1 0
http11 = Version 1 1

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

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

method :: Message -> Method
method = _method . direction

setMethod :: Method -> Message -> Message
setMethod e m = m { direction = Request e (uri m) }

uri :: Message -> URI
uri = _uri . direction

setUri :: URI -> Message -> Message
setUri u m = m { direction = Request (method m) u }

modUri :: (URI -> URI) -> Message -> Message
modUri f m = setUri (f $ uri m) m

status :: Message -> Status
status = _status . direction

setStatus :: Status -> Message -> Message
setStatus s m = m { direction = Response s }

setVersion :: Version -> Message -> Message
setVersion v m = m { version = v }

setBody :: String -> Message -> Message
setBody b m = m { body = b }

modBody :: (String -> String) -> Message -> Message
modBody f m = setBody (f $ body m) m

header :: String -> Message -> String
header k = maybe "" id . M.lookup (normalizeHeader k) . headers

setHeader :: String -> String -> Message -> Message
setHeader k a (Message r v h b) = Message r v (M.insert (normalizeHeader k) a h) b

modHeader :: String -> (String -> String) -> Message -> Message
modHeader k f m = setHeader k (f $ header k m) m

getLocation :: Message -> String
getLocation = header "Location"

getHost :: Message -> String
getHost = header "Host"

getContentLength :: Message -> Maybe Int
getContentLength = intRead . header "Content-Length"

getKeepAlive :: Message -> Maybe Int
getKeepAlive = intRead . header "Keep-Alive"

getCookie :: Message -> String
getCookie = header "Cookie"

setContentType :: String -> Maybe String -> Message -> Message
setContentType t c = setHeader "Content-Type" (t ++ maybe "" ("; charset="++) c)

setContentLength :: Num a => a -> Message -> Message
setContentLength l = setHeader "Content-Length" (show l)

setLocation :: URI -> Message -> Message
setLocation l = setHeader "Location" (show l)

setDate :: String -> Message -> Message
setDate d = setHeader "Date" d

setServer :: String -> Message -> Message
setServer n  = setHeader "Server" n

setCookie :: String -> Message -> Message
setCookie c = setHeader "Set-Cookie" c

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

-------- HTTP message parsing -------------------------------------------------

-- todo: cleanup ugly code

lf, ws, ls :: String
lf = "\r\n"
ws = " \t\r\n"
ls = " \t"

pLf :: GenParser Char st Char
pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'

pVersion :: GenParser Char st Version
pVersion = 
      (\h l -> Version (ord h - ord '0') (ord l  - ord '0'))
  <$> (string "HTTP/" *> digit)
  <*> (char '.'       *> digit)

pHeaders :: GenParser Char st Headers
pHeaders = M.insert
  <$> many1 (noneOf (':':ws)) <* string ":"
  <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))
  <*> option M.empty pHeaders

pMethod :: GenParser Char st Method
pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods

pRequest :: GenParser Char st Message
pRequest = (\m u v h b -> Message (Request m u) v h b)
  <$> (pMethod <* many1 (oneOf ls))
  <*> (pUriReference <* many1 (oneOf ls))
  <*> (pVersion <* pLf)
  <*> (pHeaders <* pLf)
  <*> (many anyToken)

pResponse :: GenParser Char st Message
pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)
  <$> (pVersion <* many1 (oneOf ls))
  <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)
  <*> (pHeaders <* pLf)
  <*> (many anyToken)

-------- HTTP message pretty printing -----------------------------------------

showVersion :: Version -> String
showVersion (Version a b) = concat ["HTTP/", show a, ".", show b]

showHeaders :: Headers -> String
showHeaders =
    intercalate lf
  . M.elems
  . M.mapWithKey (\k a -> k ++ ": " ++ a)

showMessageHeader :: Message -> String
showMessageHeader (Message (Response s) v hs _) =
  concat [
    showVersion v, " "
  , maybe "Unknown status" show
  $ Bm.lookupR s statusCodes, " "
  , show s, lf
  , showHeaders hs, lf, lf
  ]
showMessageHeader (Message (Request m u) v hs _) =
  concat [show m, " ", show u, " ", showVersion v, lf, showHeaders hs, lf, lf]

instance Show Message where
  show m = concat [showMessageHeader m, body m]

-------- status code mappings -------------------------------------------------

-- rfc2616 sec6.1.1 Status Code and Reason Phrase
statusCodes :: Bm.Bimap Int Status
statusCodes = Bm.fromList [
    (100, Continue)
  , (101, SwitchingProtocols)
  , (200, OK)
  , (201, Created)
  , (202, Accepted)
  , (203, NonAuthoritativeInformation)
  , (204, NoContent)
  , (205, ResetContent)
  , (206, PartialContent)
  , (300, MultipleChoices)
  , (301, MovedPermanently)
  , (302, Found)
  , (303, SeeOther)
  , (304, NotModified)
  , (305, UseProxy)
  , (307, TemporaryRedirect)
  , (400, BadRequest)
  , (401, Unauthorized)
  , (402, PaymentRequired)
  , (403, Forbidden)
  , (404, NotFound)
  , (405, MethodNotAllowed)
  , (406, NotAcceptable)
  , (407, ProxyAuthenticationRequired)
  , (408, RequestTimeOut)
  , (409, Conflict)
  , (410, Gone)
  , (411, LengthRequired)
  , (412, PreconditionFailed)
  , (413, RequestEntityTooLarge)
  , (414, RequestURITooLarge)
  , (415, UnsupportedMediaType)
  , (416, RequestedRangeNotSatisfiable)
  , (417, ExpectationFailed)
  , (500, InternalServerError)
  , (501, NotImplemented)
  , (502, BadGateway)
  , (503, ServiceUnavailable)
  , (504, GatewayTimeOut)
  , (505, HTTPVersionNotSupported)
  ]

-- rfc2616 sec6.1.1 Status Code and Reason Phrase

instance Show Status where
  show Continue                     = "Continue"
  show SwitchingProtocols           = "Switching Protocols"
  show OK                           = "OK"
  show Created                      = "Created"
  show Accepted                     = "Accepted"
  show NonAuthoritativeInformation  = "Non-Authoritative Information"
  show NoContent                    = "No Content"
  show ResetContent                 = "Reset Content"
  show PartialContent               = "Partial Content"
  show MultipleChoices              = "Multiple Choices"
  show MovedPermanently             = "Moved Permanently"
  show Found                        = "Found"
  show SeeOther                     = "See Other"
  show NotModified                  = "Not Modified"
  show UseProxy                     = "Use Proxy"
  show TemporaryRedirect            = "Temporary Redirect"
  show BadRequest                   = "Bad Request"
  show Unauthorized                 = "Unauthorized"
  show PaymentRequired              = "Payment Required"
  show Forbidden                    = "Forbidden"
  show NotFound                     = "Not Found"
  show MethodNotAllowed             = "Method Not Allowed"
  show NotAcceptable                = "Not Acceptable"
  show ProxyAuthenticationRequired  = "Proxy Authentication Required"
  show RequestTimeOut               = "Request Time-out"
  show Conflict                     = "Conflict"
  show Gone                         = "Gone"
  show LengthRequired               = "Length Required"
  show PreconditionFailed           = "Precondition Failed"
  show RequestEntityTooLarge        = "Request Entity Too Large"
  show RequestURITooLarge           = "Request-URI Too Large"
  show UnsupportedMediaType         = "Unsupported Media Type"
  show RequestedRangeNotSatisfiable = "Requested range not satisfiable"
  show ExpectationFailed            = "Expectation Failed"
  show InternalServerError          = "Internal Server Error"
  show NotImplemented               = "Not Implemented"
  show BadGateway                   = "Bad Gateway"
  show ServiceUnavailable           = "Service Unavailable"
  show GatewayTimeOut               = "Gateway Time-out"
  show HTTPVersionNotSupported      = "HTTP Version not supported"
  show (CustomStatus _)             = "Unknown Status"

statusFailure :: Status -> Bool
statusFailure st = codeFromStatus st >= 400

statusFromCode :: Int -> Status
statusFromCode num =
    fromMaybe (CustomStatus num)
  $ Bm.lookup num statusCodes

codeFromStatus :: Status -> Int
codeFromStatus st =
    fromMaybe 0 -- total, should not happen
  $ Bm.lookupR st statusCodes