diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2005-2008 Andy Gill +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Network/Shed/Httpd.hs b/Network/Shed/Httpd.hs new file mode 100644 --- /dev/null +++ b/Network/Shed/Httpd.hs @@ -0,0 +1,135 @@ +-- | +-- Module: Network.Shed.Httpd +-- Copyright: Andy Gill +-- License: BSD3 +-- +-- Maintainer: Andy Gill +-- Stability: unstable +-- Portability: GHC +-- +-- A trivial web server, original used in the cherry chess processor. +-- + +module Network.Shed.Httpd + ( Server + , initServer + , Request(..) + , Response(..) + , queryToArguments + ) where + +--import System.Posix +--import System.Posix.Signals +import Network.URI +import Network +import System.IO +import Control.Monad +import Control.Concurrent +import Control.Exception as Exc +import Control.Concurrent.Chan +import qualified Data.List as List +import qualified Data.Char as Char + +data Server = Server + +initServer + :: Int -- ^ The port number + -> (Request -> IO Response) -- ^ The functionality of the Sever + -> IO Server -- ^ A token for the Server +initServer portNo callOut = do +-- installHandler sigPIPE Ignore Nothing + chan <- newChan + sock <- listenOn (PortNumber $ fromIntegral portNo) + loopIO + (do (h,nm,port) <- accept sock + forkIO $ do + tid <- myThreadId + ln <- hGetLine h + case words ln of + [mode,uri,"HTTP/1.1"] -> + case parseURIReference uri of + Just uri' -> readHeaders h mode uri' [] + _ -> do print uri + hClose h + _ -> hClose h + return () + ) `finally` sClose sock + where + loopIO m = do m + loopIO m + + readHeaders h mode uri hds = 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)]) + _ -> hClose h -- strange format + + message code = show code ++ " " ++ + case lookup code longMessages of + Just msg -> msg + Nothing -> "-" + sendRequest h mode uri hds = do + resp <- callOut $ Request { reqMethod = mode + , reqURI = uri + , reqHeaders = hds + , reqBody = "" + } + hPutStr h $ "HTTP/1.1 " ++ message (resCode resp) ++ "\r\n" + hPutStr h $ "Connection: close\r\n" + sequence [ hPutStr h $ + hdr ++ ": " ++ val ++ "\r\n" + | (hdr,val) <- resHeaders resp + ] + hPutStr h $ "Content-Length: " ++ + show (length (resBody resp)) ++ "\r\n" + hPutStr h $ "\r\n" + hPutStr h $ (resBody resp) ++ "\r\n" + hClose h + +-- | Takes an escaped query, optionally starting with '?', and returns an unescaped index-value list. +queryToArguments :: String -> [(String,String)] +queryToArguments ('?':rest) = queryToArguments rest +queryToArguments input = findIx input + where + findIx = findIx' . span (/= '=') + findIx' (index,'=':rest) = findVal (unEscapeString index) rest + findIx' _ = [] + + findVal index = findVal' index . span (/= '&') + findVal' index (value,'&':rest) = (index,unEscapeString value) : findIx rest + findVal' index (value,[]) = [(index,unEscapeString value)] + findVal' _ _ = [] + +data Request = Request + { reqMethod :: String + , reqURI :: URI + , reqHeaders :: [(String,String)] + , reqBody :: String + } + deriving Show + +data Response = Response + { resCode :: Int + , resHeaders :: [(String,String)] + , resBody :: String + } + deriving Show + +addCache :: Int -> (String,String) +addCache n = ("Cache-Control","max-age=" ++ show n) + +noCache :: (String,String) +noCache = ("Cache-Control","no-cache") + +-- examples include "text/html" and "text/plain" + +contentType :: String -> (String,String) +contentType msg = ("Content-Type",msg) + +------------------------------------------------------------------------------ + +longMessages = + [ (200,"OK") + , (404,"Not Found") + ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/httpd-shed.cabal b/httpd-shed.cabal new file mode 100644 --- /dev/null +++ b/httpd-shed.cabal @@ -0,0 +1,24 @@ +Name: httpd-shed +Version: 0.2 +Cabal-Version: >= 1.2 +License: BSD3 +License-File: LICENSE +Author: Andy Gill +Category: Network, Web +Synopsis: A simple websever 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 +build-type: Simple + +Library + Build-Depends: base, network + Exposed-modules: + Network.Shed.Httpd + +Executable test + Main-Is: Main.hs + Hs-Source-Dirs: ., test + buildable: False diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +import Network.Shed.Httpd +import Network.URI + +main = do + initServer 8091 $ \ req -> do + print req + print $ uriQuery (reqURI req) + print $ queryToArguments (uriQuery (reqURI req)) + if uriPath (reqURI req) == "/" + then + return $ Response 200 [] "" + else do + str <- readFile ("." ++ uriPath (reqURI req)) + return $ Response 200 [] str + return ()