X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequest.hs;h=ea855ba30cffc108ac7764766196b63a03ff8ce0;hb=HEAD;hp=b690c3e612435844eef847ff8feffbec1b39407e;hpb=b923d454928e3d01134b15d6072b6d3edf7a15ca;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index b690c3e..ea855ba 100644
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,16 +1,16 @@
 {-# LANGUAGE
-    OverloadedStrings
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , TypeSynonymInstances
   , UnicodeSyntax
+  , ViewPatterns
   #-}
-{-# OPTIONS_HADDOCK prune #-}
-
--- |Definition of things related on HTTP request.
---
--- In general you don't have to use this module directly.
+-- |Definition of HTTP requests.
 module Network.HTTP.Lucu.Request
     ( Method(..)
     , Request(..)
-    , requestP
+    , reqHasBody
     )
     where
 import Control.Applicative
@@ -18,14 +18,14 @@ 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.
+-- |Definition of HTTP request methods.
 data Method = OPTIONS
             | GET
             | HEAD
@@ -37,7 +37,7 @@ data Method = OPTIONS
             | ExtensionMethod !Ascii
               deriving (Eq, Show)
 
--- |This is the definition of HTTP reqest.
+-- |Definition of HTTP requests.
 data Request
     = Request {
         reqMethod  ∷ !Method
@@ -48,31 +48,22 @@ data Request
     deriving (Eq, Show)
 
 instance HasHeaders Request where
+    {-# INLINE getHeaders #-}
     getHeaders = reqHeaders
+    {-# INLINE setHeaders #-}
     setHeaders req hdr = req { reqHeaders = hdr }
 
-requestP ∷ Parser Request
-requestP = do skipMany 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)
+-- |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
 
-methodP ∷ Parser Method
-methodP = choice
+instance Default (Parser Method) where
+    {-# INLINEABLE def #-}
+    def = choice
           [ string "OPTIONS" ≫ return OPTIONS
           , string "GET"     ≫ return GET
           , string "HEAD"    ≫ return HEAD
@@ -84,9 +75,32 @@ methodP = choice
           , ExtensionMethod <$> token
           ]
 
-uriP ∷ Parser URI
-uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
-          let str = C8.unpack bs
-          case parseURIReference str of
-            Nothing  -> fail ("Unparsable URI: " ⧺ str)
-            Just uri -> return uri
+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