Network/HTTP/Lucu/Request.hs

   1 module Network.HTTP.Lucu.Request
   2     ( Method(..)
   3     , Request(..)
   4     , requestP -- Parser Request
   5     )
   6     where
   7
   8 import qualified Data.ByteString.Lazy.Char8 as B
   9 import           Data.ByteString.Lazy.Char8 (ByteString)
  10 import           Network.HTTP.Lucu.Headers
  11 import           Network.HTTP.Lucu.HttpVersion
  12 import           Network.HTTP.Lucu.Parser
  13 import           Network.HTTP.Lucu.Parser.Http
  14 import           Network.URI
  15
  16 data Method = OPTIONS
  17             | GET
  18             | HEAD
  19             | POST
  20             | PUT
  21             | DELETE
  22             | TRACE
  23             | CONNECT
  24             | ExtensionMethod String
  25               deriving (Eq, Show)
  26
  27
  28 data Request
  29     = Request {
  30         reqMethod  :: Method
  31       , reqURI     :: URI
  32       , reqVersion :: HttpVersion
  33       , reqHeaders :: Headers
  34       }
  35     deriving (Show, Eq)
  36
  37 instance HasHeaders Request where
  38     getHeaders = reqHeaders
  39     setHeaders req hdr = req { reqHeaders = hdr }
  40
  41
  42 requestP :: Parser Request
  43 requestP = do many crlf
  44               (method, uri, version) <- requestLineP
  45               headers                <- headersP
  46               return Request {
  47                            reqMethod  = method
  48                          , reqURI     = uri
  49                          , reqVersion = version
  50                          , reqHeaders = headers
  51                          }
  52
  53
  54 requestLineP :: Parser (Method, URI, HttpVersion)
  55 requestLineP = do method <- methodP
  56                   sp
  57                   uri    <- uriP
  58                   sp
  59                   ver    <- httpVersionP
  60                   crlf
  61                   return (method, uri, ver)
  62
  63
  64 methodP :: Parser Method
  65 methodP = (let methods = [ ("OPTIONS", OPTIONS)
  66                          , ("GET"    , GET    )
  67                          , ("HEAD"   , HEAD   )
  68                          , ("POST"   , POST   )
  69                          , ("PUT"    , PUT    )
  70                          , ("DELETE" , DELETE )
  71                          , ("TRACE"  , TRACE  )
  72                          , ("CONNECT", CONNECT)
  73                          ]
  74            in foldl (<|>) (fail "") $ map (\ (str, mth)
  75                                            -> string str >> return mth) methods)
  76           <|>
  77           token >>= return . ExtensionMethod
  78
  79
  80 uriP :: Parser URI
  81 uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
  82           case parseURIReference str of
  83             Nothing  -> fail ""
  84             Just uri -> return uri