{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}

module Network.Protocol.Http(

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

  , major
  , minor
  , method
  , uri
  , status
  , direction
  , version
  , headers
  , body

  , utf8
  , http10
  , http11
  , emptyRequest
  , emptyResponse

  , normalizeHeader
  , header
  , contentLength
  , keepAlive
  , cookie
  , location
  , contentType
  , date
  , server
  , hostname

  , 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 Data.Record.Label
import Misc.Misc
import Network.Protocol.Uri (URI, mkURI, pUriReference, parseURI)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import qualified Data.Bimap as Bm
import qualified Data.Map as M

-------- 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 HeaderKey   = String
type HeaderValue = String
type Headers     = M.Map HeaderKey HeaderValue

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

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

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

major     :: Label Version   Int
minor     :: Label Version   Int
body      :: Label Message   String
headers   :: Label Message   Headers
version   :: Label Message   Version
direction :: Label Message   Direction
_status   :: Label Direction Status
_uri      :: Label Direction URI
_method   :: Label Direction Method

-- Public labels based on private labels.

method :: Label Message Method
method = _method % direction

uri :: Label Message URI
uri = _uri % direction

status :: Label Message Status
status = _status % direction

-- More advanced labels.

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

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

contentLength :: Label Message (Maybe Integer)
contentLength = comp safeRead (maybe "" show) (header "Content-Length")

keepAlive :: Label Message (Maybe Integer)
keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")

cookie :: Label Message String
cookie =
  Label {
    lget = lget (header "Cookie")
  , lset = lset (header "Set-Cookie")
  }

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

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

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

hostname :: Label Message String
hostname = header "Host"

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

-- 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 ""

utf8 :: String
utf8 = "utf-8"

-------- 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, lget 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