]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Request.hs
Added inputForm
[Lucu.git] / 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