diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2005-2008 Andy Gill +Copyright (c) 2005-2009 Andy Gill All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Network/Shed/Httpd.hs b/Network/Shed/Httpd.hs --- a/Network/Shed/Httpd.hs +++ b/Network/Shed/Httpd.hs @@ -14,13 +14,16 @@ -- into a local web server. The user can decide how to interpret -- the requests, and the library is intended for implementing Ajax APIs. -- --- initServerLazy (and assocated refactorings) was written by Henning Thielemann. --- +-- initServerLazy (and assocated refactorings), and Chunking support +-- was written by Henning Thielemann. +-- Handling of POST-based payloads was been written by Brandon Moore. +-- initServerBind support was written by John Van Enk. module Network.Shed.Httpd ( Server , initServer , initServerLazy + , initServerBind , Request(..) , Response(..) , queryToArguments @@ -40,8 +43,11 @@ import qualified Data.List as List import qualified Data.Char as Char import Numeric (showHex) +import qualified Network as N +import Network.BSD +import Network.Socket -type Server = () -- later, you might have a handle for shutting down a server. +type Server = () -- later, we might have a handle for shutting down a server. {- | This server transfers documents as one parcel, using the content-length header. @@ -49,11 +55,12 @@ initServer :: Int -- ^ The port number - -> (Request -> IO Response) -- ^ The functionality of the Sever + -> (Request -> IO Response) -- ^ The functionality of the Server -> IO Server -- ^ A token for the Server -initServer = +initServer port = initServerMain (\body -> ([("Content-Length", show (length body))], body)) + (SockAddrInet (fromIntegral port) iNADDR_ANY) {- | This server transfers documents in chunked mode @@ -64,36 +71,70 @@ initServerLazy :: Int -- ^ Chunk size -> Int -- ^ The port number - -> (Request -> IO Response) -- ^ The functionality of the Sever + -> (Request -> IO Response) -- ^ The functionality of the Server -> IO Server -- ^ A token for the Server -initServerLazy chunkSize = +initServerLazy chunkSize port = initServerMain (\body -> ([("Transfer-Encoding", "chunked")], - concatMap (\str -> showHex (length str) $ showString "\r\n" $ str) $ - slice chunkSize body ++ [[]])) + foldr ($) "" $ + map + (\str -> + showHex (length str) . showCRLF . + showString str . showCRLF) + (slice chunkSize body) ++ + -- terminating chunk + showString "0" . showCRLF : + -- terminating trailer + showCRLF : + [])) + (SockAddrInet (fromIntegral port) iNADDR_ANY) + +showCRLF :: ShowS +showCRLF = showString "\r\n" -- cf. Data.List.HT.sliceVertical slice :: Int -> [a] -> [[a]] slice n = map (take n) . takeWhile (not . null) . iterate (drop n) +{- | +This server transfers documents as one parcel, using the content-length header, +and takes an additional +-} +initServerBind + :: Int -- ^ The port number + -> HostAddress -- ^ The host address + -> (Request -> IO Response) -- ^ The functionality of the Server + -> IO Server -- ^ A token for the Server +initServerBind port addr = + initServerMain + (\body -> ([("Content-Length", show (length body))], body)) + (SockAddrInet (fromIntegral port) addr) + + initServerMain :: (String -> ([(String, String)], String)) - -> Int + -> SockAddr -> (Request -> IO Response) -> IO Server -initServerMain processBody portNo callOut = do +initServerMain processBody sockAddr callOut = do -- installHandler sigPIPE Ignore Nothing - sock <- listenOn (PortNumber $ fromIntegral portNo) +-- sock <- listenOn (PortNumber $ fromIntegral portNo) + num <- getProtocolNumber "tcp" + sock <- socket AF_INET Stream num + setSocketOption sock ReuseAddr 1 + bindSocket sock sockAddr + listen sock maxListenQueue + loopIO - (do (h,_nm,_port) <- accept sock - forkIO $ do + (do (h,_nm,_port) <- N.accept sock + forkIO $ do ln <- hGetLine h case words ln of - [mode,uri,"HTTP/1.1"] -> + [mode,uri,"HTTP/1.1"] -> case parseURIReference uri of - Just uri' -> readHeaders h mode uri' [] + Just uri' -> readHeaders h mode uri' [] Nothing _ -> do print uri hClose h _ -> hClose h @@ -103,22 +144,27 @@ loopIO m = do m loopIO m - readHeaders h mode uri hds = do + readHeaders h mode uri hds clen = do line <- hGetLine h case span (/= ':') line of - ("\r","") -> sendRequest h mode uri hds - (name,':':rest) -> readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)]) + ("\r","") -> sendRequest h mode uri hds clen + (name@"Content-Length",':':rest) -> + readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)]) (Just (read rest)) + (name,':':rest) -> readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)]) clen _ -> hClose h -- strange format message code = show code ++ " " ++ case lookup code longMessages of Just msg -> msg Nothing -> "-" - sendRequest h mode uri hds = do + sendRequest h mode uri hds clen = do + reqBody' <- case clen of + Just l -> fmap (take l) (hGetContents h) + Nothing -> return "" resp <- callOut $ Request { reqMethod = mode , reqURI = uri , reqHeaders = hds - , reqBody = "" + , reqBody = reqBody' } let (additionalHeaders, body) = processBody $ resBody resp diff --git a/httpd-shed.cabal b/httpd-shed.cabal --- a/httpd-shed.cabal +++ b/httpd-shed.cabal @@ -1,26 +1,29 @@ Name: httpd-shed -Version: 0.3 +Version: 0.4 Cabal-Version: >= 1.2 License: BSD3 License-File: LICENSE -Author: Andy Gill +Author: Andy Gill, Brandon Moore, Henning Thielemann, John Van Enk. Category: Network, Web Synopsis: A simple web-server with an interact style API Description: This web server promotes a Request to IO Response function into a local web server. The user can decide how to interpret the requests, and the library is intended for implementing Ajax APIs. + Maintainer: Andy Gill Copyright: (c) 2009 Andy Gill build-type: Simple Library - Build-Depends: base, network + Build-Depends: base >= 4.0 && < 5.0, network ghc-options: -Wall Exposed-modules: Network.Shed.Httpd -Executable test + +-- Trivial test; we need real tests! +Executable httpd-shed-test Main-Is: Main.hs Hs-Source-Dirs: ., test buildable: True