hack-handler-simpleserver (empty) → 0.0.0
raw patch · 7 files changed
+398/−0 lines, 7 filesdep +basedep +bytestringdep +data-defaultsetup-changed
Dependencies added: base, bytestring, data-default, hack, network, utf8-string, web-encodings
Files
- Data/ByteString/Lazy/Util.hs +89/−0
- Data/Mime/Header.hs +54/−0
- Data/String/Util.hs +55/−0
- Hack/Handler/SimpleServer.hs +141/−0
- LICENSE +25/−0
- Setup.lhs +7/−0
- hack-handler-simpleserver.cabal +27/−0
+ Data/ByteString/Lazy/Util.hs view
@@ -0,0 +1,89 @@+---------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,54 @@+---------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,55 @@+---------------------------------------------------------+-- |+-- 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
@@ -0,0 +1,141 @@+---------------------------------------------------------+-- |+-- Module : Hack.Handler.SimpleServer+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- A simplistic HTTP server handler for Hack.+--+---------------------------------------------------------+module Hack.Handler.SimpleServer+ ( run+ ) where++import Prelude ( ($), (++), map, IO, String, null, return+ , length, (==), fail, break, tail, Monad, Int+ , fromIntegral, head, (>=), fmap, (.), uncurry, words, show+ , Read, reads)++import Hack+import Data.Default++import Data.ByteString.Lazy.Util (takeUntilBlank)+import Data.Mime.Header (parseHeader, lookupHeader)+import Web.Encodings (decodeUrlPairs, decodeCookies, parsePost)++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.UTF8 as BSLU+import Network+ ( listenOn, accept, sClose, PortID(PortNumber), Socket+ , withSocketsDo)+import Control.Exception (bracket, finally)+import System.IO (Handle, hClose)+import Control.Concurrent+import Control.Monad (unless)+import Data.Maybe (isJust, fromJust, fromMaybe)++run :: Port -> Application -> IO ()+run port = withSocketsDo .+ bracket+ (listenOn $ PortNumber $ fromIntegral port)+ sClose .+ serveConnections port+type Port = Int++serveConnections :: Port -> Application -> Socket -> IO ()+serveConnections port app socket = do+ (conn, _, _) <- accept socket+ forkIO $ serveConnection port app conn+ serveConnections port app socket++serveConnection :: Port -> Application -> Handle -> IO ()+serveConnection port app conn =+ finally+ serveConnection'+ (hClose conn)+ where+ serveConnection' = do+ env <- hParseEnv port conn+ res <- app env+ sendResponse conn res++hParseEnv :: Port -> Handle -> IO Env+hParseEnv port conn = do+ content' <- BS.hGetContents conn+ let (headers, body) = takeUntilBlank content'+ parseEnv port headers body++safeRead :: Read a => a -> String -> a+safeRead d s =+ case reads s of+ ((x, _):_) -> x+ [] -> d++-- | 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+ ('/':x) -> x+ _ -> rpath'+ let heads = map parseHeader $ tail lines'+ let host' = lookupHeader "Host" heads+ unless (isJust host') $ fail "Invalid request (does not include host)"+ let host = fromJust host'+ let len = fromMaybe "0" $ lookupHeader "Content-Length" heads+ let body' = BS.take (safeRead 0 len) body+ return $ def+ { requestMethod = method+ , pathInfo = rpath+ , queryString = gets+ , serverName = host+ , serverPort = port+ , http = heads+ , hackInput = body'+ }++parseFirst :: Monad m =>+ String+ -> m (String, String, String)+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+ 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+{-+ 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+-}++sendResponse :: Handle -> Response -> IO ()+sendResponse conn = do+ BS.hPut conn . bsFromResponse
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2008, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 COPYRIGHT HOLDERS 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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ hack-handler-simpleserver.cabal view
@@ -0,0 +1,27 @@+name: hack-handler-simpleserver+version: 0.0.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+category: Web+stability: unstable+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+ exposed-modules: Hack.Handler.SimpleServer+ other-modules: Data.Mime.Header,+ Data.ByteString.Lazy.Util,+ Data.String.Util+ ghc-options: -Wall