{-# LANGUAGE DeriveFunctor #-}
module Http(module Http,StatusCode(..),Headers,header) where
import Data.List(isInfixOf)
import MimeMessage(hdrlines,Headers,header,MimeMessage(..),showMessage)
import MimeMessage(rmcrHdr,rejoin,disasmHeader,parseMessage',rmcrHdr,orig)
import HeaderNames
import StatusCode
--import Base64(encodeBase64)
import Utils2(addcr,crlf)

default (Int)

-- * HTTP related types
-- $doc These types represent the messages defined in the HTTP protocol.
-- A web client (a browser) sends a 'HttpRequest' to a web server, which
-- replies with a 'HttpResponse'.
--
-- See "HttpResponses" for functions like 'HttpResponses.okResponse' for
-- creating 'HttpResponse' values.

data HttpRequest uri
  = HttpReq {	reqURI::uri,
		reqMethod::HttpMethod,
		reqHdrs::HttpHeaders }
    deriving Functor

data HttpMethod
   = HttpGet
   | HttpHead
   | HttpPost String
   | HttpPostFormData [(String,String,String)]
   deriving (Eq,Show)

type HttpHeaders = Headers

type HttpResponseStr = HttpResponse String
data HttpResponse body
  = HttpResp {	respStatus::StatusCode,
		respHdrs::HttpHeaders,
		respBody::body }
    deriving Functor

respCode = statusCode . respStatus
respMsg  = statusMsg  . respStatus

showHttpResponse = showHttpResponse' addcr
showHttpResponseHead = showHttpResponseHead' addcr

showHttpResponse' addcr resp =
    showHttpResponseHead' addcr resp ++(respBody resp)

showHttpResponseHead' addcr (HttpResp (SC code msg) hdrs _body) =
    addcr (unlines (statusline:hdrlines hdrs++[""]))
  where
    statusline = unwords ["HTTP/1.0",show code,msg]

showHttpRequest showURI (HttpReq uri method hdrs) =
    addcr ( unlines (
    unwords [mname,showURI uri,"HTTP/1.0"]:
    hdrlines (hdrs++extrahdrs) ++
    [""])) ++
    body
  where
    (mname,extrahdrs,body) =
      case method of
        HttpGet    -> ("GET",[],[])
        HttpHead   -> ("HEAD",[],[])
	HttpPost s ->
	  ("POST",
	   [ct | contentType `notElem` map fst hdrs]
	   ++[header contentLength (show (length bodycr))],
	    bodycr)
          where
            ct = header contentType "application/x-www-form-urlencoded"
            bodycr = addcr s
	HttpPostFormData formdata ->
	  ("POST",
	   [header contentType ("multipart/form-data; boundary="++boundary),
	   header contentLength (show (length bodycr))],
            bodycr)
          where
            bodycr = multipart boundary (map encodePart formdata)
            boundary:_ = [boundary|
                          i<-"":map show [0..],
                          let boundary="------"++i,
                          not $ any (isInfixOf boundary) values]
            values = [v|(_,v,_)<-formdata]

    encodePart (name,value,attr) =
      MimeMsg [header contentDisposition ("form-data; name="++name++attr){-,
               (header contentTransferEncoding "base64")-}]
               ({-encodeBase64-} value++crlf)

    multipart boundary parts =
      "A multipart/form-data submission follows"++crlf++
      concatMap (((boundary++crlf)++) . showMessage) parts++
      boundary++"--"++crlf

parseHttpRequest s =
  case words l1 of
    ms:path:_ ->
        case ms of
          "GET" -> ok HttpGet
          "POST" -> ok (HttpPost body)
          "HEAD" -> ok HttpHead
          _ -> Left s
        where
          ok method =  Right (HttpReq path method hdrs)
    _ -> Left s
  where
    (l1,ls) = case rejoin (lines hs) of
                [] -> ([],[])
                l1:ls -> (l1,ls)
    hdrs = map disasmHeader ls
    (hs,body) = rmcrHdr s

parseHttpResponse :: String -> HttpResponseStr
parseHttpResponse = parseHttpResponse' . rmcrHdr

-- | Parse a HTTP response where the headers have already been separated
-- from the body
parseHttpResponse' m =
    case headers of
      [] -> HttpResp normalResult [] body -- pre HTTP/1.0 server
      h1@(h,h'):hdrs ->
	  case words (orig h) of
	    version:code:msgws ->
	        case reads code of
		  [(c,"")] -> HttpResp (SC c msg) hdrs body
		  _ -> HttpResp (SC 200 msg) hdrs body -- ??
	      where msg = unwords msgws ++ ": "++h'
	    _ -> HttpResp (SC 200 "No result code. OK?") (h1:hdrs) body -- ??
  where
    MimeMsg headers body = parseMessage' m