Network/HTTP/Lucu/Request.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TypeSynonymInstances
   6   , UnicodeSyntax
   7   , ViewPatterns
   8   #-}
   9 -- |Definition of HTTP requests.
  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 qualified Data.ByteString.Char8 as C8
  21 import Data.Default
  22 import Network.HTTP.Lucu.Headers
  23 import Network.HTTP.Lucu.HttpVersion
  24 import Network.HTTP.Lucu.Parser.Http
  25 import Network.URI
  26 import Prelude.Unicode
  27
  28 -- |Definition of HTTP request methods.
  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 -- |Definition of HTTP requests.
  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' would have an entity body.
  57 reqHasBody ∷ Request → Bool
  58 {-# INLINEABLE reqHasBody #-}
  59 reqHasBody (reqMethod → m)
  60     | m ≡ POST  = True
  61     | m ≡ PUT   = True
  62     | otherwise = False
  63
  64 instance Default (Parser Method) where
  65     {-# INLINEABLE def #-}
  66     def = choice
  67           [ string "OPTIONS" ≫ return OPTIONS
  68           , string "GET"     ≫ return GET
  69           , string "HEAD"    ≫ return HEAD
  70           , string "POST"    ≫ return POST
  71           , string "PUT"     ≫ return PUT
  72           , string "DELETE"  ≫ return DELETE
  73           , string "TRACE"   ≫ return TRACE
  74           , string "CONNECT" ≫ return CONNECT
  75           , ExtensionMethod <$> token
  76           ]
  77
  78 instance Default (Parser Request) where
  79     {-# INLINEABLE def #-}
  80     def = do skipMany crlf
  81              (meth, u, ver) ← requestLine
  82              hdrs           ← def
  83              return Request {
  84                           reqMethod  = meth
  85                         , reqURI     = u
  86                         , reqVersion = ver
  87                         , reqHeaders = hdrs
  88                         }
  89
  90 requestLine ∷ Parser (Method, URI, HttpVersion)
  91 {-# INLINEABLE requestLine #-}
  92 requestLine = do meth ← def
  93                  sp
  94                  u ← uri
  95                  sp
  96                  ver ← def
  97                  crlf
  98                  return (meth, u, ver)
  99
 100 uri ∷ Parser URI
 101 {-# INLINEABLE uri #-}
 102 uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
 103          let str = C8.unpack bs
 104          case parseURIReference str of
 105            Nothing → fail ("Unparsable URI: " ⧺ str)
 106            Just u  → return u