--------------------------------------------------------------------
-- |
-- Module    : Web.Utils.HTTP
-- Copyright : (c) Sigbjorn Finne, 2009
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability: so-so
-- 
-- Ad-hoc, one-off, but convenient untyped representation of
-- HTTP requests and responses. Includes instances for serializing
-- both via JSON.
--
module Web.Utils.HTTP where

import Web.Types
import Data.Maybe
import Text.JSON

-- 
-- basic representation of requests and responses; minimal
-- typing used, i.e., at the other end of the spectrum from
-- the HTTP package's representation of the same objects.
--
data Request
 = Request
     { reqMethod  :: String
     , reqURL     :: URLString
     , reqHeaders :: [(String,String)]
     , reqVars    :: [(String,String)]
     , reqBody    :: String
     } 

data Response
 = Response
     { respStatus  :: Integer
     , respHeaders :: [(String,String)]
     , respBody    :: String
     } deriving ( Show, Read )


jsonRequest :: String -> Maybe Request
jsonRequest s =
  case decode s of
    Ok v -> Just v
    _ -> Nothing

jsonResponse :: Response -> String
jsonResponse r = encode r

instance JSON Request where
 readJSON r = readRequest r
 showJSON r = showRequest r

instance JSON Response where
 readJSON r = readResponse r
 showJSON r = showResponse r

readRequest :: JSValue -> Result Request
readRequest (JSObject o) = do
    m  <- valFromObj "method" o
    u  <- valFromObj "url"    o
    hs <- valFromObj "headers" o
    vs <- valFromObj "vars" o
    bo <- valFromObj "body" o
    return Request{ reqMethod  = m
                  , reqURL     = u
		  , reqHeaders = hs
		  , reqVars    = vs
		  , reqBody    = bo
		  }
readRequest _ = Error ("unable to decode Request object")

showRequest :: Request -> JSValue
showRequest r = makeObj
  [ ("method",  showJSON (reqMethod r))
  , ("url",     showJSON (reqURL r))
  , ("headers", showJSON (reqHeaders r))
  , ("vars",    showJSON (reqVars r))
  , ("body",    showJSON (reqBody r))
  ]

readResponse :: JSValue -> Result Response
readResponse (JSObject o) = do
    s  <- valFromObj "status" o
    hs <- valFromObj "headers" o
    bo <- valFromObj "body" o
    return Response{ respStatus  = s
                   , respHeaders = hs
		   , respBody    = bo
		   }
readResponse _ = Error ("unable to decode response object")

showResponse :: Response -> JSValue
showResponse r = makeObj
   [ ("status",  showJSON (respStatus r))
   , ("headers", showJSON (respHeaders r))
   , ("body",    showJSON (respBody r))
   ]

toStatusString :: Integer -> String
toStatusString x = fromMaybe "" (lookup x statusMap)


statusMap :: [(Integer, String)]
statusMap = 
  [ 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"
  ]
 where
   (-=>) a b = (a,b)