{-# LANGUAGE
    FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , TypeSynonymInstances
  , UnicodeSyntax
  , ViewPatterns
  #-}
-- |Definition of HTTP requests.
module Network.HTTP.Lucu.Request
    ( Method(..)
    , Request(..)
    , reqHasBody
    )
    where
import Control.Applicative
import Control.Monad.Unicode
import Data.Ascii (Ascii)
import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as C8
import Data.Default
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Parser.Http
import Network.URI
import Prelude.Unicode

-- |Definition of HTTP request methods.
data Method = OPTIONS
            | GET
            | HEAD
            | POST
            | PUT
            | DELETE
            | TRACE
            | CONNECT
            | ExtensionMethod !Ascii
              deriving (Eq, Show)

-- |Definition of HTTP requests.
data Request
    = Request {
        reqMethod   !Method
      , reqURI      !URI
      , reqVersion  !HttpVersion
      , reqHeaders  !Headers
      }
    deriving (Eq, Show)

instance HasHeaders Request where
    {-# INLINE getHeaders #-}
    getHeaders = reqHeaders
    {-# INLINE setHeaders #-}
    setHeaders req hdr = req { reqHeaders = hdr }

-- |Returns 'True' iff the 'Request' would have an entity body.
reqHasBody  Request  Bool
{-# INLINEABLE reqHasBody #-}
reqHasBody (reqMethod  m)
    | m  POST  = True
    | m  PUT   = True
    | otherwise = False

instance Default (Parser Method) where
    {-# INLINEABLE def #-}
    def = choice
          [ string "OPTIONS"  return OPTIONS
          , string "GET"      return GET
          , string "HEAD"     return HEAD
          , string "POST"     return POST
          , string "PUT"      return PUT
          , string "DELETE"   return DELETE
          , string "TRACE"    return TRACE
          , string "CONNECT"  return CONNECT
          , ExtensionMethod <$> token
          ]

instance Default (Parser Request) where
    {-# INLINEABLE def #-}
    def = do skipMany crlf
             (meth, u, ver)  requestLine
             hdrs            def
             return Request {
                          reqMethod  = meth
                        , reqURI     = u
                        , reqVersion = ver
                        , reqHeaders = hdrs
                        }

requestLine  Parser (Method, URI, HttpVersion)
{-# INLINEABLE requestLine #-}
requestLine = do meth  def
                 sp
                 u  uri
                 sp
                 ver  def
                 crlf
                 return (meth, u, ver)

uri  Parser URI
{-# INLINEABLE uri #-}
uri = do bs  takeWhile1 (\c  (¬) (isCtl c  c  '\x20'))
         let str = C8.unpack bs
         case parseURIReference str of
           Nothing  fail ("Unparsable URI: "  str)
           Just u   return u