+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
{-# OPTIONS_HADDOCK prune #-}
-- |Definition of things related on HTTP request.
, requestP
)
where
-
-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 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.
| DELETE
| TRACE
| CONNECT
- | ExtensionMethod !String
+ | ExtensionMethod !Ascii
deriving (Eq, Show)
-- |This is the definition of 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
getHeaders = reqHeaders
setHeaders req hdr = req { reqHeaders = hdr }
-
-requestP :: Parser Request
-requestP = do _ <- many crlf
- (method, uri, version) <- requestLineP
- headers <- headersP
+requestP ∷ Parser Request
+requestP = do skipMany crlf
+ (method, uri, version) ← requestLineP
+ headers ← headersP
return Request {
reqMethod = method
, reqURI = uri
, reqHeaders = headers
}
-
-requestLineP :: Parser (Method, URI, HttpVersion)
-requestLineP = do method <- methodP
- _ <- sp
- uri <- uriP
- _ <- sp
- ver <- httpVersionP
- _ <- crlf
+requestLineP ∷ Parser (Method, URI, HttpVersion)
+requestLineP = do method ← methodP
+ sp
+ uri ← uriP
+ sp
+ ver ← httpVersionP
+ crlf
return (method, uri, ver)
+methodP ∷ Parser Method
+methodP = 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
+ ]
-methodP :: Parser Method
-methodP = ( let methods = [ ("OPTIONS", OPTIONS)
- , ("GET" , GET )
- , ("HEAD" , HEAD )
- , ("POST" , POST )
- , ("PUT" , PUT )
- , ("DELETE" , DELETE )
- , ("TRACE" , TRACE )
- , ("CONNECT", CONNECT)
- ]
- in choice $ map (\ (str, mth)
- -> string str >> return mth) methods )
- <|>
- fmap ExtensionMethod token
-
-
-uriP :: Parser URI
-uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
+uriP ∷ Parser URI
+uriP = try $
+ do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
+ let str = C8.unpack bs
case parseURIReference str of
- Nothing -> failP
- Just uri -> return uri
\ No newline at end of file
+ Nothing -> fail ("Unparsable URI: " ⧺ str)
+ Just uri -> return uri