Network/HTTP/Lucu/Request.hs

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