--- #prune
-
+{-# LANGUAGE
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
+ , TypeSynonymInstances
+ , UnicodeSyntax
+ , ViewPatterns
+ #-}
-- |Definition of things related on HTTP request.
--
-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.Request
( Method(..)
, Request(..)
- , requestP
+ , reqHasBody
)
where
-
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.URI
+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
-- |This is the definition of HTTP request methods, which shouldn't
--- require any description.
+-- require any descriptions.
data Method = OPTIONS
| GET
| HEAD
| DELETE
| TRACE
| CONNECT
- | ExtensionMethod String
+ | ExtensionMethod !Ascii
deriving (Eq, Show)
--- |This is the definition of HTTP reqest.
+-- |This is the definition of an HTTP reqest.
data Request
= Request {
- reqMethod :: Method
- , reqURI :: URI
- , reqVersion :: HttpVersion
- , reqHeaders :: Headers
+ reqMethod ∷ !Method
+ , reqURI ∷ !URI
+ , reqVersion ∷ !HttpVersion
+ , reqHeaders ∷ !Headers
}
- deriving (Show, Eq)
+ 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
-requestP :: Parser Request
-requestP = do many crlf
- (method, uri, version) <- requestLineP
- headers <- headersP
- return Request {
- reqMethod = method
- , reqURI = uri
- , reqVersion = version
- , reqHeaders = headers
- }
-
-
-requestLineP :: Parser (Method, URI, HttpVersion)
-requestLineP = do method <- methodP
- sp
- uri <- uriP
- sp
- ver <- httpVersionP
- crlf
- return (method, uri, ver)
-
+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
+ }
-methodP :: Parser Method
-methodP = (let methods = [ ("OPTIONS", OPTIONS)
- , ("GET" , GET )
- , ("HEAD" , HEAD )
- , ("POST" , POST )
- , ("PUT" , PUT )
- , ("DELETE" , DELETE )
- , ("TRACE" , TRACE )
- , ("CONNECT", CONNECT)
- ]
- in foldl (<|>) (fail "") $ map (\ (str, mth)
- -> string str >> return mth) methods)
- <|>
- token >>= return . ExtensionMethod
+requestLine ∷ Parser (Method, URI, HttpVersion)
+{-# INLINEABLE requestLine #-}
+requestLine = do meth ← method
+ sp
+ u ← uri
+ sp
+ ver ← def
+ crlf
+ return (meth, u, ver)
+method ∷ Parser Method
+{-# INLINEABLE method #-}
+method = 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
+ ]
-uriP :: Parser URI
-uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
- case parseURIReference str of
- Nothing -> fail ""
- Just uri -> return uri
\ No newline at end of file
+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