diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Tom Nielsen (tanielsen@gmail.com): Initital design and development. +Sergio Urinovsky (sergio.urinovsky@gmail.com): Design and lead developer. + diff --git a/Example/GridExample.hs b/Example/GridExample.hs new file mode 100644 --- /dev/null +++ b/Example/GridExample.hs @@ -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) + diff --git a/Example/HtmlExample.hs b/Example/HtmlExample.hs new file mode 100644 --- /dev/null +++ b/Example/HtmlExample.hs @@ -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 + diff --git a/Example/Makefile b/Example/Makefile new file mode 100644 --- /dev/null +++ b/Example/Makefile @@ -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 *~ diff --git a/Example/README b/Example/README new file mode 100644 --- /dev/null +++ b/Example/README @@ -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/. + + + + diff --git a/Example/images/header.gif b/Example/images/header.gif new file mode 100644 Binary files /dev/null and b/Example/images/header.gif differ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Network/HTTP/RedHandler.hs b/Network/HTTP/RedHandler.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler.hs @@ -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 diff --git a/Network/HTTP/RedHandler/FileUtils.hs b/Network/HTTP/RedHandler/FileUtils.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/FileUtils.hs @@ -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 + diff --git a/Network/HTTP/RedHandler/HTTP_Fork/HTTP.hs b/Network/HTTP/RedHandler/HTTP_Fork/HTTP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/HTTP.hs @@ -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 : +-- - 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: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" 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: + + 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 [] = [] diff --git a/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Base64.hs b/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Base64.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Base64.hs @@ -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 +-- and . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Headers.hs b/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/HTTP/Headers.hs @@ -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 : +-- - 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 diff --git a/Network/HTTP/RedHandler/HTTP_Fork/Stream.hs b/Network/HTTP/RedHandler/HTTP_Fork/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/Stream.hs @@ -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 : +-- - 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 () + diff --git a/Network/HTTP/RedHandler/HTTP_Fork/StreamDebugger.hs b/Network/HTTP/RedHandler/HTTP_Fork/StreamDebugger.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/StreamDebugger.hs @@ -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 : +-- - 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) + diff --git a/Network/HTTP/RedHandler/HTTP_Fork/StreamSocket.hs b/Network/HTTP/RedHandler/HTTP_Fork/StreamSocket.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/StreamSocket.hs @@ -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 : +-- - 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 + diff --git a/Network/HTTP/RedHandler/HTTP_Fork/TCP.hs b/Network/HTTP/RedHandler/HTTP_Fork/TCP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/HTTP_Fork/TCP.hs @@ -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 : +-- - 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 + } + diff --git a/Network/HTTP/RedHandler/Handler.hs b/Network/HTTP/RedHandler/Handler.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/Handler.hs @@ -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 + diff --git a/Network/HTTP/RedHandler/Httpd.hs b/Network/HTTP/RedHandler/Httpd.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/Httpd.hs @@ -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) + diff --git a/Network/HTTP/RedHandler/RequestContext.hs b/Network/HTTP/RedHandler/RequestContext.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/RequestContext.hs @@ -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 = [] } + diff --git a/Network/HTTP/RedHandler/Response.hs b/Network/HTTP/RedHandler/Response.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/Response.hs @@ -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) + diff --git a/Network/HTTP/RedHandler/Session.hs b/Network/HTTP/RedHandler/Session.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/Session.hs @@ -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 + diff --git a/Network/HTTP/RedHandler/Utils.hs b/Network/HTTP/RedHandler/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/RedHandler/Utils.hs @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple + +>main = defaultMain + diff --git a/redHandlers.cabal b/redHandlers.cabal new file mode 100644 --- /dev/null +++ b/redHandlers.cabal @@ -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 +