hack-handler-simpleserver 0.0.1 → 0.2.0
raw patch · 5 files changed
+98/−276 lines, 5 filesdep +failuredep −data-defaultdep −utf8-stringdep ~bytestringdep ~hackdep ~networkPVP ok
version bump matches the API change (PVP)
Dependencies added: failure
Dependencies removed: data-default, utf8-string
Dependency ranges changed: bytestring, hack, network, web-encodings
API changes (from Hackage documentation)
+ Hack.Handler.SimpleServer: instance Exception InvalidRequest
+ Hack.Handler.SimpleServer: instance Show InvalidRequest
+ Hack.Handler.SimpleServer: instance Typeable InvalidRequest
Files
- Data/ByteString/Lazy/Util.hs +0/−89
- Data/Mime/Header.hs +0/−54
- Data/String/Util.hs +0/−55
- Hack/Handler/SimpleServer.hs +89/−66
- hack-handler-simpleserver.cabal +9/−12
− Data/ByteString/Lazy/Util.hs
@@ -1,89 +0,0 @@------------------------------------------------------------- |--- Module : Data.ByteString.Lazy.Util--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Unstable--- Portability : portable------ Various utilities to assist in dealing with lazy bytestrings.---------------------------------------------------------------module Data.ByteString.Lazy.Util- ( ord- , stripPrefix- , breakAt- , breakAtString- , takeLine- , chompBS- , takeUntilBlank- ) where--import qualified Data.ByteString.Lazy as BS-import qualified Data.Char as C-import Data.Word (Word8)---- | Get the ASCII value of character. Differers from regular ord in that--- it returns an Integral, so it is automatically cast to eg a Word8.-ord :: Integral a => Char -> a-ord = fromInteger . toInteger . C.ord---- | Strip a prefix from a bytestring if it's there.-stripPrefix :: Word8 -> BS.ByteString -> BS.ByteString-stripPrefix p bs- | BS.null bs = bs- | BS.head bs == p = BS.tail bs- | otherwise = bs---- | Break a bytestring into two at the first occurence of the given 'Word8'.--- That 'Word8' should not appear in either piece.-breakAt :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString)-breakAt p bs =- let (x, y) = BS.span (/= p) bs- y' = stripPrefix p y- in (x, y')---- | Same as 'breakAt', but use a bytestring instead of a 'Word8'.-breakAtString :: BS.ByteString- -> BS.ByteString- -> (BS.ByteString, BS.ByteString)-breakAtString p c- | BS.null c = (BS.empty, BS.empty)- | p `BS.isPrefixOf` c = (BS.empty, BS.drop (BS.length p) c)- | otherwise =- let x = BS.head c- xs = BS.tail c- (next, rest) = breakAtString p xs- in (BS.cons' x next, rest)---- | Take a single line from a bytestring.-takeLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)-takeLine bs =- let (x, y) = BS.span (/= ord '\n') bs- x' = if not (BS.null x) && BS.last x == ord '\r' then BS.init x else x- y' = if not (BS.null y) && BS.head y == ord '\n' then BS.tail y else y- in (x', y')---- | Removes newline characters from the end of a string.-chompBS :: BS.ByteString -> BS.ByteString-chompBS s- | BS.null s = s- | BS.last s == ord '\n' =- if BS.length s == 1 || BS.last (BS.init s) /= ord '\r'- then BS.init s- else BS.init (BS.init s)- | BS.last s == ord '\r' = BS.init s- | otherwise = s---- | Take each line until the first blank line and return as first.--- The rest of the content is returned as second.-takeUntilBlank :: BS.ByteString -> ([BS.ByteString], BS.ByteString)-takeUntilBlank bs =- let (next, rest) = takeLine bs- in if BS.null next- then ([], rest)- else let (nexts, rest') = takeUntilBlank rest- in (next : nexts, rest')
− Data/Mime/Header.hs
@@ -1,54 +0,0 @@------------------------------------------------------------- |--- Module : Data.Mime.Header--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Unstable--- Portability : portable------ Functions for parsing MIME headers (Key: value; k1=v1; k2=v2)---------------------------------------------------------------module Data.Mime.Header- ( Header- , parseHeader- , lookupHeader- ) where--import qualified Data.ByteString.Lazy.UTF8 as BSLU-import Data.String.Util--type SMap = [(String, String)]---- | A single MIME header.-type Header = (String, String)---- | Parse a header line in the format--- Name: value; attkey=attval; attkey2=attval2.-parseHeader :: BSLU.ByteString -> Header-parseHeader bs =- let s = BSLU.toString bs- (k, rest) = span (/= ':') s- in (k, tail $ tail rest)--{--lookupHeaderAttr :: Monad m => String -> String -> [Header] -> m String-lookupHeaderAttr k1 k2 [] =- fail $ "Could not find header when looking for attr: " ++ - k1 ++ ":" ++ k2-lookupHeaderAttr k1 k2 ((key, _, vals):rest)- | k1 == key = case lookup k2 vals of- Nothing -> fail $ "Could not find header attr "- ++ k1 ++ ":" ++ k2- Just v -> return v- | otherwise = lookupHeaderAttr k1 k2 rest--}--lookupHeader :: Monad m => String -> [Header] -> m String-lookupHeader k [] = fail $ "Header " ++ k ++ " not found"-lookupHeader k ((key, val):rest)- | k == key = return val- | otherwise = lookupHeader k rest
− Data/String/Util.hs
@@ -1,55 +0,0 @@------------------------------------------------------------- |--- Module : Data.String.Util--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Unstable--- Portability : portable------ Various utilities to assist in dealing with Strings.---------------------------------------------------------------module Data.String.Util- ( chomp- , dropPrefix- , dropQuotes- , splitList- ) where--import Data.List (isPrefixOf)---- | Removes newline characters from the end of a string.-chomp :: String -> String-chomp s- | null s = s- | last s == '\n' =- if length s == 1 || last (init s) /= '\r'- then init s- else init (init s)- | last s == '\r' = init s- | otherwise = s---- | Drop a string from the beginning of another, if present.-dropPrefix :: Eq a => [a] -> [a] -> [a]-dropPrefix x y- | x `isPrefixOf` y = drop (length x) y- | otherwise = y---- | Drop surrounding quotes, if present.-dropQuotes :: String -> String-dropQuotes s- | length s > 2 && head s == '"' && last s == '"' = tail $ init s- | otherwise = s---- | Split up a list into sublists at every occurence of the split--- element. That element is thrown away.-splitList :: Eq a => a -> [a] -> [[a]]-splitList c s = helper s [[]] where- helper [] res = filter (not . null) $ reverse $ map reverse res- helper (x:xs) (y:ys)- | x == c = helper xs ([]:y:ys)- | otherwise = helper xs ((x:y):ys)- helper _ [] = error "This case should never be"
Hack/Handler/SimpleServer.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module : Hack.Handler.SimpleServer@@ -5,7 +7,7 @@ -- License : BSD3 -- -- Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Unstable+-- Stability : Stable -- Portability : portable -- -- A simplistic HTTP server handler for Hack.@@ -15,28 +17,28 @@ ( run ) where -import Prelude ( ($), map, IO, String, return- , length, (==), fail, break, tail, Monad, Int- , fromIntegral, head, (>=), (.), words, show- , Read, reads, dropWhile, takeWhile, (/=))- import Hack-import Data.Default+import qualified System.IO -import Data.ByteString.Lazy.Util (takeUntilBlank)-import Data.Mime.Header (parseHeader, lookupHeader)+import Web.Encodings.StringLike (takeUntilBlank)+import Web.Encodings.MimeHeader (parseHeader, lookupHeader) -import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.UTF8 as BSLU+import qualified Data.ByteString.Lazy as BL import Network ( listenOn, accept, sClose, PortID(PortNumber), Socket , withSocketsDo)-import Control.Exception (bracket, finally)+import Control.Exception (bracket, finally, Exception) import System.IO (Handle, hClose) import Control.Concurrent import Control.Monad (unless)-import Data.Maybe (isJust, fromJust, fromMaybe)+import Data.Maybe (isJust, fromJust) +import Control.Failure+import Data.Typeable (Typeable)++import Web.Encodings.StringLike (StringLike)+import qualified Web.Encodings.StringLike as SL+ run :: Port -> Application -> IO () run port = withSocketsDo . bracket@@ -47,26 +49,26 @@ serveConnections :: Port -> Application -> Socket -> IO () serveConnections port app socket = do- (conn, _, _) <- accept socket- forkIO $ serveConnection port app conn+ (conn, remoteHost', _) <- accept socket+ forkIO $ serveConnection port app conn remoteHost' serveConnections port app socket -serveConnection :: Port -> Application -> Handle -> IO ()-serveConnection port app conn =+serveConnection :: Port -> Application -> Handle -> String -> IO ()+serveConnection port app conn remoteHost' = finally serveConnection' (hClose conn) where serveConnection' = do- env <- hParseEnv port conn+ env <- hParseEnv port conn remoteHost' res <- app env sendResponse conn res -hParseEnv :: Port -> Handle -> IO Env-hParseEnv port conn = do- content' <- BS.hGetContents conn+hParseEnv :: Port -> Handle -> String -> IO Env+hParseEnv port conn remoteHost' = do+ content' <- BL.hGetContents conn let (headers', body') = takeUntilBlank content'- parseEnv port headers' body'+ parseEnv port headers' body' remoteHost' safeRead :: Read a => a -> String -> a safeRead d s =@@ -74,67 +76,88 @@ ((x, _):_) -> x [] -> d +data InvalidRequest =+ NotEnoughLines [String]+ | HostNotIncluded+ | BadFirstLine String+ | NonHttp11+ deriving (Show, Typeable)+instance Exception InvalidRequest+ -- | Parse a set of header lines and body into a 'Env'.-parseEnv :: Monad m => Port -> [BS.ByteString] -> BS.ByteString -> m Env-parseEnv port lines' body' = do- let lines = map BSLU.toString lines'- unless (length lines >= 2) $ fail "Invalid request (not enough lines)"- (method', rpath', gets) <- parseFirst $ head lines- let method = safeRead GET method'- let rpath = '/' : case rpath' of+parseEnv :: (MonadFailure InvalidRequest m)+ => Port+ -> [BL.ByteString]+ -> BL.ByteString+ -> String+ -> m Env+parseEnv port lines' body' remoteHost' = do+ case lines' of+ (_:_:_) -> return ()+ _ -> failure $ NotEnoughLines $ map SL.unpack lines'+ (method', rpath', gets) <- parseFirst $ head lines'+ let method = safeRead GET (SL.unpack method')+ let rpath = '/' : case SL.unpack rpath' of ('/':x) -> x- _ -> rpath'+ _ -> SL.unpack rpath' let heads = map parseHeader $ tail lines'- let host' = lookupHeader "Host" heads- unless (isJust host') $ fail "Invalid request (does not include host)"+ heads' = map (\(x, y, _) -> (SL.unpack x, SL.unpack y)) heads+ let host' = lookupHeader (SL.pack "Host") heads+ unless (isJust host') $ failure HostNotIncluded let host = fromJust host'- let len = fromMaybe "0" $ lookupHeader "Content-Length" heads- let body'' = BS.take (safeRead 0 len) body'- return $ def+ let len = maybe "0" SL.unpack+ $ lookupHeader (SL.pack "Content-Length") heads+ let body'' = BL.take (safeRead 0 len) body'+ let (serverName', _) = SL.breakChar ':' host+ return $ Env { requestMethod = method+ , scriptName = "" , pathInfo = rpath- , queryString = dropWhile (== '?') gets- , serverName = takeWhile (/= ':') host+ , queryString = SL.unpack gets+ , serverName = SL.unpack serverName' , serverPort = port- , http = heads+ , http = heads'+ , hackVersion = [2009, 10, 30]+ , hackUrlScheme = HTTP , hackInput = body''+ , hackErrors = System.IO.hPutStr System.IO.stderr+ , hackHeaders = []+ , hackCache = []+ , remoteHost = remoteHost' } -parseFirst :: Monad m =>- String- -> m (String, String, String)+parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>+ s+ -> m (s, s, s) parseFirst s = do- let pieces = words s- unless (length pieces == 3) $ fail "Invalid request (bad first line)"- let [method, query, http'] = pieces- unless (http' == "HTTP/1.1") $- fail "Invalid request (only handle HTTP/1.1)"- let (rpath, qstring) = break (== '?') query+ let pieces = SL.split ' ' s+ (method, query, http') <-+ case pieces of+ [x, y, z] -> return (x, y, z)+ _ -> failure $ BadFirstLine $ SL.unpack s+ unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11+ let (rpath, qstring) = SL.breakChar '?' query return (method, rpath, qstring) -bsFromResponse :: Response -> BS.ByteString-bsFromResponse res = BS.concat- [ f "HTTP/1.1 "- , f $ show $ status res- , f "\r\n"- , BS.concat $ map (\(x, y) -> BS.concat- [ f x- , f ": "- , f y- , f "\r\n"- ]) $ headers res- , f "\r\n"- , body res- ] where f = BSLU.fromString+sendResponse :: Handle -> Response -> IO ()+sendResponse h res = do+ BL.hPut h $ SL.pack "HTTP/1.1 "+ BL.hPut h $ SL.pack $ show $ status res+ BL.hPut h $ SL.pack "\r\n"+ mapM_ putHeader $ headers res+ BL.hPut h $ SL.pack "\r\n"+ BL.hPut h $ body res+ where+ putHeader (x, y) = do+ BL.hPut h $ SL.pack x+ BL.hPut h $ SL.pack ": "+ BL.hPut h $ SL.pack y+ BL.hPut h $ SL.pack "\r\n" {- hPutStr conn $ "HTTP/1.1 " ++ code res ++ "\r\n" hPutStr conn $ "Content-type: " ++ contentType res ++ "\r\n" let headers' = map (\(x, y) -> x ++ ": " ++ y ++ "\r\n") $ headers res hPutStr conn $ concat headers' hPutStr conn "\r\n"- BS.hPutStr conn $ content res+ BL.hPutStr conn $ content res -}--sendResponse :: Handle -> Response -> IO ()-sendResponse conn = do- BS.hPut conn . bsFromResponse
hack-handler-simpleserver.cabal view
@@ -1,27 +1,24 @@ name: hack-handler-simpleserver-version: 0.0.1+version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: A simplistic HTTP server handler for Hack.-description: FIXME+description: This should not be used in a production environment.+ However, it's useful for testing. category: Web-stability: unstable+stability: stable cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/hack-handler-simpleserver/tree/master library build-depends: base >= 4 && < 5,- network,- hack >= 2009.5.19,- utf8-string,- bytestring >= 0.9.1.4,- web-encodings,- data-default >= 0.2+ network >= 2.2.1.2 && < 2.3,+ hack == 2009.10.30,+ bytestring >= 0.9.1.4 && < 0.10,+ web-encodings >= 0.2.0 && < 0.3,+ failure >= 0.0.0 && < 0.1 exposed-modules: Hack.Handler.SimpleServer- other-modules: Data.Mime.Header,- Data.ByteString.Lazy.Util,- Data.String.Util ghc-options: -Wall