X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequest.hs;h=2fcfc9123e3c8e07f343ba3d9211556d4a4c2ed7;hb=db4a546d0d462cb94639b1f273bf0b78bccc960c;hp=712a6107f2932f93d603e9e272013e65c2553578;hpb=9ac730212cb361eb10e5fe4ad0eec6758e2b200a;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 712a610..2fcfc91 100644
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,23 +1,33 @@
-{-# OPTIONS_HADDOCK prune #-}
-
+{-# LANGUAGE
+    MultiParamTypeClasses
+  , OverloadedStrings
+  , 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
+    , reqMustHaveBody
     )
     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 Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
+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.
+-- require any descriptions.
 data Method = OPTIONS
             | GET
             | HEAD
@@ -26,64 +36,73 @@ data Method = OPTIONS
             | 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' must have an entity body.
+reqMustHaveBody ∷ Request → Bool
+{-# INLINEABLE reqMustHaveBody #-}
+reqMustHaveBody (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 Parsable ByteString Request where
+    {-# INLINEABLE parser #-}
+    parser = do skipMany crlf
+                (meth, u, ver) ← requestLine
+                hdrs           ← parser
+                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 choice $ map (\ (str, mth)
-                                 -> string str >> return mth) methods )
-          <|>
-          fmap ExtensionMethod token
+requestLine ∷ Parser (Method, URI, HttpVersion)
+{-# INLINEABLE requestLine #-}
+requestLine = do meth ← method
+                 sp
+                 u ← uri
+                 sp
+                 ver ← parser
+                 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  -> failP
-            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