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     , request
  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 request ∷ Parser Request
  66 request = do skipMany crlf
  67              (meth, u, ver) ← requestLine
  68              hdrs           ← headers
  69              return Request {
  70                           reqMethod  = meth
  71                         , reqURI     = u
  72                         , reqVersion = ver
  73                         , reqHeaders = hdrs
  74                         }
  75
  76 requestLine ∷ Parser (Method, URI, HttpVersion)
  77 requestLine = do meth ← method
  78                  sp
  79                  u ← uri
  80                  sp
  81                  ver ← httpVersion
  82                  crlf
  83                  return (meth, u, ver)
  84
  85 method ∷ Parser Method
  86 method = 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 uri ∷ Parser URI
  99 uri = 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 u  → return u