module Data.HttpSpec.HttpTypes
    (HttpBody, HttpMethod, HttpUrl, HttpCode, HttpReason
    ,HttpHeaderName, HttpHeaderValue, HttpHeader, HttpHeaders
    ,HttpParamName, HttpParamValue, HttpParams
    ,HttpData(..), ReqIn(..), ReqOut(..), ResIn(..), ResOut(..)
    ,IsHttp(..), IsReq(..), IsRes(..)
    ,reqIn_body, reqIn_headers, reqOut_body, reqOut_headers
    ,resIn_body, resIn_headers, resOut_body, resOut_headers
    ,urlParams, urlMatchPrefix, urlMatchPrefix', urlSplit, url
    ,completeReq, completeRes, mkHeaderName)
where

----------------------------------------
-- STDLIB
----------------------------------------
import Data.Char (toLower)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (isPrefixOf)

import Control.Monad (liftM)
import Control.Arrow (first)

import System.FilePath (takeDirectory, (</>))

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import qualified Network.HTTP as Http
import qualified Network.URI as Uri
import qualified Network.CGI as Cgi

import Text.PrettyPrint.HughesPJ (Doc, vcat, ($+$), (<+>), (<>), text, colon
                                 ,int, empty)

import Safe (headMay)

----------------------------------------
-- LOCAL
----------------------------------------
import Data.HttpSpec.Pretty (Pretty(..))

-- ============================================================================
--  http types
-- ============================================================================

-- URL types
type HttpPath = String
type HttpParamName = String
type HttpParamValue = String
type HttpParams = [(HttpParamName, HttpParamValue)]
type HttpUrl = Uri.URI

-- Http message types
type HttpHeaderName = Http.HeaderName
type HttpHeaderValue = String
type HttpHeader = (HttpHeaderName, String)
type HttpHeaders = [HttpHeader]
type HttpBody = String

-- Request types
type HttpMethod = Http.RequestMethod

-- Response types
type HttpCode = Int
type HttpReason = String


data HttpData = HttpData { http_headers :: HttpHeaders
                         , http_body :: HttpBody
                         }
              deriving (Show)

data ReqIn = ReqIn { reqIn_progUrl :: HttpUrl
                   , reqIn_fullUrl :: HttpUrl
                   , reqIn_method :: HttpMethod
                   , reqIn_data :: HttpData
                   }
           deriving (Show)
reqIn_body = http_body . reqIn_data
reqIn_headers = http_headers . reqIn_data

data ReqOut = ReqOut { reqOut_url :: HttpUrl
                     , reqOut_method :: HttpMethod
                     , reqOut_data :: HttpData }
            deriving (Show)
reqOut_body = http_body . reqOut_data
reqOut_headers = http_headers . reqOut_data

data ResIn = ResIn { resIn_code :: HttpCode
                   , resIn_reason :: HttpReason
                   , resIn_data :: HttpData }
             deriving (Show)
resIn_body = http_body . resIn_data
resIn_headers = http_headers . resIn_data


data ResOut = ResOut { resOut_code :: HttpCode
                     , resOut_reason :: Maybe HttpReason
                     , resOut_data :: HttpData }
             deriving (Show)
resOut_body = http_body . resOut_data
resOut_headers = http_headers . resOut_data


-- ============================================================================
--  helper functions and instances
-- ============================================================================

instance Ord Http.HeaderName where
    compare hn1 hn2 = compare (mapHdr hn1) (mapHdr hn2)
        where mapHdr (Http.HdrCustom l) = Left l
              mapHdr other = Right (show other)

mkHeaderName :: String -> HttpHeaderName
mkHeaderName = Http.HdrCustom

url :: String -> HttpUrl
url s = case Uri.parseURI s of
          Just uri -> uri
          Nothing -> error $ "HttpTypes.url: Invalid URI `" ++ s ++ "'"

urlParams :: HttpUrl -> HttpParams
urlParams uri = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)

urlAddParam :: HttpParamName -> HttpParamValue -> HttpUrl -> HttpUrl
urlAddParam n v uri = uri'
    where params = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)
          params' = (n,v) : params
          uri' = uri { Uri.uriQuery = '?' : Cgi.formEncode params' }

urlAppendPath :: HttpPath -> HttpUrl -> HttpUrl
urlAppendPath path uri = uri { Uri.uriPath = Uri.uriPath uri ++ path }

-- | Splits off the first path component of a URL.
-- @urlSplit (url "http://svr/foo/bar") == Just ("/foo", url "http://svr/bar")@
-- @urlSplit (url "http://svr/") == Just ("/", url "http://svr")@
-- @urlSplit (url "http://svr") == Nothing@
urlSplit :: Monad m => HttpUrl -> m (HttpPath, HttpUrl)
urlSplit uri = liftM mapUri (uriPathSplit $ Uri.uriPath uri)
    where
      mapUri (head, tail) = (head, uri { Uri.uriPath = tail })
      uriPathSplit "" = fail "Empty URL Path."
      uriPathSplit "/" = return ("/", "")
      uriPathSplit ('/':path) = liftM (first ('/':)) (uriPathSplit path)
      uriPathSplit path = return $ span (/='/') path

urlMatchPrefix :: HttpPath -> HttpUrl -> Maybe HttpUrl
urlMatchPrefix s uri
    | s `isPrefixOf` path = Just $ uri { Uri.uriPath = drop (length s) path }
    | otherwise = Nothing
    where path = Uri.uriPath uri


urlMatchPrefix' :: HttpUrl -> HttpUrl -> Maybe HttpUrl
urlMatchPrefix' prefixUrl = urlMatchPrefix prefixPath
    where prefixPath = Uri.uriPath prefixUrl


completeReq :: IsHttp req => req -> req
completeReq r = if clen /= 0 then r2 else r
    where
      clen = length (httpBody r)
      r1 | not (httpHasHeader Http.HdrTransferEncoding r)
           && not (httpHasHeader Http.HdrContentLength r)
               = httpSetHeader Http.HdrContentLength (show clen) r
         | otherwise = r
      r2 | not (httpHasHeader Http.HdrContentType r1)
             = httpSetHeader Http.HdrContentType "application/octet-stream" r1
         | otherwise = r1

completeRes :: IsHttp res => res -> res
completeRes = completeReq

-- ============================================================================
--  access helper type classes
-- ============================================================================


class IsHttp a where
    -- required methods
    httpData :: a -> HttpData
    httpSetData :: a -> HttpData -> a
    -- methods with default implementations
    httpHeaders :: a -> HttpHeaders
    httpHeaders = http_headers . httpData
    httpBody :: a -> HttpBody
    httpBody = http_body . httpData
    httpGetHeader :: HttpHeaderName -> a -> Maybe HttpHeaderValue
    httpGetHeader n x =
        case n of
          Http.HdrCustom mixedName -> headMay vals
              where vals = [v | (Http.HdrCustom n, v) <- httpHeaders x, map toLower n == name]
                    name = map toLower mixedName
          _ ->  lookup n (httpHeaders x)
    httpHasHeader :: HttpHeaderName -> a -> Bool
    httpHasHeader n = (/=Nothing) . httpGetHeader n
    httpSetBody :: HttpBody -> a -> a
    httpSetBody body this = httpSetData this (HttpData (httpHeaders this) body)
    httpSetHeaders :: HttpHeaders -> a -> a
    httpSetHeaders hs this = httpSetData this (HttpData hs (httpBody this))
    httpSetHeader :: HttpHeaderName -> HttpHeaderValue -> a -> a
    httpSetHeader name val this = flip httpSetHeaders this .
                                  Map.toList $
                                  Map.insert name val $
                                  Map.fromList (httpHeaders this)

class IsHttp a => IsRes a where
    resCode :: a -> HttpCode
    resSetStatus :: HttpCode -> Maybe HttpReason -> a -> a
    resReason :: a -> HttpReason
    resReason res = fromMaybe def $ lookup (resCode res) statusCodeMessageMap
        where def = ""

class IsHttp a => IsReq a where
    reqMethod :: a -> HttpMethod
    reqUrl :: a -> HttpUrl
    reqSetMethod :: HttpMethod -> a -> a
    reqSetUrl :: HttpUrl -> a -> a
    reqUrlPath :: a -> HttpPath
    reqUrlPath req = Uri.uriPath (reqUrl req)
    reqAppendUrlPath :: HttpPath -> a -> a
    reqAppendUrlPath p req = reqSetUrl (urlAppendPath p (reqUrl req)) req
    reqAddUrlParam :: HttpParamName -> HttpParamValue -> a -> a
    reqAddUrlParam n v r = reqSetUrl (urlAddParam n v (reqUrl r)) r

instance IsHttp HttpData where
    httpData = id
    httpSetData = const

instance IsHttp ReqIn where
    httpData = reqIn_data
    httpSetData this x = this { reqIn_data = x }

instance IsHttp ReqOut where
    httpData = reqOut_data
    httpSetData this x = this { reqOut_data = x }

instance IsHttp ResIn where
    httpData = resIn_data
    httpSetData this x = this { resIn_data = x }

instance IsHttp ResOut where
    httpData = resOut_data
    httpSetData this x = this { resOut_data = x }


instance IsRes ResIn where
    resCode = resIn_code
    resSetStatus code mr r = r { resIn_reason = fromMaybe (resIn_reason r) mr
                               , resIn_code = code }

instance IsRes ResOut where
    resCode = resOut_code
    resSetStatus code mr r = r { resOut_reason = mr
                               , resOut_code = code }


instance IsReq ReqIn where
    reqMethod = reqIn_method
    reqUrl = reqIn_fullUrl
    reqSetMethod meth req = req { reqIn_method = meth }
    reqSetUrl url req = req { reqIn_fullUrl = url }

instance IsReq ReqOut where
    reqMethod = reqOut_method
    reqUrl = reqOut_url
    reqSetMethod meth req = req { reqOut_method = meth }
    reqSetUrl url req = req { reqOut_url = url }


pprReq :: IsReq req => req -> Doc
pprReq req =  ppr (reqMethod req) <+> ppr (reqUrl req) <+> text "HTTP/1.1"
              $+$ ppr (httpData req)

pprRes :: IsRes res => res -> Doc
pprRes res = int (resCode res) <+> text (resReason res) $+$ ppr (httpData res)

instance Pretty Uri.URI where
    ppr = text . show

instance Pretty HttpData where
    ppr (HttpData hds b) = foldl ($+$) empty (map pprHd hds)
                           $+$ foldl ($+$) empty (map text $ "" : bodylines)
        where pprHd (n,v) = text (show n) <> colon <+> text v
              showlines | showlines' /= bodylines = bodylines ++ ["[...]"]
                        | otherwise = bodylines
              showlines' = takeWhile ((<=80) . length) $ take 5 bodylines
              bodylines = lines b

instance Pretty ReqIn where
    ppr = pprReq

instance Pretty ReqOut where
    ppr = pprReq

instance Pretty ResIn where
    ppr = pprRes

instance Pretty ResOut where
    ppr = pprRes

instance Pretty Http.RequestMethod where
    ppr = text . show


statusCodeMessageMap :: [(Int, String)]
statusCodeMessageMap =
    [(100, "Continue")
    ,(101, "Switching Protocols")
    ,(200, "OK")
    ,(201, "Created")
    ,(202, "Accepted")
    ,(203, "Non-Authoritative Information")
    ,(204, "No Content")
    ,(205, "Reset Content")
    ,(206, "Partial Content")
    ,(300, "Multiple Choices")
    ,(301, "Moved Permanently")
    ,(302, "Found")
    ,(303, "See Other")
    ,(304, "Not Modified")
    ,(305, "Use Proxy")
    ,(307, "Temporary Redirect")
    ,(400, "Bad Request")
    ,(401, "Unauthorized")
    ,(402, "Payment Required")
    ,(403, "Forbidden")
    ,(404, "Not Found")
    ,(405, "Method Not Allowed")
    ,(406, "Not Acceptable")
    ,(407, "Proxy Authentication Required")
    ,(408, "Request Time-out")
    ,(409, "Conflict")
    ,(410, "Gone")
    ,(411, "Length Required")
    ,(412, "Precondition Failed")
    ,(413, "Request Entity Too Large")
    ,(414, "Request-URI Too Large")
    ,(415, "Unsupported Media Type")
    ,(416, "Requested range not satisfiable")
    ,(417, "Expectation Failed")
    ,(500, "Internal Server Error")
    ,(501, "Not Implemented")
    ,(502, "Bad Gateway")
    ,(503, "Service Unavailable")
    ,(504, "Gateway Time-out")
    ,(505, "HTTP Version not supported")
    ]