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)
import qualified Data.Map as Map
import Data.List (intersperse, unfoldr, isPrefixOf)

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

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLChar
import Data.Encoding (decodeLazyByteStringExplicit)

----------------------------------------
-- 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, ($+$), (<+>), (<>), text, colon
                                 ,int, empty)

import Safe (headMay)

----------------------------------------
-- LOCAL
----------------------------------------
import Data.HttpSpec.Pretty (Pretty(..))
import Data.HttpSpec.EncodingHelper (xmlEncoding, encodingFromContentType)

-- ============================================================================
--  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 = BSL.ByteString

-- 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 :: ReqIn -> HttpBody
reqIn_body = http_body . reqIn_data

reqIn_headers :: ReqIn -> HttpHeaders
reqIn_headers = http_headers . reqIn_data

data ReqOut = ReqOut { reqOut_url :: HttpUrl
                     , reqOut_method :: HttpMethod
                     , reqOut_data :: HttpData }
            deriving (Show)

reqOut_body :: ReqOut -> HttpBody
reqOut_body = http_body . reqOut_data

reqOut_headers :: ReqOut -> HttpHeaders
reqOut_headers = http_headers . reqOut_data

data ResIn = ResIn { resIn_code :: HttpCode
                   , resIn_reason :: HttpReason
                   , resIn_data :: HttpData }
             deriving (Show)

resIn_body :: ResIn -> HttpBody
resIn_body = http_body . resIn_data

resIn_headers :: ResIn -> HttpHeaders
resIn_headers = http_headers . resIn_data


data ResOut = ResOut { resOut_code :: HttpCode
                     , resOut_reason :: Maybe HttpReason
                     , resOut_data :: HttpData }
             deriving (Show)

resOut_body :: ResOut -> HttpBody
resOut_body = http_body . resOut_data

resOut_headers :: ResOut -> HttpHeaders
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 s'
    | s == "content-length" = Http.HdrContentLength
    | s == "content-md5" = Http.HdrContentMD5
    | s == "content-type" = Http.HdrContentType
    | s == "content-encoding" = Http.HdrContentEncoding
    | s == "content-transfer-encoding" = Http.HdrContentTransferEncoding
    | s == "transfer-encoding" = Http.HdrTransferEncoding
    | s == "user-agent" = Http.HdrUserAgent
    | otherwise = Http.HdrCustom s'
    where s = map toLower s'

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 }

urlSetPath :: HttpPath -> HttpUrl -> HttpUrl
urlSetPath path uri = uri { Uri.uriPath = 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 (hd, tl) = (hd, uri { Uri.uriPath = tl })
      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 = BSL.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 hn x =
        case hn of
          Http.HdrCustom mixedName -> headMay vals
              where vals = [v | (Http.HdrCustom n, v) <- httpHeaders x, map toLower n == name]
                    name = map toLower mixedName
          _ ->  lookup hn (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)
    reqSetUrlPath :: HttpPath -> a -> a
    reqSetUrlPath p req = reqSetUrl (urlSetPath p (reqUrl req)) 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 newUrl req = req { reqIn_fullUrl = newUrl }

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


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)

pprHttpBody :: Maybe String -> BSL.ByteString -> Doc
pprHttpBody mctype b =
    case mctype of
      Just ctype | "text/xml" `isPrefixOf` ctype || "application/xml" `isPrefixOf` ctype
          -> pprWithEncoding (xmlEncoding b)
      Just ctype | "text/" `isPrefixOf` ctype
        -> pprWithEncoding (encodingFromContentType ctype)
      Nothing | BSL.length b == 0 -> empty
      _ ->
          let hd' = BSL.take (fromIntegral maxbytes) b
              hd = BSLChar.takeWhile (<'\128') hd'
              unfold x = if BSL.length x > (fromIntegral maxlinelen)
                           then Just (BSL.splitAt (fromIntegral maxlinelen) x)
                           else Nothing
          in if BSL.length hd' > 20
               then (text . BSLChar.unpack . BSL.concat . intersperse binsep) (unfoldr unfold hd)
               else (text "[" <> text (show $ BSL.length b) <+> text "bytes"
                     <+> text (fromMaybe "binary data" mctype) <> text "]")
    where
      pprWithEncoding Nothing =
          (text ("Could not determine encoding of body of content-type "
                 ++ fromMaybe "(unknown)" mctype ++ ".")
           $+$ text "The first 64 bytes are: "
           $+$ text (show (BSL.take 64 b)))
      pprWithEncoding (Just enc) =
          case decodeLazyByteStringExplicit enc b of
            Left err -> text ("Could not decode body with " ++ show (BSL.length b) ++ " bytes " ++
                              " using the given encoding " ++ show enc ++ ": " ++ show err)
            Right s -> foldl ($+$) empty (map text $ "" : showlines s)
      showlines s | (showlines'' s) /= lines s = (showlines'' s) ++ ["[body shortend!]"]
                  | otherwise = bodylines s
      showlines'' s = map (shorten maxlinelen) (showlines' s)
      showlines' s =
          let (shorts,longs) = (span ((<=maxtakelinelen) . length) . take 25) (bodylines s)
          in shorts ++ take 1 longs
      bodylines s = lines (take maxbytes s)
      maxbytes = 1500
      binsep = BSLChar.pack "\\\n"
      maxtakelinelen = 160
      maxlinelen = 100

shorten :: Int -> String -> String
shorten i s
    | length s <= i = s
    | otherwise = take (i-3) s ++ "..."

instance Pretty Uri.URI where
    ppr = text . show

instance Pretty HttpData where
    ppr http@(HttpData hds b) = headers $+$ body
        where
          body = pprHttpBody (httpGetHeader Http.HdrContentType http) b
          headers = foldl ($+$) empty (map pprHd hds)
          pprHd (n,v) = text (show n) <> colon <+> text v

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