Network/HTTP/Lucu/Request.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   , ViewPatterns
   5   #-}
   6 -- |Definition of things related on HTTP request.
   7 --
   8 -- In general you don't have to use this module directly.
   9 module Network.HTTP.Lucu.Request
  10     ( Method(..)
  11     , Request(..)
  12     , reqMustHaveBody
  13     , requestP
  14     )
  15     where
  16 import Control.Applicative
  17 import Control.Monad.Unicode
  18 import Data.Ascii (Ascii)
  19 import Data.Attoparsec.Char8
  20 import qualified Data.ByteString.Char8 as C8
  21 import Network.HTTP.Lucu.Headers
  22 import Network.HTTP.Lucu.HttpVersion
  23 import Network.HTTP.Lucu.Parser.Http
  24 import Network.URI
  25 import Prelude.Unicode
  26
  27 -- |This is the definition of HTTP request methods, which shouldn't
  28 -- require any description.
  29 data Method = OPTIONS
  30             | GET
  31             | HEAD
  32             | POST
  33             | PUT
  34             | DELETE
  35             | TRACE
  36             | CONNECT
  37             | ExtensionMethod !Ascii
  38               deriving (Eq, Show)
  39
  40 -- |This is the definition of HTTP reqest.
  41 data Request
  42     = Request {
  43         reqMethod  ∷ !Method
  44       , reqURI     ∷ !URI
  45       , reqVersion ∷ !HttpVersion
  46       , reqHeaders ∷ !Headers
  47       }
  48     deriving (Eq, Show)
  49
  50 instance HasHeaders Request where
  51     {-# INLINE getHeaders #-}
  52     getHeaders = reqHeaders
  53     {-# INLINE setHeaders #-}
  54     setHeaders req hdr = req { reqHeaders = hdr }
  55
  56 -- |Returns 'True' iff the 'Request' must have an entity body.
  57 reqMustHaveBody ∷ Request → Bool
  58 {-# INLINEABLE reqMustHaveBody #-}
  59 reqMustHaveBody (reqMethod → m)
  60     | m ≡ POST  = True
  61     | m ≡ PUT   = True
  62     | otherwise = False
  63
  64 requestP ∷ Parser Request
  65 requestP = do skipMany crlf
  66               (method, uri, version) ← requestLineP
  67               headers                ← headersP
  68               return Request {
  69                            reqMethod  = method
  70                          , reqURI     = uri
  71                          , reqVersion = version
  72                          , reqHeaders = headers
  73                          }
  74
  75 requestLineP ∷ Parser (Method, URI, HttpVersion)
  76 requestLineP = do method ← methodP
  77                   sp
  78                   uri    ← uriP
  79                   sp
  80                   ver    ← httpVersionP
  81                   crlf
  82                   return (method, uri, ver)
  83
  84 methodP ∷ Parser Method
  85 methodP = choice
  86           [ string "OPTIONS" ≫ return OPTIONS
  87           , string "GET"     ≫ return GET
  88           , string "HEAD"    ≫ return HEAD
  89           , string "POST"    ≫ return POST
  90           , string "PUT"     ≫ return PUT
  91           , string "DELETE"  ≫ return DELETE
  92           , string "TRACE"   ≫ return TRACE
  93           , string "CONNECT" ≫ return CONNECT
  94           , ExtensionMethod <$> token
  95           ]
  96
  97 uriP ∷ Parser URI
  98 uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
  99           let str = C8.unpack bs
 100           case parseURIReference str of
 101             Nothing  -> fail ("Unparsable URI: " ⧺ str)
 102             Just uri -> return uri