Network/HTTP/Lucu/Request.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 {-# OPTIONS_HADDOCK prune #-}
   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     , 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 requestP ∷ Parser Request
  55 requestP = do skipMany crlf
  56               (method, uri, version) ← requestLineP
  57               headers                ← headersP
  58               return Request {
  59                            reqMethod  = method
  60                          , reqURI     = uri
  61                          , reqVersion = version
  62                          , reqHeaders = headers
  63                          }
  64
  65 requestLineP ∷ Parser (Method, URI, HttpVersion)
  66 requestLineP = do method ← methodP
  67                   sp
  68                   uri    ← uriP
  69                   sp
  70                   ver    ← httpVersionP
  71                   crlf
  72                   return (method, uri, ver)
  73
  74 methodP ∷ Parser Method
  75 methodP = choice
  76           [ string "OPTIONS" ≫ return OPTIONS
  77           , string "GET"     ≫ return GET
  78           , string "HEAD"    ≫ return HEAD
  79           , string "POST"    ≫ return POST
  80           , string "PUT"     ≫ return PUT
  81           , string "DELETE"  ≫ return DELETE
  82           , string "TRACE"   ≫ return TRACE
  83           , string "CONNECT" ≫ return CONNECT
  84           , ExtensionMethod <$> token
  85           ]
  86
  87 uriP ∷ Parser URI
  88 uriP = try $
  89        do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
  90           let str = C8.unpack bs
  91           case parseURIReference str of
  92             Nothing  -> fail ("Unparsable URI: " ⧺ str)
  93             Just uri -> return uri