Fixed many bugs...

[Lucu.git] / Network / HTTP / Lucu / Request.hs

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 3c235eb6e6888e55d088312cedcc3f25a6e59b98..66511e24c1f869490469ea637e0ea763ffd1ec34 100644 (file)
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,84 +1,102 @@
+{-# LANGUAGE
+    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 -- Parser Request
+    , Request(..)
+    , reqMustHaveBody
+    , requestP
     )
     where
+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
 
-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
-
+-- |This is the definition of HTTP request methods, which shouldn't
+-- require any description.
 data Method = OPTIONS
             | GET
             | HEAD
+            | POST
             | PUT
             | 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
-      , reqBody    :: Maybe ByteString
+        reqMethod  ∷ !Method
+      , reqURI     ∷ !URI
+      , reqVersion ∷ !HttpVersion
+      , reqHeaders ∷ !Headers
       }
-    deriving (Show)
+    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
-              let req = Request {
-                          reqMethod  = method
-                        , reqURI     = uri
-                        , reqVersion = version
-                        , reqHeaders = emptyHeaders -- FIXME
-                        , reqBody    = Nothing      -- FIXME
-                        }
-              return req
-
+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
+requestLineP ∷ Parser (Method, URI, HttpVersion)
+requestLineP = do method ← methodP
                   sp
-                  uri    <- uriP
+                  uri    ← uriP
                   sp
-                  ver    <- httpVersionP
+                  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   )
-                         , ("PUT"    , PUT    )
-                         , ("DELETE" , DELETE )
-                         , ("TRACE"  , TRACE  )
-                         , ("CONNECT", CONNECT)
-                         ]
-           in foldl (<|>) (fail "") $ map (\ (str, mth)
-                                           -> string str >> return mth) methods)
-          <|>
-          many1 token >>= return . ExtensionMethod
-
-
-uriP :: Parser URI
-uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
+uriP ∷ Parser URI
+uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
+          let str = C8.unpack bs
           case parseURIReference str of
-            Nothing  -> fail ""
-            Just uri -> return uri
\ No newline at end of file
+            Nothing  -> fail ("Unparsable URI: " ⧺ str)
+            Just uri -> return uri