redHandlers (empty) → 0.1
raw patch · 24 files changed
+2822/−0 lines, 24 filesdep +MaybeTdep +arraydep +basesetup-changedbinary-added
Dependencies added: MaybeT, array, base, bytestring, cgi, containers, haskell98, mtl, network, old-time, parsec, stm, unix, xhtml
Files
- AUTHORS +3/−0
- Example/GridExample.hs +102/−0
- Example/HtmlExample.hs +47/−0
- Example/Makefile +10/−0
- Example/README +12/−0
- Example/images/header.gif binary
- LICENSE +25/−0
- Network/HTTP/RedHandler.hs +12/−0
- Network/HTTP/RedHandler/FileUtils.hs +64/−0
- Network/HTTP/RedHandler/HTTP_Fork/HTTP.hs +784/−0
- Network/HTTP/RedHandler/HTTP_Fork/HTTP/Base64.hs +279/−0
- Network/HTTP/RedHandler/HTTP_Fork/HTTP/Headers.hs +310/−0
- Network/HTTP/RedHandler/HTTP_Fork/Stream.hs +59/−0
- Network/HTTP/RedHandler/HTTP_Fork/StreamDebugger.hs +59/−0
- Network/HTTP/RedHandler/HTTP_Fork/StreamSocket.hs +83/−0
- Network/HTTP/RedHandler/HTTP_Fork/TCP.hs +192/−0
- Network/HTTP/RedHandler/Handler.hs +232/−0
- Network/HTTP/RedHandler/Httpd.hs +107/−0
- Network/HTTP/RedHandler/RequestContext.hs +183/−0
- Network/HTTP/RedHandler/Response.hs +75/−0
- Network/HTTP/RedHandler/Session.hs +112/−0
- Network/HTTP/RedHandler/Utils.hs +31/−0
- Setup.lhs +6/−0
- redHandlers.cabal +35/−0
+ AUTHORS view
@@ -0,0 +1,3 @@+Tom Nielsen (tanielsen@gmail.com): Initital design and development.+Sergio Urinovsky (sergio.urinovsky@gmail.com): Design and lead developer.+
+ Example/GridExample.hs view
@@ -0,0 +1,102 @@+module Main where++import Text.CxML+import Text.YuiGrid+import Network.HTTP.RedHandler+import Control.Monad.Reader (ask)+++-----------------------------------------------+-- Responses with grids+-----------------------------------------------++type GridResp = HandlerRsp [GridElement ()]++gridRespToRsp :: GridResp -> BasicRsp+gridRespToRsp = basicRspWith (showNonCxmlStrict "Grid Example" . gridPage)++-----------------------------------------------+-- Utilities for Handlers with Grid responses+-----------------------------------------------++-- | add contextual grid elements to the dynamic response+inGridWithElems :: Monad m => [GridElement RequestContext] -> RqHandlerT m GridResp -> RqHandlerT m GridResp+inGridWithElems ges handl = do ges' <- fmap (runBoxes ges) ask+ fmap (fmap (++ ges')) handl++-- | turn a contextual html into a grid response handler+okCxML :: Monad m => CxML RequestContext -> RqHandlerT m GridResp+okCxML cx = fmap ( return . (:[]) . boxInMain . runCxML cx) ask+++-----------------------------------------------+-- Main daemon and port+-----------------------------------------------+main :: IO ()+main = runHttpServer 8080 mainHandlers++-----------------------------------------------+-- Routes and handlers+-----------------------------------------------+mainHandlers :: [IORqHandler BasicRsp]+mainHandlers = [staticFilesHandler, appHandlers]++staticFilesHandler = under "pictures" $ mapDir "./images/"++appHandlers = modResp gridRespToRsp $ appCtx $ anyOf [greetHandler, inputFormHandler]+++inputFormHandler :: IORqHandler GridResp+inputFormHandler = okCxML inputForm++greetHandler :: IORqHandler GridResp+greetHandler = ifPost $ + withPostField "name" (\n -> if null n + then notMe + else okCxML (greet n)+ )+++greet :: String -> CxML a+greet n = p /- [t $ "Hello " ++ n ++ "!"]++inputForm :: CxML a+inputForm = form!("method","post")+ /- [+ p /- [t "My name is ", textfield "name"],+ button!("name","action")!("value","submit") /- [t "Submit"]+ ]++++-----------------------------------------------+-- Application GRID context+-----------------------------------------------+appCtx :: Monad m => RqHandlerT m GridResp -> RqHandlerT m GridResp+appCtx h = do+ inGridWithElems [+ boxInFooter (t "Footer goes here."),+ boxInHeader (h1logo "Header image goes in the URL" "/pictures/header.gif"),+ smallMarginBottomCSS $ nearLeft $ setColumnsVote 2 $ nearBottom $ boxInHeader (loginControl "Guest"),+ smallMarginBottomCSS $ nearRight $ setColumnsVote 2 $ nearBottom $ boxInHeader searchForm,+ boxInLeftSidebar (vertNav [("Home", "/"),+ ("About", "/about"),+ ("Contact", "/contact")])+ ] $ h+++-----------------------------------------------+-- More contextual htmls used in the example+-----------------------------------------------+searchForm :: CxML a+searchForm+ = form!("method","post")!("action","/search.html")+ /- [+ textfield "search", + button!("name","action")!("value","submit") /- [t "Search"]+ ]+++loginControl ::String -> CxML a+loginControl userName = t ("User: " ++ userName)+
+ Example/HtmlExample.hs view
@@ -0,0 +1,47 @@+module Main where++import Text.XHtml.Strict+import Network.HTTP.RedHandler++-----------------------------------------------+-- Main daemon and port+-----------------------------------------------+main :: IO ()+main = runHttpServer 8080 mainHandlers++-----------------------------------------------+-- Routes and handlers+-----------------------------------------------+mainHandlers :: [IORqHandler BasicRsp]+mainHandlers = map (modResp htmlRespToRsp) [greetHandler, inputFormHandler]++inputFormHandler :: IORqHandler (HandlerRsp Html)+inputFormHandler = okHtml $ page "Handlers Example" inputForm++greetHandler :: IORqHandler (HandlerRsp Html)+greetHandler = ifPost $ + withPostField "name" (\n -> if null n + then notMe + else okHtml (page "Handlers Example" (greet n))+ )+++inputForm :: Html+inputForm = form![method "post"] << [paragraph << ("My name is " +++ textfield "name"),+ submit "" "Submit"]++greet :: String -> Html +greet n = paragraph << ("Hello " ++ n ++ "!")+ +page t b = header << thetitle << t +++ body << b+++-----------------------------------------------+-- Utilities for Html responses+-----------------------------------------------+okHtml :: Monad m => Html -> RqHandlerT m (HandlerRsp Html)+okHtml = return . return++htmlRespToRsp :: HandlerRsp Html -> BasicRsp+htmlRespToRsp = basicRspWith prettyHtmlFragment+
+ Example/Makefile view
@@ -0,0 +1,10 @@+.PHONY: application clean++application:+ ghc -o HtmlExample --make HtmlExample.hs+ ghc -o GridExample --make GridExample.hs++clean:+ -rm HtmlExample+ -rm GridExample+ -rm *.o *.hi *~
+ Example/README view
@@ -0,0 +1,12 @@+BUILD:+In order to build the grid example you need to setup also the "yuiGrid" pkg.+Run "make" to make the examples. If the yuiGrid pkg is not installed you should be able to build just the Html example.++RUN:+The examples are standalone web applications listening on port 8080.+ - Run any of the application examples (HtmlExample or GridExample).+ - Open a browser and try the URL: http://localhost:8080/.++++
+ Example/images/header.gif view
binary file changed (absent → 26128 bytes)
+ LICENSE view
@@ -0,0 +1,25 @@+The MIT License++Copyright (c) 2009 RedNucleus LTD++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.+
+ Network/HTTP/RedHandler.hs view
@@ -0,0 +1,12 @@+module Network.HTTP.RedHandler+ (+ module Network.HTTP.RedHandler.RequestContext,+ module Network.HTTP.RedHandler.Handler,+ module Network.HTTP.RedHandler.Response,+ runHttpServer,+ ) where++import Network.HTTP.RedHandler.RequestContext+import Network.HTTP.RedHandler.Handler+import Network.HTTP.RedHandler.Response+import Network.HTTP.RedHandler.Httpd
+ Network/HTTP/RedHandler/FileUtils.hs view
@@ -0,0 +1,64 @@+module Network.HTTP.RedHandler.FileUtils where++import System.Posix (FileStatus, getFileStatus, fileSize, fileAccess, modificationTime, isDirectory, isRegularFile)+import Control.Exception as Exception (tryJust, ioErrors)+import Foreign.C.Error (getErrno, eNOENT)++sendFileResponse :: String -> IO (Maybe (Integer, String))+sendFileResponse path = do++ check <- findRealFilename path+ case check of { + Nothing -> return Nothing;+ Just (filename,stat) -> do+ + -- check we can actually read this file+ access <- fileAccess filename True{-read-} False False+ case access of {+ False -> return Nothing;+ -- not "permission denied", we're being paranoid+ -- about security.+ True -> do+ {-+ let content_type = + case mimeTypeOf filename of+ Nothing -> contentTypeHeader (show defaultType)+ Just t -> contentTypeHeader (show t)+ + let last_modified = + lastModifiedHeader (epochTimeToClockTime (modificationTime stat))+ -}+ let size = toInteger (fileSize stat)+ + return (Just (size, filename) )+ }}++statFile :: String -> IO (Maybe FileStatus)+statFile filename = do+ maybe_stat <- tryJust ioErrors (getFileStatus filename)+ case maybe_stat of+ Left e -> do+ errno <- getErrno+ if errno == eNOENT+ then return Nothing+ else ioError e+ Right stat ->+ return (Just stat)++findRealFilename :: String -> IO (Maybe (String,FileStatus))+findRealFilename filename = do+ stat <- statFile filename+ case stat of+ Nothing -> return Nothing+ Just stat+ | isDirectory stat -> do+ let index_filename = filename ++ '/': "index.html"+ stat <- statFile index_filename+ case stat of+ Nothing -> return Nothing+ Just stat -> return (Just (index_filename,stat))+ | isRegularFile stat ->+ return (Just (filename,stat))+ | otherwise ->+ return Nothing+
+ Network/HTTP/RedHandler/HTTP_Fork/HTTP.hs view
@@ -0,0 +1,784 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- License : BSD+-- +-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An easy HTTP interface enjoy.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Made dependencies explicit in import statements.+-- - Removed false dependencies in import statements.+-- - Added missing type signatures.+-- - Moved Header-related code to Network.HTTP.Headers module.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- - Created functions receiveHTTP and responseHTTP to allow server side interactions+-- (although 100-continue is unsupported and I haven't checked for standard compliancy).+-- - Pulled the transfer functions from sendHTTP to global scope to allow access by+-- above functions.+--+-- * Changes by Graham Klyne:+-- - export httpVersion+-- - use new URI module (similar to old, but uses revised URI datatype)+--+-- * Changes by Bjorn Bringert:+--+-- - handle URIs with a port number+-- - added debugging toggle+-- - disabled 100-continue transfers to get HTTP\/1.0 compatibility+-- - change 'ioError' to 'throw'+-- - Added simpleHTTP_, which takes a stream argument.+--+-- * Changes from 0.1+-- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.+-- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.+-- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic+-- and the addition of a debugging stream.+-- - simplified error handling.+-- +-- * TODO+-- - request pipelining+-- - https upgrade (includes full TLS, i.e. SSL, implementation)+-- - use of Stream classes will pay off+-- - consider C implementation of encryption\/decryption+-- - comm timeouts+-- - MIME & entity stuff (happening in separate module)+-- - support \"*\" uri-request-string for OPTIONS request method+-- +-- +-- * Header notes:+--+-- [@Host@]+-- Required by HTTP\/1.1, if not supplied as part+-- of a request a default Host value is extracted+-- from the request-uri.+-- +-- [@Connection@] +-- If this header is present in any request or+-- response, and it's value is "close", then+-- the current request\/response is the last +-- to be allowed on that connection.+-- +-- [@Expect@]+-- Should a request contain a body, an Expect+-- header will be added to the request. The added+-- header has the value \"100-continue\". After+-- a 417 \"Expectation Failed\" response the request+-- is attempted again without this added Expect+-- header.+-- +-- [@TransferEncoding,ContentLength,...@]+-- if request is inconsistent with any of these+-- header values then you may not receive any response+-- or will generate an error response (probably 4xx).+--+--+-- * Response code notes+-- Some response codes induce special behaviour:+--+-- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent.+-- \"101 Upgrade\" will be returned.+-- Other 1xx responses are ignored.+-- +-- [@417@] The reason for this code is \"Expectation failed\", indicating+-- that the server did not like the Expect \"100-continue\" header+-- added to a request. Receipt of 417 will induce another+-- request attempt (without Expect header), unless no Expect header+-- had been added (in which case 417 response is returned).+--+-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.HTTP (+ module Network.HTTP.RedHandler.HTTP_Fork.Stream,+ module Network.HTTP.RedHandler.HTTP_Fork.TCP,++ -- ** Constants+ httpVersion,++ -- ** HTTP + Request(..),+ Response(..),+ RequestMethod(..),+ ResponseCode,+ ResponseBody(..),+ simpleHTTP, simpleHTTP_,+ sendHTTP,+ receiveHTTP,+ respondHTTP,++ -- ** Header Functions+ module Network.HTTP.RedHandler.HTTP_Fork.HTTP.Headers,++ -- ** URL Encoding+ urlEncode,+ urlDecode,+ urlEncodeVars,++ -- ** URI authority parsing+ URIAuthority(..),+ parseURIAuthority+) where+++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.URI+ ( URI(URI, uriScheme, uriAuthority, uriPath)+ , URIAuth(uriUserInfo, uriRegName, uriPort)+ , parseURIReference+ , unEscapeString+ )+import Network.HTTP.RedHandler.HTTP_Fork.HTTP.Headers+import Network.HTTP.RedHandler.HTTP_Fork.Stream+import Network.HTTP.RedHandler.HTTP_Fork.StreamDebugger (debugStream)+import Network.HTTP.RedHandler.HTTP_Fork.TCP (openTCPPort)++import Control.Exception as Exception (catch, throw)+import Data.Bits ((.&.))+import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)+import Data.List (partition)+import Data.Maybe (listToMaybe, fromMaybe)+import Control.Monad (when, guard)+import Numeric (readHex)+import Text.Read.Lex (readDecP)+import Text.ParserCombinators.ReadP+ ( ReadP, readP_to_S, char, (<++), look, munch )++-- Turn on to enable HTTP traffic logging+debug :: Bool+debug = False++-- File that HTTP traffic logs go to+httpLogFile :: String+httpLogFile = "http-debug.log"++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- remove leading and trailing whitespace.+trim :: String -> String+trim = let dropspace = dropWhile isSpace in+ reverse . dropspace . reverse . dropspace+++crlf, sp :: String+crlf = "\r\n"+sp = " "++-----------------------------------------------------------------+------------------ URI Authority parsing ------------------------+-----------------------------------------------------------------++data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String,+ host :: String,+ port :: Maybe Int+ } deriving (Eq,Show)++-- | Parse the authority part of a URL.+--+-- > RFC 1732, section 3.1:+-- >+-- > //<user>:<password>@<host>:<port>/<url-path>+-- > Some or all of the parts "<user>:<password>@", ":<password>",+-- > ":<port>", and "/<url-path>" may be excluded.+parseURIAuthority :: String -> Maybe URIAuthority+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuthority+pURIAuthority = do+ (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing)+ h <- munch (/=':')+ p <- orNothing (char ':' >> readDecP)+ look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p }++pUserInfo :: ReadP (Maybe String, Maybe String)+pUserInfo = do+ u <- orNothing (munch (`notElem` ":@"))+ p <- orNothing (char ':' >> munch (/='@'))+ return (u,p)++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++orNothing :: ReadP a -> ReadP (Maybe a)+orNothing p = fmap Just p <++ return Nothing++-----------------------------------------------------------------+------------------ HTTP Messages --------------------------------+-----------------------------------------------------------------+++-- Protocol version+httpVersion :: String+httpVersion = "HTTP/1.1"+++-- | The HTTP request method, to be used in the 'Request' object.+-- We are missing a few of the stranger methods, but these are+-- not really necessary until we add full TLS.+data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE+ deriving(Show,Eq)++rqMethodMap :: [(String, RequestMethod)]+rqMethodMap = [("HEAD", HEAD),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST),+ ("DELETE", DELETE),+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE)]++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request =+ Request { rqURI :: URI -- ^ might need changing in future+ -- 1) to support '*' uri in OPTIONS request+ -- 2) transparent support for both relative+ -- & absolute uris, although this should+ -- already work (leave scheme & host parts empty).+ , rqMethod :: RequestMethod + , rqHeaders :: [Header]+ , rqBody :: String+ }++++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show Request where+ show (Request u m h _) =+ show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf+ ++ foldr (++) [] (map show h) ++ crlf+ where+ alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u++instance HasHeaders Request where+ getHeaders = rqHeaders+ setHeaders rq hdrs = rq { rqHeaders=hdrs }++type ResponseCode = (Int,Int,Int)+type ResponseData = (ResponseCode,String,[Header])+type RequestData = (RequestMethod,URI,[Header])++data ResponseBody+ = FileBody Integer{-size-} FilePath+ | StringRespBody String++-- | An HTTP Response.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output, additionally the output will+-- show an HTTP version of 1.1 instead of the actual version returned+-- by a server.+data Response =+ Response { rspCode :: ResponseCode+ , rspReason :: String+ , rspHeaders :: [Header]+ , rspBody :: ResponseBody+ }+ +-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1+instance Show Response where+ show (Response (a,b,c) reason headers _) =+ httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf+ ++ foldr (++) [] (map show headers) ++ crlf++instance HasHeaders Response where+ getHeaders = rspHeaders+ setHeaders rsp hdrs = rsp { rspHeaders=hdrs }+++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++-- Parsing a request+parseRequestHead :: [String] -> Result RequestData+parseRequestHead [] = Left ErrorClosed+parseRequestHead (com:hdrs) =+ requestCommand com `bindE` \(version,rqm,uri) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (rqm,uri,hdrs')+ where+ requestCommand line+ = case words line of+ yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of+ (Just u, Just r) -> Right (version,r,u)+ _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line)+ no -> if null line+ then Left ErrorClosed+ else Left (ErrorParse $ "Request command line parse failure: " ++ line) ++-- Parsing a response+parseResponseHead :: [String] -> Result ResponseData+parseResponseHead [] = Left ErrorClosed+parseResponseHead (sts:hdrs) = + responseStatus sts `bindE` \(version,code,reason) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (code,reason,hdrs')+ where++ responseStatus line+ = case words line of+ yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)+ no -> if null line + then Left ErrorClosed -- an assumption+ else Left (ErrorParse $ "Response status line parse failure: " ++ line)+++ match [a,b,c] = (digitToInt a,+ digitToInt b,+ digitToInt c)+ match _ = (-1,-1,-1) -- will create appropriate behaviour+++ ++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data Behaviour = Continue+ | Retry+ | Done+ | ExpectEntity+ | DieHorribly String++matchResponse :: RequestMethod -> ResponseCode -> Behaviour+matchResponse rqst rsp =+ case rsp of+ (1,0,0) -> Continue+ (1,0,1) -> Done -- upgrade to TLS+ (1,_,_) -> Continue -- default+ (2,0,4) -> Done+ (2,0,5) -> Done+ (2,_,_) -> ans+ (3,0,4) -> Done+ (3,0,5) -> Done+ (3,_,_) -> ans+ (4,1,7) -> Retry -- Expectation failed+ (4,_,_) -> ans+ (5,_,_) -> ans+ (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")+ where+ ans | rqst == HEAD = Done+ | otherwise = ExpectEntity+ ++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+-- Host Altered only if no Host header is supplied, HTTP\/1.1+-- requires a Host header.+-- Connection Where no allowance is made for persistant connections+-- the Connection header will be set to "close"+simpleHTTP :: Request -> IO (Result Response)+simpleHTTP r = + do + auth <- getAuth r+ c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+ simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ s r =+ do + auth <- getAuth r+ let r' = fixReq auth r + rsp <- if debug then do+ s' <- debugStream httpLogFile s+ sendHTTP s' r'+ else+ sendHTTP s r'+ -- already done by sendHTTP because of "Connection: close" header+ --; close s + return rsp+ where+ {- RFC 2616, section 5.1.2:+ "The most common form of Request-URI is that used to identify a+ resource on an origin server or gateway. In this case the absolute+ path of the URI MUST be transmitted (see section 3.2.1, abs_path) as+ the Request-URI, and the network location of the URI (authority) MUST+ be transmitted in a Host header field." -}+ -- we assume that this is the case, so we take the host name from+ -- the Host header if there is one, otherwise from the request-URI.+ -- Then we make the request-URI an abs_path and make sure that there+ -- is a Host header.+ fixReq :: URIAuthority -> Request -> Request+ fixReq URIAuthority{host=h} r = + replaceHeader HdrConnection "close" $+ insertHeaderIfMissing HdrHost h $+ r { rqURI = (rqURI r){ uriScheme = "", + uriAuthority = Nothing } } ++getAuth :: Monad m => Request -> m URIAuthority+getAuth r = case parseURIAuthority auth of+ Just x -> return x + Nothing -> fail $ "Error parsing URI authority '"+ ++ auth ++ "'"+ where auth = case findHeader HdrHost r of+ Just h -> h+ Nothing -> uriToAuthorityString (rqURI r)++sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP conn rq = + do { let a_rq = fixHostHeader rq+ ; rsp <- Exception.catch (main a_rq)+ (\e -> do { close conn; throw e })+ ; let fn list = when (or $ map findConnClose list)+ (close conn)+ ; either (\_ -> fn [rqHeaders rq])+ (\r -> fn [rqHeaders rq,rspHeaders r])+ rsp+ ; return rsp+ }+ where +-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+ main :: Request -> IO (Result Response)+ main rqst =+ do + --let str = if null (rqBody rqst)+ -- then show rqst+ -- else show (insertHeader HdrExpect "100-continue" rqst)+ writeBlock conn (show rqst)+ -- write body immediately, don't wait for 100 CONTINUE+ writeBlock conn (rqBody rqst)+ rsp <- getResponseHead + switchResponse True False rsp rqst+ + -- reads and parses headers+ getResponseHead :: IO (Result ResponseData)+ getResponseHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseResponseHead+ }++ -- Hmmm, this could go bad if we keep getting "100 Continue"+ -- responses... Except this should never happen according+ -- to the RFC.+ switchResponse :: Bool {- allow retry? -}+ -> Bool {- is body sent? -}+ -> Result ResponseData+ -> Request+ -> IO (Result Response)+ + switchResponse _ _ (Left e) _ = return (Left e)+ -- retry on connreset?+ -- if we attempt to use the same socket then there is an excellent+ -- chance that the socket is not in a completely closed state.++ switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+ case matchResponse (rqMethod rqst) cd of+ Continue+ | not bdy_sent -> {- Time to send the body -}+ do { val <- writeBlock conn (rqBody rqst)+ ; case val of+ Left e -> return (Left e)+ Right _ ->+ do { rsp <- getResponseHead+ ; switchResponse allow_retry True rsp rqst+ }+ }+ | otherwise -> {- keep waiting -}+ do { rsp <- getResponseHead+ ; switchResponse allow_retry bdy_sent rsp rqst + }++ Retry -> {- Request with "Expect" header failed.+ Trouble is the request contains Expects+ other than "100-Continue" -}+ do { writeBlock conn (show rqst ++ rqBody rqst)+ ; rsp <- getResponseHead+ ; switchResponse False bdy_sent rsp rqst+ } + + Done ->+ return (Right $ Response cd rn hdrs (StringRespBody ""))++ DieHorribly str ->+ return $ Left $ ErrorParse ("Invalid response: " ++ str)++ ExpectEntity ->+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ in+ do { rslt <- case tc of+ Nothing -> + case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> hopefulTransfer conn ""+ Just x -> + case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) (StringRespBody bdy)) + }++ + -- Adds a Host header if one is NOT ALREADY PRESENT+ fixHostHeader :: Request -> Request+ fixHostHeader rq =+ let uri = rqURI rq+ host = uriToAuthorityString uri+ in insertHeaderIfMissing HdrHost host rq+ + -- Looks for a "Connection" header with the value "close".+ -- Returns True when this is found.+ findConnClose :: [Header] -> Bool+ findConnClose hdrs =+ case lookupHeader HdrConnection hdrs of+ Nothing -> False+ Just x -> map toLower (trim x) == "close"++-- This function duplicates old Network.URI.authority behaviour.+uriToAuthorityString :: URI -> String+uriToAuthorityString URI{uriAuthority=Nothing} = ""+uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua +++ uriRegName ua +++ uriPort ua++-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP conn = do rq <- getRequestHead+ processRequest rq + where+ -- reads and parses headers+ getRequestHead :: IO (Result RequestData)+ getRequestHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseRequestHead+ }+ + processRequest (Left e) = return $ Left e+ processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue.+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ rslt <- case tc of+ Nothing ->+ case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> return (Right ([], "")) -- hopefulTransfer ""+ Just x ->+ case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+++-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+ -- write body immediately, don't wait for 100 CONTINUE+ case rspBody rsp of + StringRespBody str -> writeBlock conn str+ FileBody _size filename -> writeBlockWithFile conn _size filename+ return ()++-- The following functions were in the where clause of sendHTTP, they have+-- been moved to global scope so other functions can access them. ++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))+linearTransfer conn n+ = do info <- readBlock conn n+ return $ info `bindE` \str -> Right ([],str)++-- | Used when nothing about data is known,+-- Unfortunately waiting for a socket closure+-- causes bad behaviour. Here we just+-- take data once and give up the rest.+hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))+hopefulTransfer conn str+ = readLine conn >>= + either (\v -> return $ Left v)+ (\more -> if null more + then return (Right ([],str)) + else hopefulTransfer conn (str++more))+-- | A necessary feature of HTTP\/1.1+-- Also the only transfer variety likely to+-- return any footers.+chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))+chunkedTransfer conn+ = chunkedTransferC conn 0 >>= \v ->+ return $ v `bindE` \(ftrs,count,info) ->+ let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info)++chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))+chunkedTransferC conn n+ = readLine conn >>= \v -> case v of+ Left e -> return (Left e)+ Right line ->+ let size = ( if null line+ then 0+ else case readHex line of+ (n,_):_ -> n+ _ -> 0+ )+ in if size == 0+ then do { rs <- readTillEmpty2 conn []+ ; return $+ rs `bindE` \strs ->+ parseHeaders strs `bindE` \ftrs ->+ Right (ftrs,n,"")+ }+ else do { some <- readBlock conn size+ ; readLine conn+ ; more <- chunkedTransferC conn (n+size)+ ; return $ + some `bindE` \cdata ->+ more `bindE` \(ftrs,m,mdata) -> + Right (ftrs,m,cdata++mdata) + } ++-- | Maybe in the future we will have a sensible thing+-- to do here, at that time we might want to change+-- the name.+uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))+uglyDeathTransfer conn+ = return $ Left $ ErrorParse "Unknown Transfer-Encoding"++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Stream s => s -> IO (Result [String])+readTillEmpty1 conn =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf+ then readTillEmpty1 conn+ else readTillEmpty2 conn [s]+ }++-- | Read lines until an empty line (CRLF),+-- also accepts a connection close as end of+-- input, which is not an HTTP\/1.1 compliant+-- thing to do - so probably indicates an+-- error condition.+readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])+readTillEmpty2 conn list =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf || null s+ then return (Right $ reverse (s:list))+ else readTillEmpty2 conn (s:list)+ }++ +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+ I had a quick look around but couldn't find any RFC about+ the encoding of data on the query string. I did find an+ IETF memo, however, so this is how I justify the urlEncode+ and urlDecode methods.++ Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)++ Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+ Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+ URI delims: "<" | ">" | "#" | "%" | <">+ Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+ <US-ASCII coded character 20 hexadecimal>+ Also unallowed: any non-us-ascii character++ Escape method: char -> '%' a b where a, b :: Hex digits+-}++urlEncode, urlDecode :: String -> String++{- commented by Rednucleous. since it is not handling spaces ok. +Replaced by implementation done in Network.CGI.Protocol.+See code in: http://haskell.org/ghc/docs/latest/html/libraries/cgi/src/Network-CGI-Protocol.html#urlDecode++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+ : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []+-}++-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding.+urlDecode = unEscapeString . replace '+' ' '++-- | Replaces all instances of a value in a list by another value.+replace :: Eq a =>+ a -- ^ Value to look for+ -> a -- ^ Value to replace it with+ -> [a] -- ^ Input list+ -> [a] -- ^ Output list+replace x y = map (\z -> if z == x then y else z)++{- ended modifications by rednucleous -}+++urlEncode (h:t) =+ let str = if reserved (ord h) then escape h else [h]+ in str ++ urlEncode t+ where+ reserved x+ | x >= ord 'a' && x <= ord 'z' = False+ | x >= ord 'A' && x <= ord 'Z' = False+ | x >= ord '0' && x <= ord '9' = False+ | x <= 0x20 || x >= 0x7F = True+ | otherwise = x `elem` map ord [';','/','?',':','@','&'+ ,'=','+',',','$','{','}'+ ,'|','\\','^','[',']','`'+ ,'<','>','#','%','"']+ -- wouldn't it be nice if the compiler+ -- optimised the above for us?++ escape x = + let y = ord x + in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []+ +++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars ((n,v):t) =+ let (same,diff) = partition ((==n) . fst) t+ in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+ ++ urlEncodeRest diff+ where urlEncodeRest [] = []+ urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []
+ Network/HTTP/RedHandler/HTTP_Fork/HTTP/Base64.hs view
@@ -0,0 +1,279 @@+-----------------------------------------------------------------------------+-- |+-- Module : Codec.Binary.Base64+-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002+-- License : BSD-style (see the file ReadMe.tex)+--+-- Maintainer : dominic.steinitz@blueyonder.co.uk+-- Stability : experimental+-- Portability : portable+--+-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Network.HTTP.RedHandler.HTTP_Fork.HTTP.Base64+ ( encode+ , decode+ , chop72+ , Octet+ ) where++{------------------------------------------------------------------------+This is what RFC2045 had to say:++6.8. Base64 Content-Transfer-Encoding++ The Base64 Content-Transfer-Encoding is designed to represent+ arbitrary sequences of octets in a form that need not be humanly+ readable. The encoding and decoding algorithms are simple, but the+ encoded data are consistently only about 33 percent larger than the+ unencoded data. This encoding is virtually identical to the one used+ in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.++ A 65-character subset of US-ASCII is used, enabling 6 bits to be+ represented per printable character. (The extra 65th character, "=",+ is used to signify a special processing function.)++ NOTE: This subset has the important property that it is represented+ identically in all versions of ISO 646, including US-ASCII, and all+ characters in the subset are also represented identically in all+ versions of EBCDIC. Other popular encodings, such as the encoding+ used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and+ the base85 encoding specified as part of Level 2 PostScript, do not+ share these properties, and thus do not fulfill the portability+ requirements a binary transport encoding for mail must meet.++ The encoding process represents 24-bit groups of input bits as output+ strings of 4 encoded characters. Proceeding from left to right, a+ 24-bit input group is formed by concatenating 3 8bit input groups.+ These 24 bits are then treated as 4 concatenated 6-bit groups, each+ of which is translated into a single digit in the base64 alphabet.+ When encoding a bit stream via the base64 encoding, the bit stream+ must be presumed to be ordered with the most-significant-bit first.+ That is, the first bit in the stream will be the high-order bit in+ the first 8bit byte, and the eighth bit will be the low-order bit in+ the first 8bit byte, and so on.++ Each 6-bit group is used as an index into an array of 64 printable+ characters. The character referenced by the index is placed in the+ output string. These characters, identified in Table 1, below, are+ selected so as to be universally representable, and the set excludes+ characters with particular significance to SMTP (e.g., ".", CR, LF)+ and to the multipart boundary delimiters defined in RFC 2046 (e.g.,+ "-").++++ Table 1: The Base64 Alphabet++ Value Encoding Value Encoding Value Encoding Value Encoding+ 0 A 17 R 34 i 51 z+ 1 B 18 S 35 j 52 0+ 2 C 19 T 36 k 53 1+ 3 D 20 U 37 l 54 2+ 4 E 21 V 38 m 55 3+ 5 F 22 W 39 n 56 4+ 6 G 23 X 40 o 57 5+ 7 H 24 Y 41 p 58 6+ 8 I 25 Z 42 q 59 7+ 9 J 26 a 43 r 60 8+ 10 K 27 b 44 s 61 9+ 11 L 28 c 45 t 62 ++ 12 M 29 d 46 u 63 /+ 13 N 30 e 47 v+ 14 O 31 f 48 w (pad) =+ 15 P 32 g 49 x+ 16 Q 33 h 50 y++ The encoded output stream must be represented in lines of no more+ than 76 characters each. All line breaks or other characters not+ found in Table 1 must be ignored by decoding software. In base64+ data, characters other than those in Table 1, line breaks, and other+ white space probably indicate a transmission error, about which a+ warning message or even a message rejection might be appropriate+ under some circumstances.++ Special processing is performed if fewer than 24 bits are available+ at the end of the data being encoded. A full encoding quantum is+ always completed at the end of a body. When fewer than 24 input bits+ are available in an input group, zero bits are added (on the right)+ to form an integral number of 6-bit groups. Padding at the end of+ the data is performed using the "=" character. Since all base64+ input is an integral number of octets, only the following cases can+ arise: (1) the final quantum of encoding input is an integral+ multiple of 24 bits; here, the final unit of encoded output will be+ an integral multiple of 4 characters with no "=" padding, (2) the+ final quantum of encoding input is exactly 8 bits; here, the final+ unit of encoded output will be two characters followed by two "="+ padding characters, or (3) the final quantum of encoding input is+ exactly 16 bits; here, the final unit of encoded output will be three+ characters followed by one "=" padding character.++ Because it is used only for padding at the end of the data, the+ occurrence of any "=" characters may be taken as evidence that the+ end of the data has been reached (without truncation in transit). No+ such assurance is possible, however, when the number of octets+ transmitted was a multiple of three and no "=" characters are+ present.++ Any characters outside of the base64 alphabet are to be ignored in+ base64-encoded data.++ Care must be taken to use the proper octets for line breaks if base64+ encoding is applied directly to text material that has not been+ converted to canonical form. In particular, text line breaks must be+ converted into CRLF sequences prior to base64 encoding. The+ important thing to note is that this may be done directly by the+ encoder rather than in a prior canonicalization step in some+ implementations.++ NOTE: There is no need to worry about quoting potential boundary+ delimiters within base64-encoded bodies within multipart entities+ because no hyphen characters are used in the base64 encoding.++----------------------------------------------------------------------------}++{-++The following properties should hold:++ decode . encode = id+ decode . chop72 . encode = id++I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,+the second variation corresponds better with the RFC above, but outside of+MIME applications might be undesireable.+++But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-}+++import Data.Array (Array, array, (!))+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Char (chr, ord)+import Data.Word (Word8)++type Octet = Word8++encodeArray :: Array Int Char+encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')+ , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')+ , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')+ , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')+ , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')+ , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')+ , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')+ , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')+ , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]+++-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)+-- clearly the upmost/leftmost 8 bits of the answer are 0.+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.+-- 0 represents a 4 :(+int4_char3 :: [Int] -> [Char]+int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)+ in (chr (n `shiftR` 16 .&. 0xff))+ : (chr (n `shiftR` 8 .&. 0xff))+ : (chr (n .&. 0xff)) : int4_char3 t++int4_char3 [a,b,c] =+ let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)+ in [ (chr (n `shiftR` 16 .&. 0xff))+ , (chr (n `shiftR` 8 .&. 0xff)) ]++int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12)+ in [ (chr (n `shiftR` 16 .&. 0xff)) ]++int4_char3 [] = [] +++++-- Convert triplets of characters to+-- 4 base64 integers. The last entries+-- in the list may not produce 4 integers,+-- a trailing 2 character group gives 3 integers,+-- while a trailing single character gives 2 integers.+char3_int4 :: [Char] -> [Int]+char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)+ in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t++char3_int4 [a,b]+ = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)+ in [ (n `shiftR` 18 .&. 0x3f)+ , (n `shiftR` 12 .&. 0x3f)+ , (n `shiftR` 6 .&. 0x3f) ]+ +char3_int4 [a]+ = let n = (ord a `shiftL` 16)+ in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]++char3_int4 [] = []+++-- Retrieve base64 char, given an array index integer in the range [0..63]+enc1 :: Int -> Char+enc1 ch = encodeArray!ch+++-- | Cut up a string into 72 char lines, each line terminated by CRLF.++chop72 :: String -> String+chop72 str = let (bgn,end) = splitAt 70 str+ in if null end then bgn else "\r\n" ++ chop72 end+++-- Pads a base64 code to a multiple of 4 characters, using the special+-- '=' character.+quadruplets :: [Char] -> [Char]+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t+quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit+quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit+quadruplets [] = [] -- 24bit tail unit+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++dcd :: String -> [Int]+dcd [] = []+dcd (h:t)+ | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t+ | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t+ | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t+ | h == '+' = 62 : dcd t+ | h == '/' = 63 : dcd t+ | h == '=' = [] -- terminate data stream+ | otherwise = dcd t+++-- Principal encoding and decoding functions.++encode :: [Octet] -> String+encode = enc . char3_int4 . (map (chr .fromIntegral))++{-+prop_base64 os =+ os == (f . g . h) os+ where types = (os :: [Word8])+ f = map (fromIntegral. ord)+ g = decode . encode+ h = map (chr . fromIntegral)+-}++decode :: String -> [Octet]+decode = (map (fromIntegral . ord)) . int4_char3 . dcd
+ Network/HTTP/RedHandler/HTTP_Fork/HTTP/Headers.hs view
@@ -0,0 +1,310 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Headers+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- License : BSD+-- +-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Made dependencies explicit in import statements.+-- - Removed false dependencies in import statements.+-- - Added missing type signatures.+-- - Created Network.HTTP.Headers from Network.HTTP modules.+--+-- See changes history and TODO list in Network.HTTP module.+--+-- * Header notes:+--+-- [@Host@]+-- Required by HTTP\/1.1, if not supplied as part+-- of a request a default Host value is extracted+-- from the request-uri.+-- +-- [@Connection@] +-- If this header is present in any request or+-- response, and it's value is "close", then+-- the current request\/response is the last +-- to be allowed on that connection.+-- +-- [@Expect@]+-- Should a request contain a body, an Expect+-- header will be added to the request. The added+-- header has the value \"100-continue\". After+-- a 417 \"Expectation Failed\" response the request+-- is attempted again without this added Expect+-- header.+-- +-- [@TransferEncoding,ContentLength,...@]+-- if request is inconsistent with any of these+-- header values then you may not receive any response+-- or will generate an error response (probably 4xx).+--+-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.HTTP.Headers+ ( HasHeaders(..)+ , Header(..)+ , HeaderName(..)+ , insertHeader+ , insertHeaderIfMissing+ , insertHeaders+ , retrieveHeaders+ , replaceHeader+ , findHeader+ , lookupHeader+ , parseHeaders+ ) where++import Data.Char (isSpace, toLower)+import Data.List (elemIndex)+import Network.HTTP.RedHandler.HTTP_Fork.Stream (Result, ConnError(ErrorParse))++-- remove leading and trailing whitespace.+trim :: String -> String+trim = let dropspace = dropWhile isSpace in+ reverse . dropspace . reverse . dropspace++-- Split a list into two parts, the delimiter occurs+-- at the head of the second list. Nothing is returned+-- when no occurance of the delimiter is found.+split :: Eq a => a -> [a] -> Maybe ([a],[a])+split delim list = case delim `elemIndex` list of+ Nothing -> Nothing+ Just x -> Just $ splitAt x list++crlf :: String+crlf = "\r\n"++-- | The Header data type pairs header names & values.+data Header = Header HeaderName String++instance Show Header where+ show (Header key value) = show key ++ ": " ++ value ++ crlf++-- | HTTP Header Name type:+-- Why include this at all? I have some reasons+-- 1) prevent spelling errors of header names,+-- 2) remind everyone of what headers are available,+-- 3) might speed up searches for specific headers.+--+-- Arguments against:+-- 1) makes customising header names laborious+-- 2) increases code volume.+--+data HeaderName = + -- Generic Headers --+ HdrCacheControl+ | HdrConnection+ | HdrDate+ | HdrPragma+ | HdrTransferEncoding + | HdrUpgrade + | HdrVia++ -- Request Headers --+ | HdrAccept+ | HdrAcceptCharset+ | HdrAcceptEncoding+ | HdrAcceptLanguage+ | HdrAuthorization+ | HdrCookie+ | HdrExpect+ | HdrFrom+ | HdrHost+ | HdrIfModifiedSince+ | HdrIfMatch+ | HdrIfNoneMatch+ | HdrIfRange+ | HdrIfUnmodifiedSince+ | HdrMaxForwards+ | HdrProxyAuthorization+ | HdrRange+ | HdrReferer+ | HdrUserAgent++ -- Response Headers+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate++ -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified++ -- Mime entity headers (for sub-parts)+ | HdrContentTransferEncoding++ -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.+ deriving(Eq)++-- Translation between header names and values,+-- good candidate for improvement.+headerMap :: [ (String,HeaderName) ]+headerMap + = [ ("Cache-Control" ,HdrCacheControl )+ , ("Connection" ,HdrConnection )+ , ("Date" ,HdrDate ) + , ("Pragma" ,HdrPragma )+ , ("Transfer-Encoding" ,HdrTransferEncoding ) + , ("Upgrade" ,HdrUpgrade ) + , ("Via" ,HdrVia )+ , ("Accept" ,HdrAccept )+ , ("Accept-Charset" ,HdrAcceptCharset )+ , ("Accept-Encoding" ,HdrAcceptEncoding )+ , ("Accept-Language" ,HdrAcceptLanguage )+ , ("Authorization" ,HdrAuthorization )+ , ("From" ,HdrFrom )+ , ("Host" ,HdrHost )+ , ("If-Modified-Since" ,HdrIfModifiedSince )+ , ("If-Match" ,HdrIfMatch )+ , ("If-None-Match" ,HdrIfNoneMatch )+ , ("If-Range" ,HdrIfRange ) + , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )+ , ("Max-Forwards" ,HdrMaxForwards )+ , ("Proxy-Authorization" ,HdrProxyAuthorization)+ , ("Range" ,HdrRange ) + , ("Referer" ,HdrReferer )+ , ("User-Agent" ,HdrUserAgent )+ , ("Age" ,HdrAge )+ , ("Location" ,HdrLocation )+ , ("Proxy-Authenticate" ,HdrProxyAuthenticate )+ , ("Public" ,HdrPublic )+ , ("Retry-After" ,HdrRetryAfter )+ , ("Server" ,HdrServer )+ , ("Vary" ,HdrVary )+ , ("Warning" ,HdrWarning )+ , ("WWW-Authenticate" ,HdrWWWAuthenticate )+ , ("Allow" ,HdrAllow )+ , ("Content-Base" ,HdrContentBase )+ , ("Content-Encoding" ,HdrContentEncoding )+ , ("Content-Language" ,HdrContentLanguage )+ , ("Content-Length" ,HdrContentLength )+ , ("Content-Location" ,HdrContentLocation )+ , ("Content-MD5" ,HdrContentMD5 )+ , ("Content-Range" ,HdrContentRange )+ , ("Content-Type" ,HdrContentType )+ , ("ETag" ,HdrETag )+ , ("Expires" ,HdrExpires )+ , ("Last-Modified" ,HdrLastModified )+ , ("Set-Cookie" ,HdrSetCookie )+ , ("Cookie" ,HdrCookie )+ , ("Expect" ,HdrExpect ) ]+++instance Show HeaderName where+ show (HdrCustom s) = s+ show x = case filter ((==x).snd) headerMap of+ [] -> error "headerMap incomplete"+ (h:_) -> fst h++-- | This class allows us to write generic header manipulation functions+-- for both 'Request' and 'Response' data types.+class HasHeaders x where+ getHeaders :: x -> [Header]+ setHeaders :: x -> [Header] -> x++-- Header manipulation functions+insertHeader, replaceHeader, insertHeaderIfMissing+ :: HasHeaders a => HeaderName -> String -> a -> a+++-- | Inserts a header with the given name and value.+-- Allows duplicate header names.+insertHeader name value x = setHeaders x newHeaders+ where+ newHeaders = (Header name value) : getHeaders x++-- | Adds the new header only if no previous header shares+-- the same name.+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+ where+ newHeaders list@(h@(Header n _): rest)+ | n == name = list+ | otherwise = h : newHeaders rest+ newHeaders [] = [Header name value]++-- | Removes old headers with duplicate name.+replaceHeader name value x = setHeaders x newHeaders+ where+ newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]+ +-- | Inserts multiple headers.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)++-- | Gets a list of headers with a particular 'HeaderName'.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+ where+ matchname (Header n _) | n == name = True+ matchname _ = False++-- | Lookup presence of specific HeaderName in a list of Headers+-- Returns the value from the first matching header.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t) | v == n = Just s+ | otherwise = lookupHeader v t+lookupHeader _ _ = Nothing++parseHeader :: String -> Result Header+parseHeader str =+ case split ':' str of+ Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)+ Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+ where+ fn k = case map snd $ filter (match k . fst) headerMap of+ [] -> (HdrCustom k)+ (h:_) -> h++ match :: String -> String -> Bool+ match s1 s2 = map toLower s1 == map toLower s2+ +parseHeaders :: [String] -> Result [Header]+parseHeaders =+ catRslts [] . map (parseHeader . clean) . joinExtended ""+ where+ -- Joins consecutive lines where the second line+ -- begins with ' ' or '\t'.+ joinExtended old (h : t)+ | not (null h) && (head h == ' ' || head h == '\t')+ = joinExtended (old ++ ' ' : tail h) t+ | otherwise = old : joinExtended h t+ joinExtended old [] = [old]++ clean [] = []+ clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+ | otherwise = h : clean t++ -- tollerant of errors? should parse+ -- errors here be reported or ignored?+ -- currently ignored.+ catRslts :: [a] -> [Result a] -> Result [a]+ catRslts list (h:t) = + case h of+ Left _ -> catRslts list t+ Right v -> catRslts (v:list) t+ catRslts list [] = Right $ reverse list
+ Network/HTTP/RedHandler/HTTP_Fork/Stream.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.Stream+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An library for creating abstract streams. Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Removed unnecessary import statements.+-- - Moved Debug code to StreamDebugger.hs+-- - Moved Socket-related code to StreamSocket.hs.+--+-- * Changes by Simon Foster:+-- - Split Network.HTTPmodule up into to separate+-- Network.[Stream,TCP,HTTP] modules+-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.Stream+ ( Stream(..)+ , ConnError(..)+ , Result+ , bindE+ ) where++data ConnError = ErrorReset + | ErrorClosed+ | ErrorParse String+ | ErrorMisc String+ deriving(Show,Eq)++bindE :: Result a -> (a -> Result b) -> Result b+bindE (Left e) _ = Left e+bindE (Right v) f = f v++-- | This is the type returned by many exported network functions.+type Result a = Either ConnError {- error -}+ a {- result -}++-- | Streams should make layering of TLS protocol easier in future,+-- they allow reading/writing to files etc for debugging,+-- they allow use of protocols other than TCP/IP+-- and they allow customisation.+--+-- Instances of this class should not trim+-- the input in any way, e.g. leave LF on line+-- endings etc. Unless that is exactly the behaviour+-- you want from your twisted instances ;)+class Stream x where + readLine :: x -> IO (Result String)+ readBlock :: x -> Int -> IO (Result String)+ writeBlock :: x -> String -> IO (Result ())+ writeBlockWithFile :: x -> Integer -> String -> IO (Result ())+ close :: x -> IO ()+
+ Network/HTTP/RedHandler/HTTP_Fork/StreamDebugger.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.StreamDebugger+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Created. Made minor formatting changes.+-- +-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.StreamDebugger+ ( StreamDebugger+ , debugStream+ ) where++import Network.HTTP.RedHandler.HTTP_Fork.Stream (Stream(..))+import System.IO+ ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile+ )++-- | Allows stream logging. Refer to 'debugStream' below.+data StreamDebugger x+ = Dbg Handle x++instance (Stream x) => Stream (StreamDebugger x) where+ readBlock (Dbg h x) n =+ do val <- readBlock x n+ hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+ return val+ readLine (Dbg h x) =+ do val <- readLine x+ hPutStrLn h ("readLine " ++ show val)+ return val+ writeBlock (Dbg h x) str =+ do val <- writeBlock x str+ hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+ return val+ close (Dbg h x) =+ do hPutStrLn h "closing..."+ hFlush h+ close x+ hPutStrLn h "...closed"+ hClose h++-- | Wraps a stream with logging I\/O.+-- The first argument is a filename which is opened in @AppendMode@.+debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)+debugStream file stream = + do h <- openFile file AppendMode+ hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")+ return (Dbg h stream)+
+ Network/HTTP/RedHandler/HTTP_Fork/StreamSocket.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.StreamSocket+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop.+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Made dependencies explicit in import statements.+-- - Removed false dependencies in import statements.+-- - Created separate module for instance Stream Socket.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- +-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.StreamSocket+ ( handleSocketError+ , myrecv+ ) where++import Network.HTTP.RedHandler.HTTP_Fork.Stream+ ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result+ )+import Network.Socket+ ( Socket, getSocketOption, shutdown, send, recv, sClose+ , ShutdownCmd(ShutdownBoth), SocketOption(SoError)+ )++import Control.Monad (liftM)+import Control.Exception as Exception (Exception, catch, throw)+import System.IO.Error (catch, isEOFError)++-- | Exception handler for socket operations.+handleSocketError :: Socket -> Exception -> IO (Result a)+handleSocketError sk e =+ do se <- getSocketOption sk SoError+ case se of+ 0 -> throw e+ 10054 -> return $ Left ErrorReset -- reset+ _ -> return $ Left $ ErrorMisc $ show se++instance Stream Socket where+ readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)+ where+ fn x = do { str <- myrecv sk x+ ; let len = length str+ ; if len < x+ then ( fn (x-len) >>= \more -> return (str++more) ) + else return str+ }++ -- Use of the following function is discouraged.+ -- The function reads in one character at a time, + -- which causes many calls to the kernel recv()+ -- hence causes many context switches.+ readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)+ where+ fn str =+ do { c <- myrecv sk 1 -- like eating through a straw.+ ; if null c || c == "\n"+ then return (reverse str++c)+ else fn (head c:str)+ }+ + writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)+ where+ fn [] = return ()+ fn x = send sk x >>= \i -> fn (drop i x)++ -- This slams closed the connection (which is considered rude for TCP\/IP)+ close sk = shutdown sk ShutdownBoth >> sClose sk++myrecv :: Socket -> Int -> IO String+myrecv sock len =+ let handler e = if isEOFError e then return [] else ioError e+ in System.IO.Error.catch (recv sock len) handler+
+ Network/HTTP/RedHandler/HTTP_Fork/TCP.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.TCP+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An easy access TCP library. Makes the use of TCP in Haskell much easier.+-- This was originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - Made dependencies explicit in import statements.+-- - Removed false dependencies from import statements.+-- - Removed unused exported functions.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- +-----------------------------------------------------------------------------+module Network.HTTP.RedHandler.HTTP_Fork.TCP+ ( Connection+ , openTCPPort+ , isConnectedTo+ ) where++import Network.BSD (getHostByName, hostAddresses)+import Network.Socket+ ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive, SoError)+ , SocketType(Stream), inet_addr, connect, sendTo+ , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive)+ , sClose, sIsConnected, setSocketOption, getSocketOption+ , socket, Family(AF_INET)+ )+import Network.HTTP.RedHandler.HTTP_Fork.Stream+ ( Stream(readBlock, readLine, writeBlock, close)+ , ConnError(ErrorMisc, ErrorReset, ErrorClosed)+ , bindE+ )+import Network.HTTP.RedHandler.HTTP_Fork.StreamSocket (myrecv, handleSocketError)++import Control.Exception as Exception (catch, throw)+import Data.List (elemIndex)+import Data.Char (toLower)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)++-----------------------------------------------------------------+------------------ TCP Connections ------------------------------+-----------------------------------------------------------------++-- | The 'Connection' newtype is a wrapper that allows us to make+-- connections an instance of the StreamIn\/Out classes, without ghc extensions.+-- While this looks sort of like a generic reference to the transport+-- layer it is actually TCP specific, which can be seen in the+-- implementation of the 'Stream Connection' instance.+newtype Connection = ConnRef {getRef :: IORef Conn}++data Conn = MkConn { connSock :: ! Socket+ , connAddr :: ! SockAddr + , connBffr :: ! String + , connHost :: String+ }+ | ConnClosed+ deriving(Eq)++-- | This function establishes a connection to a remote+-- host, it uses "getHostByName" which interrogates the+-- DNS system, hence may trigger a network connection.+--+-- Add a "persistant" option? Current persistant is default.+-- Use "Result" type for synchronous exception reporting?+openTCPPort :: String -> Int -> IO Connection+openTCPPort uri port = + do { s <- socket AF_INET Stream 6+ ; setSocketOption s KeepAlive 1+ ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers+ (\_ -> getHostByName uri >>= \host ->+ case hostAddresses host of+ [] -> return (error "no addresses in host entry")+ (h:_) -> return h)+ ; let a = SockAddrInet (toEnum port) host+ ; Exception.catch (connect s a) (\e -> sClose s >> throw e)+ ; v <- newIORef (MkConn s a [] uri)+ ; return (ConnRef v)+ }++instance Stream Connection where+ readBlock ref n = + readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr bfr hst)+ | length bfr >= n ->+ do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })+ ; return (Right $ take n bfr)+ }+ | otherwise ->+ do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+ ; more <- readBlock sk (n - length bfr)+ ; return $ case more of+ Left _ -> more+ Right s -> (Right $ bfr ++ s)+ }++ -- This function uses a buffer, at this time the buffer is just 1000 characters.+ -- (however many bytes this is is left to the user to decypher)+ readLine ref =+ readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr bfr _)+ | null bfr -> {- read in buffer -}+ do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !!+ -- ... since that call will loop.+ ; let len = length str+ ; if len == 0 {- indicates a closed connection -}+ then return (Right "")+ else modifyIORef (getRef ref) (\c -> c { connBffr=str })+ >> readLine ref -- recursion+ }+ | otherwise ->+ case elemIndex '\n' bfr of+ Nothing -> {- need recursion to finish line -}+ do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+ ; more <- readLine ref -- contains extra recursion + ; return $ more `bindE` \str -> Right (bfr++str)+ }+ Just i -> {- end of line found -}+ let (bgn,end) = splitAt i bfr in+ do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })+ ; return (Right (bgn++['\n']))+ }++++ -- The 'Connection' object allows no outward buffering, + -- since in general messages are serialised in their entirety.+ writeBlock ref str =+ readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)+ where+ fn sk addr s+ | null s = return (Right ()) -- done+ | otherwise =+ getSocketOption sk SoError >>= \se ->+ if se == 0+ then sendTo sk s addr >>= \i -> fn sk addr (drop i s)+ else writeIORef (getRef ref) ConnClosed >>+ if se == 10054+ then return (Left ErrorReset)+ else return (Left $ ErrorMisc $ show se)+++ -- Closes a Connection. Connection will no longer+ -- allow any of the other Stream functions. Notice that a Connection may close+ -- at any time before a call to this function. This function is idempotent.+ -- (I think the behaviour here is TCP specific)+ close ref = + do { c <- readIORef (getRef ref)+ ; closeConn c `Exception.catch` (\_ -> return ())+ ; writeIORef (getRef ref) ConnClosed+ }+ where+ -- Be kind to peer & close gracefully.+ closeConn (ConnClosed) = return ()+ closeConn (MkConn sk addr [] _) =+ do { shutdown sk ShutdownSend+ ; suck ref+ ; shutdown sk ShutdownReceive+ ; sClose sk+ }++ suck :: Connection -> IO ()+ suck cn = readLine cn >>= + either (\_ -> return ()) -- catch errors & ignore+ (\x -> if null x then return () else suck cn)++-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> String -> IO Bool+isConnectedTo conn name =+ do { v <- readIORef (getRef conn)+ ; case v of+ ConnClosed -> return False+ (MkConn sk _ _ h) ->+ if (map toLower h == map toLower name)+ then sIsConnected sk+ else return False+ }+
+ Network/HTTP/RedHandler/Handler.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.HTTP.RedHandler.Handler where++import Network.HTTP.RedHandler.Utils (low)+import Network.URI (uriPath)+import Text.XHtml.Strict+import Maybe (fromMaybe)+import Control.Monad (MonadPlus, mzero, mplus, msum)+import Control.Monad.Trans (lift)+import Control.Monad.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Reader++import Network.HTTP.RedHandler.HTTP_Fork.HTTP (RequestMethod(..), rqMethod, Response, rqURI, rqHeaders, rqBody)+import Network.HTTP.RedHandler.FileUtils (sendFileResponse)+import Network.HTTP.RedHandler.RequestContext+import Network.HTTP.RedHandler.Response++------------------------------------------------------------------+--------- MaybeT monad transformer instances and combinators -----+------------------------------------------------------------------+mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b+mapMaybeT f = MaybeT . f . runMaybeT++maybeToMonadPlus :: MonadPlus m => Maybe a -> m a+maybeToMonadPlus Nothing = mzero+maybeToMonadPlus (Just x) = return x++------------------------------------------------------------------+--------- RequestHandler monad transformer -----------------------+------------------------------------------------------------------++type IORqHandler = RqHandlerT IO++newtype RqHandlerT m a = RqHandlerT { unRqHandlerT :: ReaderT RequestContext (MaybeT m) a }+ deriving (Functor, Monad, MonadIO, MonadReader RequestContext, MonadPlus) --, MonadTrans)++instance MonadTrans RqHandlerT where+ lift = RqHandlerT . lift . lift++runRqHandlerT :: RqHandlerT m a -> RequestContext -> m (Maybe a)+runRqHandlerT han = runMaybeT . runReaderT (unRqHandlerT han)+++mapRqHandlerT :: (m (Maybe a) -> n (Maybe b)) -> RqHandlerT m a -> RqHandlerT n b+mapRqHandlerT f = RqHandlerT . mapReaderT (mapMaybeT f) . unRqHandlerT+++--------------------------------------------+--------- RqHandlerT combinators -----------+--------------------------------------------++notMe :: Monad m => RqHandlerT m a+notMe = mzero++anyOf :: Monad m => [RqHandlerT m a] -> RqHandlerT m a+anyOf = msum++ifReq :: Monad m => (RequestContext -> Bool) -> RqHandlerT m a -> RqHandlerT m a -> RqHandlerT m a+ifReq test thenh elseh = ask >>= \req -> if (test req) then thenh else elseh+++underString :: Monad m => (String -> RqHandlerT m a) -> RqHandlerT m a+underString hanLambda = ask >>= \req -> case moveForwardDir req of+ Nothing -> notMe+ Just (req',d) -> local (\_->req') $ hanLambda d+++under :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a+under urlDirName han = underString (\s -> if s == low urlDirName then han else notMe)+++underInteger :: Monad m => (Integer -> RqHandlerT m a) -> RqHandlerT m a+underInteger hanLambda = underString hanStrLambda+ where+ hanStrLambda s = case maybeReads s of+ Nothing -> notMe+ Just ix -> hanLambda ix++reprocessLastDir :: Monad m => RqHandlerT m a -> RqHandlerT m a+reprocessLastDir han = ask >>= \req -> case moveBackwardDir req of+ Nothing -> notMe+ Just (req',_) -> local (\_->req') han++underNoDir :: Monad m => RqHandlerT m a -> RqHandlerT m a+underNoDir = filterReq (null . dirs)+++withDocName :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a+withDocName urlDocName han = underNoDir $ filterReq ((==urlDocName) . docName) han++withDocNameInteger :: Monad m => (Integer -> RqHandlerT m a) -> RqHandlerT m a+withDocNameInteger lam = underNoDir $ (withParam $ maybeReads . docName) lam++withDocNameString :: Monad m => (String -> RqHandlerT m a) -> RqHandlerT m a+withDocNameString lam = underNoDir $ (withParam $ Just . docName) lam++modReq :: Monad m => (RequestContext -> RequestContext) -> RqHandlerT m a -> RqHandlerT m a+modReq = local++modResp :: Monad m => (a -> b) -> RqHandlerT m a -> RqHandlerT m b+modResp = fmap++-- more Request Handler combinators+filterReq :: Monad m => (RequestContext -> Bool) -> RqHandlerT m a -> RqHandlerT m a+filterReq test han = ifReq test han notMe++sat :: Monad m => (RequestContext->a) -> (a->Bool) -> RqHandlerT m b -> RqHandlerT m b+sat tr test = filterReq (test . tr)++ifMethod :: Monad m => RequestMethod -> RqHandlerT m a -> RqHandlerT m a+ifMethod method = filterReq (\req -> (rqMethod . originalRequest $ req) == method)++formatEq :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a+formatEq fmt = filterReq (\req -> (format req) == fmt) ++formatHtml :: Monad m => RqHandlerT m a -> RqHandlerT m a+formatHtml = formatEq "html"++ifGet, ifPost :: Monad m => RqHandlerT m a -> RqHandlerT m a+ifGet = ifMethod GET+ifPost = ifMethod POST++eq :: (Eq a, Monad m) => (RequestContext->a) -> a -> RqHandlerT m b -> RqHandlerT m b+eq tr val = sat tr (==val)++failWith :: Monad m => RqHandlerT m a -> RqHandlerT m a -> RqHandlerT m a +failWith failh handl = handl `mplus` failh++-----------------------------------------------------------------+-- Handlers related to IO (running an IO, file sytestem, debug) -+-----------------------------------------------------------------++getResponse :: Monad m => RqHandlerT m BasicRsp -> RequestContext -> m Response+getResponse han req = liftM maybeBasicRspToResponse (runRqHandlerT han req)+++respWithStatic :: MonadIO m => String -> RqHandlerT m BasicRsp+respWithStatic filePath = fmap (uncurry fileRsp) $ liftIO (sendFileResponse filePath) >>= maybeToMonadPlus+++-- mapDir performs a get, applying the URL as relative to the pathString+-- it checks if the pathString exist and then appends it to the URI, in case it fails returns nothing.+mapDir :: MonadIO m => String -> RqHandlerT m BasicRsp+mapDir dirPath = do + filePath <- fmap ((dirPath ++) . pendingURIPath) ask+ liftIO $ putStrLn ("To send file: " ++ filePath)+ -- FIXME: comment last line for deployment+ respWithStatic filePath+++printString :: String -> IORqHandler ()+printString s = liftIO (putStrLn s)++printFullReq :: IORqHandler ()+printFullReq = ask >>= liftIO . print+++debug :: IORqHandler a -> IORqHandler a+debug rh = printString "--------" >> printFullReq >> rh++debugStr :: String -> IORqHandler a -> IORqHandler a+debugStr s rh = printString "--------" >> printString s >> printFullReq >> rh+++printReq :: IORqHandler a -> IORqHandler a+printReq rh = ask >>= printString . showShortReq >> rh+ where + showShortReq req = let o = originalRequest req+ in (show $ rqMethod o) ++ " " ++ (show $ rqURI o)+++-----------------------------------------------------+--------------------RequestContext-------------------+-----------------------------------------------------++withRequestDo :: Monad m => (RequestContext -> m a) -> RqHandlerT m a+withRequestDo rqlam = ask >>= lift . rqlam++withParam ::Monad m => (RequestContext-> Maybe a) -> (a-> RqHandlerT m b) -> RqHandlerT m b+withParam sel lam = ask >>= \req -> case sel req of+ Nothing -> notMe+ Just x -> lam x++maybeReads :: Read a => String -> Maybe a+maybeReads val = case reads val of+ [] -> Nothing+ (n,_):_ -> Just n++withQueryField :: Monad m => String -> (String-> RqHandlerT m a) -> RqHandlerT m a+withQueryField key = withParam $ (lookup key) . query ++withQuery :: Monad m => ([(String,String)] -> RqHandlerT m a) -> RqHandlerT m a+withQuery = withParam $ (Just . query)++-- forms+withPostField :: Monad m => String -> (String -> RqHandlerT m a) -> RqHandlerT m a+withPostField key = withParam $ lookup key . postFields ++withPostFields :: Monad m => ([(String,String)] -> RqHandlerT m a) -> RqHandlerT m a+withPostFields postFieldsLam = ask >>= postFieldsLam . postFields++withPostFieldFileName :: Monad m => String -> (Maybe String -> RqHandlerT m a) -> RqHandlerT m a+withPostFieldFileName field postFieldFileNameLam = ask >>= postFieldFileNameLam . postFieldFileName field++----------------------+-- examples ----------+----------------------+showReqHtml :: Monad m => RqHandlerT m Html+showReqHtml = fmap showReq ask++showReq :: RequestContext -> Html+showReq reqc =+ header << thetitle << "showing original request" + +++ body << (+ h2 << ("URI: " ++ show (rqURI req) ) +++ + h2 << ("Req Method: " ++ show (rqMethod req) ) +++ + h2 << ("Req Headers: ") +++ + concatHtml(map (\hdr -> (h3 << show hdr)) (rqHeaders req)) +++ + h2 << ("Req Body: " ++ show (rqBody req) ) ++++ showRqContext reqc+ )+ where+ showRqContext :: RequestContext -> Html + showRqContext reqc = h2 << ("Current request being processed: ") ++++ h3 << ("Dirs: " ++ show (dirs reqc)) ++++ h3 << ("Doc Name: " ++ docName reqc) ++++ h3 << ("Format: " ++ format reqc) ++++ h3 << ("Query: " ++ show (query reqc)) ++++ h3 << ("Form body inputs:" ++ show (formInputs reqc))+ req = originalRequest reqc+
+ Network/HTTP/RedHandler/Httpd.hs view
@@ -0,0 +1,107 @@+module Network.HTTP.RedHandler.Httpd+ (runHttpServer) where++import Control.Concurrent (ThreadId, forkIO)+import Control.Monad (forever, replicateM)+import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Result, receiveHTTP, respondHTTP, Request, Response, Stream, close, readLine, readBlock, writeBlock, writeBlockWithFile)+import Network+import System.IO+import Data.Array.IO+import Control.Exception as Exception++import Network.HTTP.RedHandler.RequestContext (RequestContext, mkRqCtx)+import Network.HTTP.RedHandler.Handler (IORqHandler, getResponse, anyOf)+import Network.HTTP.RedHandler.Response (BasicRsp)+++runHttpServer :: PortNumber -> [IORqHandler BasicRsp] -> IO ()+runHttpServer port hans = withSocketsDo $ do+ sock <- listenOn (PortNumber $ port)+ forever $ acceptConnection sock $ handleConnection hans+++handleConnection :: [IORqHandler BasicRsp] -> Handle -> IO ()+handleConnection rhans h = do requestCtx <- getRequestContext h+ response <- runRequestHandler (anyOf rhans) requestCtx+ responseSend h response+++getRequestContext :: Handle -> IO (Result RequestContext)+getRequestContext h = receiveHTTP h >>= mkRqCtx'+++mkRqCtx' :: Result Request-> IO (Result RequestContext)+mkRqCtx' (Left e) = return $ Left e+mkRqCtx' (Right rq) = fmap Right (mkRqCtx rq)++ +runRequestHandler :: IORqHandler BasicRsp -> Result RequestContext -> IO (Result Response)+runRequestHandler han (Left e) = return $ Left e+runRequestHandler han (Right rq) = fmap Right (getResponse han rq)++responseSend :: Handle -> Result Response -> IO ()+responseSend h rsp = either print (respondHTTP h) rsp >> close h++acceptConnection :: Socket -> (Handle -> IO ()) -> IO ThreadId+acceptConnection s k = accept s >>= \(h,_,_) -> forkIO $ k h+++instance Stream Handle where+ readLine h = hGetLine h >>= \l -> return $ Right $ l ++ "\n"+ readBlock h n = replicateM n (hGetChar h) >>= return . Right+ writeBlock h s = mapM_ (hPutChar h) s >>= return . Right+ writeBlockWithFile conn _ filename = sendFile conn filename >>= return . Right+ close = hClose++{- for debugging -}+{-+ readLine h = do l <- hGetLine h+ sniff_received l+ return $ Right $ l ++ "\n"++ readBlock h n = do s <- replicateM n (hGetChar h)+ sniff_received s+ return $ Right s++ writeBlock h s = sniff_sent s >> mapM_ (hPutChar h) s >>= return . Right+ writeBlockWithFile conn _size filename = sniff_sent ("file: " ++ filename) >> sendFile conn filename >>= return . Right)+ close = hClose+-}+++{-----------------------}+{- auxiliary functions -}+{-----------------------}++sendFile :: Handle -> String -> IO ()+sendFile conn filename = Exception.bracket+ (openFile filename ReadMode)+ hClose+ (\handle -> squirt handle conn >> hFlush conn)++-- squirt data from 'rd' into 'wr' as fast as possible. We use a 4k+-- single buffer.+squirt :: Handle -> Handle -> IO ()+squirt rd wr = do+ arr <- newArray_ (0, bufsize-1)+ let loop = do+ r <- hGetArray rd arr bufsize+ if (r == 0)+ then return ()+ else if (r < bufsize)+ then hPutArray wr arr r+ else hPutArray wr arr bufsize >> loop+ loop+ where+ bufsize = 4 * 1024 :: Int+++sniff_received = sniff . ("\n{{Received}}"++)+sniff_sent = sniff . ("\n{{Sent}}"++)++sniff :: String -> IO ()+sniff s = Exception.bracket+ (openFile "sniff.log" AppendMode)+ hClose+ (\hdl -> hPutStr hdl s)+
+ Network/HTTP/RedHandler/RequestContext.hs view
@@ -0,0 +1,183 @@+module Network.HTTP.RedHandler.RequestContext where++import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Request, HasHeaders, rqHeaders, rqURI, rqBody, rqMethod, lookupHeader, findHeader, getHeaders, setHeaders, HeaderName(..))+import Text.ParserCombinators.Parsec+import System.Time+import Data.List(intercalate)++import Network.HTTP.RedHandler.Utils (low, fst4, snd4, trd4, fourth4)++import qualified Data.ByteString.Lazy.Char8 as BS+import Network.CGI.Protocol (Input(..), decodeInput)+++data RequestContext = RequestContext {+ originalRequest :: Request,+ requestTime :: CalendarTime,+ dirs ::[String],+ docName :: String,+ format:: String,+ customQuery::[(String, String)],+ formInputs :: [(String,Input)],+ consumedDirs ::[String], -- in reverse order. The head is the last consumed dir+ restrictByParentQuery ::[(String, String)]+ } deriving Show++query :: RequestContext -> [(String,String)]+query rc = restrictByParentQuery rc ++ customQuery rc++moveForwardDir, moveBackwardDir :: RequestContext -> Maybe (RequestContext, String)+moveForwardDir rc = case dirs rc of+ [] -> Nothing+ (d:ds) -> Just (rc {dirs = ds, consumedDirs = d:consumedDirs rc}, d)+moveBackwardDir rc = case consumedDirs rc of+ [] -> Nothing+ (d:ds) -> Just (rc {consumedDirs = ds, dirs = d:dirs rc}, d)++completeDirs :: RequestContext -> [String]+completeDirs rc = reverse (consumedDirs rc) ++ dirs rc+++completeURL :: RequestContext -> String+completeURL rc = concat (map ("/"++) $ completeDirs rc) ++ "/" ++ docAndQuery+ where docAndQuery = docName rc ++ "." ++ format rc ++ renderQuery (customQuery rc)++pendingURIPath :: RequestContext -> String+pendingURIPath rc = concat (map (++"/") $ dirs rc) ++ docName rc ++ "." ++ format rc+++renderQuery :: [(String,String)] -> String+renderQuery [] = ""+renderQuery pairs = "?" ++ intercalate ";" (map (\(k,val) -> k ++ "=" ++ val) pairs)+++instance HasHeaders RequestContext where+ getHeaders = rqHeaders . originalRequest+ setHeaders rqc hdrs = rqc { originalRequest = (originalRequest rqc) {rqHeaders=hdrs} }+++mkRqCtx::Request-> IO RequestContext+mkRqCtx rq = do tm <- toCalendarTime =<< getClockTime+ let dcurl = case (parse parseURL "" $ (show $ rqURI rq)) of+ Left err -> ([], "index","html",[])+ Right x -> x+ return $ RequestContext rq tm (fst4 dcurl) (snd4 dcurl) (trd4 dcurl) (fourth4 dcurl) buildFormInputs [] []+ where+ buildFormInputs :: [(String,Input)]+ buildFormInputs = fst $ decodeInput cgiLibEnvVars (BS.pack $ rqBody rq)+ cgiLibEnvVars :: [(String,String)] -- ^ CGI environment variables.+ -- we are wrapping only "REQUEST_METHOD" and the headers "CONTENT_TYPE" and "CONTENT_LENGTH"+ -- Not including "QUERYSTRING", since we are only interested in getting inputs for the post for the moment+ cgiLibEnvVars = methodEnvVar ++ contentTypeEnvVar ++ contentLengthEnvVar+ methodEnvVar = [("REQUEST_METHOD", show $ rqMethod rq)]+ contentTypeEnvVar = case lookupHeader HdrContentType (rqHeaders rq) of+ Nothing -> []+ Just v -> [("CONTENT_TYPE",v)]++ contentLengthEnvVar = case lookupHeader HdrContentLength (rqHeaders rq) of+ Nothing -> []+ Just v -> [("CONTENT_LENGTH",v)]+++parseURL = do skipMany $ char '/'+ _dirs <- try $ many $ try parseDir+ _doc <- try $ many $noneOf ".?"+ skipMany $ char '.'+ _format <- try $ many $ noneOf "?"+ q <- try parseQuery+ return (_dirs, + _doc `orIfEmpty` "index", + (low _format) `orIfEmpty` "html",+ q)++parseDir = do name <- many1 $ noneOf "?/"+ char '/'+ return $ low name++parseQuery = do skipMany $ char '?'+ pair `sepBy` char ';'+ where pair = do key <- many1 (alphaNum <|> char '_')+ char '='+ val <- many1 (noneOf ";")+ return ( key,val)++orIfEmpty :: [a]->[a] ->[a]+orIfEmpty [] xs = xs+orIfEmpty ys _ = ys++----++-- cookies and forms++hasCookie:: String -> RequestContext -> Bool+hasCookie str req = case findHeader HdrCookie req of+ Just str->True+ _ ->False++postFields :: RequestContext -> [(String,String)]+postFields rq = [ (n, BS.unpack (inputValue i)) | (n,i) <- formInputs rq ]++postFieldFileName :: String -> RequestContext -> Maybe String+postFieldFileName fieldname rq = lookup fieldname (formInputs rq) >>= inputFilename+++postField:: String -> RequestContext -> String+postField field req = case lookup field $ postFields req of+ Nothing -> ""+ Just s -> s +++---testing parsing, does not belng here++run :: Show a => Parser a -> String -> IO ()+run pars input+ = case (parse pars "" input) of+ Left err -> do{ putStr "parse error at "+ ; print err+ }+ Right x -> print (input++": "++show x)+++showParses :: Show a => Parser a -> [String] -> IO ()+showParses pars strs = sequence_ $ map (run pars) strs++tup = showParses parseURL ["/my/folder/index?foo=bar",+ "/my/folder/index.html?foo=bar",+ "/my/folder/index.json"]+++-- helpers for building ReSTful links+-- The following functions should be used in combination +-- with completeURL to build ReSTful links+addResourceIdToCollAddr :: String -> RequestContext -> RequestContext --should be applied when completeDirs address a collection+addResourceIdToCollAddr keyString rc = rc {docName = keyString}++--should be applied when completeDirs address a collection+addMethodToCollAddr :: String -> RequestContext -> RequestContext+addMethodToCollAddr meth rc = rc {docName = meth}++addMethodNewToCollAddr = addMethodToCollAddr "new"++--should be applied when completeDirs address a resource+addMethodToResAddr :: String -> RequestContext -> RequestContext+addMethodToResAddr meth rc = rc {consumedDirs = docName rc : consumedDirs rc, docName = meth}++addMethodEditToResAddr = addMethodToResAddr "edit"+addMethodDeleteToResAddr = addMethodToResAddr "delete"++--should be applied when completeDirs address a resource+addHierarchicalCollToResAddr :: String -> [(String, String)] -> RequestContext -> RequestContext+addHierarchicalCollToResAddr resTypeName restrictionQuery rc+ = rc' {consumedDirs = resTypeName : docName rc : consumedDirs rc, docName = "index" }+ where+ rc' = upgradeQueriesForHierarchy restrictionQuery rc+--FIXME: hide query fields and others to enforce appropiate usage through narrow API++setCollectionFromRootAddr :: String -> RequestContext -> RequestContext+setCollectionFromRootAddr resTypeName rc+ = rc {consumedDirs = [resTypeName], docName = "index",+ restrictByParentQuery = [], customQuery = [] }++upgradeQueriesForHierarchy :: [(String, String)] -> RequestContext -> RequestContext+upgradeQueriesForHierarchy restrictionQuery rc = rc {restrictByParentQuery = restrictionQuery, customQuery = [] }+
+ Network/HTTP/RedHandler/Response.hs view
@@ -0,0 +1,75 @@+module Network.HTTP.RedHandler.Response where++import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Header(..), HasHeaders, getHeaders, setHeaders, insertHeaders,+ Response(..), ResponseBody(..), HeaderName(..))+import Control.Monad (liftM)++---------------------------------------------------------------+--------- Parametric Handler response type --------------------+---------------------------------------------------------------++data HandlerRsp a = HandlerRsp {+ hanRspHeaders :: [Header],+ hanRspBody :: Either Non200Response a+ }++data Non200Response = -- the 404 Not found response is not modeled here. The request handlers returns Nothing instead of a response if + -- it is a not found scenario.+ RedirectResp -- The redirect address is encoded on the headers+-- | ErrorResp ErrorResp+--data ErrorResp = ForbiddenResp | ...++instance Monad HandlerRsp where+ return x = HandlerRsp [] (Right x)+ (HandlerRsp hdrs (Right x)) >>= f = insertHeaders hdrs $ f x+ (HandlerRsp hdrs (Left non200resp)) >>= f = (HandlerRsp hdrs (Left non200resp))++instance Functor HandlerRsp where+ fmap = liftM++instance HasHeaders (HandlerRsp a) where+ getHeaders = hanRspHeaders+ setHeaders rsp hdrs = rsp { hanRspHeaders = hdrs }++non200response :: Non200Response -> Response+non200response _ = redirectResponse++okHTTPStrResponse :: String -> Response+okHTTPStrResponse s = Response (2,0,0) "" [] (StringRespBody s)++redirectResponse :: Response+redirectResponse = Response (3,0,2) "" [] (StringRespBody "")++redirectToRsp ::String -> HandlerRsp a+redirectToRsp url = HandlerRsp [Header HdrLocation url] (Left RedirectResp)++---------------------------------------------------------------+--------- Basic response type and combinators -----------------+---------------------------------------------------------------+type BasicRsp = HandlerRsp BasicRspBody++data BasicRspBody = FileResp Integer{-size-} FilePath+ | StrResp String++basicRspWith :: (a -> String) -> HandlerRsp a -> BasicRsp+basicRspWith f = fmap (StrResp . f)++fileRsp :: Integer -> FilePath -> BasicRsp+fileRsp i name = return (FileResp i name)++maybeBasicRspToResponse :: Maybe BasicRsp -> Response+maybeBasicRspToResponse Nothing = notFoundResponse+maybeBasicRspToResponse (Just rsp) = basicRspToResponse rsp++notFoundResponse :: Response+notFoundResponse = okHTTPStrResponse "File not found!"++basicRspToResponse :: BasicRsp -> Response+basicRspToResponse (HandlerRsp hrHeaders (Left resp)) = setHeaders (non200response resp) hrHeaders+basicRspToResponse (HandlerRsp hrHeaders (Right rspBd)) = setHeaders (basicRspBodyToResponse rspBd) hrHeaders++basicRspBodyToResponse :: BasicRspBody -> Response+basicRspBodyToResponse (StrResp s) = Response (2,0,0) "" [] (StringRespBody s)+basicRspBodyToResponse (FileResp i path) = Response (2,0,0) "" [] (FileBody i path)+--FIXME: set content-type headers for FileResp? (for instance for pictures)+
+ Network/HTTP/RedHandler/Session.hs view
@@ -0,0 +1,112 @@+module Network.HTTP.RedHandler.Session (+ SessionState,+ getSessionedStateWithCookie,+ newSessionedStateWithCookie,+ updateSessionedStateWithCookie,+ deleteSessionedStateWithCookie+) where++import System.IO.Unsafe (unsafePerformIO)+import System.Time+import qualified Data.Map as Map+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar+import Network.HTTP.RedHandler.HTTP_Fork.HTTP+import Network.CGI.Cookie(findCookie, newCookie, showCookie, deleteCookie)++----------------------------------------+-- session stuff -----------------------+----------------------------------------++type SessionMap a = TVar (Map.Map String a)+type SessionState = Integer++-- global session map+sessionMap :: SessionMap SessionState+sessionMap = unsafePerformIO $ newTVarIO $ Map.empty++addSession :: SessionState -> IO String --automatically (randomly) generates string+addSession x =+ do tok <- getNewToken+ updateSession tok x+ return tok+ where+ getNewToken = getClockTime >>= toCalendarTime >>= (return . show . ctPicosec) -- dirty random numbers++updateSession :: String -> SessionState -> IO ()+updateSession tok x =+ atomically (readTVar sessionMap+ >>= return . Map.insert tok x+ >>= writeTVar sessionMap)+++readSession :: String -> IO (Maybe SessionState)+readSession tok = atomically (readTVar sessionMap >>= return . Map.lookup tok)++deleteSession :: String -> IO ()+deleteSession tok = atomically (readTVar sessionMap+ >>= return . Map.delete tok+ >>= writeTVar sessionMap)+++-- just for testing+exportSessionMap :: IO [(String,SessionState)]+exportSessionMap = atomically (readTVar sessionMap) >>= return . Map.toList++----------------------------------------+-- cookies -----------------------------+----------------------------------------++lookupCookieValue :: HasHeaders a => String-> a-> Maybe String+lookupCookieValue cookname rq = do cookstr <- findHeader HdrCookie rq+ findCookie cookname cookstr+++setCookie :: HasHeaders a => String -> String -> a -> a+setCookie cookname cookvalue =+ insertHeaders [Header HdrSetCookie (showCookie $ newCookie cookname cookvalue)]++removeCookie :: HasHeaders a => String -> a -> a+removeCookie cookname =+ insertHeaders [Header HdrSetCookie (showCookie $ deleteCookie $ newCookie cookname "")]+++----------------------------------------+-- session and cookies -----------------+----------------------------------------++{- we assume that the cookies will expire when the user closes its browser, otherwise, we might need +some combinators to refresh the cookie -}++-- | search the cookie with the given name in the headers (request headers) and get the session id.+-- Then search the Session Map for the value+getSessionedStateWithCookie :: HasHeaders request => String -> request -> IO (Maybe SessionState)+getSessionedStateWithCookie cookieName req+ = case (lookupCookieValue cookieName req) of+ Nothing -> return Nothing+ Just tok -> readSession tok++-- | set the value in a new session.+-- Then set responses headers with the cookie.+newSessionedStateWithCookie :: HasHeaders response => String -> SessionState -> IO (response -> response)+newSessionedStateWithCookie cookieName st+ = do tok <- addSession st+ return $ setCookie cookieName tok++-- this is not going to be used. Just for testing+updateSessionedStateWithCookie :: HasHeaders request => String -> request -> SessionState -> IO ()+updateSessionedStateWithCookie cookieName req st+ = case lookupCookieValue cookieName req of+ Nothing -> return ()+ Just tok -> updateSession tok st++deleteSessionedStateWithCookie :: (HasHeaders request, HasHeaders response) => String -> request -> IO (response -> response)+deleteSessionedStateWithCookie cookieName req+ = do removeSession+ return $ removeCookie cookieName+ where+ removeSession :: IO ()+ removeSession = case lookupCookieValue cookieName req of+ Nothing -> return ()+ Just tok -> deleteSession tok+
+ Network/HTTP/RedHandler/Utils.hs view
@@ -0,0 +1,31 @@+module Network.HTTP.RedHandler.Utils where++import Data.Char(toLower)++-- map-like functions+mapFst f (x,y) = (f x, y)+mapSnd f (x,y) = (x, f y)++-- string conversion+low = map toLower++-- n tuples+fst3 (x,_,_) = x+snd3 (_,x,_) = x+trd3 (_,_,x) = x++fst4 (x,_,_,_) = x+snd4 (_,x,_,_) = x+trd4 (_,_,x,_) = x+fourth4 (_,_,_,x) = x++-- list processing+lookupByFun :: Eq a => (b->a) -> a -> [b] -> Maybe b+lookupByFun f a [] = Nothing+lookupByFun f a (b:bs) = if (f b == a) then Just b+ else lookupByFun f a bs+++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x
+ Setup.lhs view
@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+
+ redHandlers.cabal view
@@ -0,0 +1,35 @@+Name: redHandlers+Version: 0.1+Synopsis: Monadic HTTP request handlers combinators to build a standalone web apps.+Description: Monadic HTTP request handlers combinators to build a standalone web apps. Most of them deal with request data. + Some of them allow mapping part of the URL to public folders in the file system. There is also a combinator for + sending files efficiently in the response (a fork of the HTTP library was necessary for this, included here).+Category: Web+License: OtherLicense+License-file: LICENSE+Author: RedNucleus (see AUTHORS)+Maintainer: none+Stability: Experimental+Build-Type: Simple+Build-Depends: base < 4, cgi, network, stm, containers, old-time, bytestring, parsec, unix, MaybeT >= 0.1.2, mtl, haskell98, xhtml, array+Exposed-modules: Network.HTTP.RedHandler,+ Network.HTTP.RedHandler.Session+Other-modules: Network.HTTP.RedHandler.RequestContext,+ Network.HTTP.RedHandler.Handler,+ Network.HTTP.RedHandler.Response,+ Network.HTTP.RedHandler.Httpd,+ Network.HTTP.RedHandler.FileUtils,+ Network.HTTP.RedHandler.Utils,+ Network.HTTP.RedHandler.HTTP_Fork.HTTP,+ Network.HTTP.RedHandler.HTTP_Fork.TCP,+ Network.HTTP.RedHandler.HTTP_Fork.StreamSocket,+ Network.HTTP.RedHandler.HTTP_Fork.StreamDebugger,+ Network.HTTP.RedHandler.HTTP_Fork.Stream,+ Network.HTTP.RedHandler.HTTP_Fork.HTTP.Base64,+ Network.HTTP.RedHandler.HTTP_Fork.HTTP.Headers++Extra-source-files: AUTHORS,+ Example/README, Example/Makefile,+ Example/GridExample.hs, Example/HtmlExample.hs,+ Example/images/header.gif+