{-# 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