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     , reqHasBody
  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 description.
  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 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     getHeaders = reqHeaders
  52     setHeaders req hdr = req { reqHeaders = hdr }
  53
  54 -- |Returns 'True' iff the 'Request' must have an entity body.
  55 reqHasBody ∷ Request → Bool
  56 reqHasBody (reqMethod → m)
  57     = m ≡ POST ∨ m ≡ PUT
  58
  59 requestP ∷ Parser Request
  60 requestP = do skipMany crlf
  61               (method, uri, version) ← requestLineP
  62               headers                ← headersP
  63               return Request {
  64                            reqMethod  = method
  65                          , reqURI     = uri
  66                          , reqVersion = version
  67                          , reqHeaders = headers
  68                          }
  69
  70 requestLineP ∷ Parser (Method, URI, HttpVersion)
  71 requestLineP = do method ← methodP
  72                   sp
  73                   uri    ← uriP
  74                   sp
  75                   ver    ← httpVersionP
  76                   crlf
  77                   return (method, uri, ver)
  78
  79 methodP ∷ Parser Method
  80 methodP = choice
  81           [ string "OPTIONS" ≫ return OPTIONS
  82           , string "GET"     ≫ return GET
  83           , string "HEAD"    ≫ return HEAD
  84           , string "POST"    ≫ return POST
  85           , string "PUT"     ≫ return PUT
  86           , string "DELETE"  ≫ return DELETE
  87           , string "TRACE"   ≫ return TRACE
  88           , string "CONNECT" ≫ return CONNECT
  89           , ExtensionMethod <$> token
  90           ]
  91
  92 uriP ∷ Parser URI
  93 uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
  94           let str = C8.unpack bs
  95           case parseURIReference str of
  96             Nothing  -> fail ("Unparsable URI: " ⧺ str)
  97             Just uri -> return uri