Network/HTTP/Lucu/Request.hs

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