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 descriptions.
  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 an 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 -- |'Parser' for a 'Request'.
  65 requestP ∷ Parser Request
  66 requestP = do skipMany crlf
  67               (method, uri, version) ← requestLineP
  68               headers                ← headersP
  69               return Request {
  70                            reqMethod  = method
  71                          , reqURI     = uri
  72                          , reqVersion = version
  73                          , reqHeaders = headers
  74                          }
  75
  76 requestLineP ∷ Parser (Method, URI, HttpVersion)
  77 requestLineP = do method ← methodP
  78                   sp
  79                   uri    ← uriP
  80                   sp
  81                   ver    ← httpVersionP
  82                   crlf
  83                   return (method, uri, ver)
  84
  85 methodP ∷ Parser Method
  86 methodP = choice
  87           [ string "OPTIONS" ≫ return OPTIONS
  88           , string "GET"     ≫ return GET
  89           , string "HEAD"    ≫ return HEAD
  90           , string "POST"    ≫ return POST
  91           , string "PUT"     ≫ return PUT
  92           , string "DELETE"  ≫ return DELETE
  93           , string "TRACE"   ≫ return TRACE
  94           , string "CONNECT" ≫ return CONNECT
  95           , ExtensionMethod <$> token
  96           ]
  97
  98 uriP ∷ Parser URI
  99 uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
 100           let str = C8.unpack bs
 101           case parseURIReference str of
 102             Nothing  -> fail ("Unparsable URI: " ⧺ str)
 103             Just uri -> return uri