packages feed

httpd-shed (empty) → 0.2

raw patch · 5 files changed

+201/−0 lines, 5 filesdep +basedep +networksetup-changed

Dependencies added: base, network

Files

+ LICENSE view
@@ -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.+
+ Network/Shed/Httpd.hs view
@@ -0,0 +1,135 @@+-- |+-- Module: Network.Shed.Httpd +-- Copyright: Andy Gill+-- License: BSD3+--+-- Maintainer: Andy Gill <andygill@ku.edu>+-- 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")+    ]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ httpd-shed.cabal view
@@ -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
+ test/Main.hs view
@@ -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 [] "<root dir>"+                        else do+                          str <- readFile ("." ++ uriPath (reqURI req))+                          return $ Response 200 [] str+  return ()