diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,23 @@ +2009.4.23 +--------- + +### Feature + +* more middleware + * ContentSize + * SimpleAccessLogger + +* request helper + 2009.4.22 --------- ### Feature -* more middleware: RawRouter, ContentType +* more middleware + * ContentType + * RawRouter + * SimpleRouter 2009.4.21 ------------ diff --git a/hack.cabal b/hack.cabal --- a/hack.cabal +++ b/hack.cabal @@ -1,8 +1,33 @@ Name: hack -Version: 2009.4.22 +Version: 2009.4.23 Build-type: Simple Synopsis: a sexy Haskell Webserver Interface -Description: a sexy Haskell Webserver Interface +Description: + + Hack: a sexy Haskell Webserver Interface + ======================================== + + + Hack is a brain-dead port of the brilliant Ruby Rack webserver interface. + + What does a Hack app look like + ------------------------------ + + + module Main where + + import Hack + import Hack.Handler.Kibro + + hello :: Application + hello = \env -> return $ Response + { status = 200 + , headers = [ ("Content-Type", "text/plain") ] + , body = "Hello World" + } + + main = run hello + License: GPL License-file: LICENSE Author: Wang, Jinjing @@ -15,12 +40,20 @@ library ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults - build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, mps >= 2009.4.21, kibro >= 0.4.3, data-default >= 0.2 + build-depends: base, cgi, network, haskell98, old-locale, old-time, directory, filepath, containers, mps >= 2009.4.21, kibro >= 0.4.3, data-default >= 0.2, ansi-wl-pprint, bytestring, template, unix hs-source-dirs: src/ exposed-modules: Hack + Hack.Utils + Hack.Request + Hack.Constants + Hack.Handler.Kibro + + Hack.Contrib.ContentSize + Hack.Contrib.Hub + Hack.Contrib.SimpleAccessLogger Hack.Contrib.SimpleRouter Hack.Contrib.RawRouter Hack.Contrib.ContentType - Hack.Utils + diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -1,9 +1,13 @@ -## Hack: a sexy Haskell Webserver Interface +Hack: a sexy Haskell Webserver Interface +======================================== + Hack is a brain-dead port of the brilliant Ruby [Rack](http://rack.rubyforge.org/) webserver interface. -### What does a Hack app look like +What does a Hack app look like +------------------------------ + module Main where import Hack @@ -18,17 +22,18 @@ main = run hello -### 1 minute tutorial +1 minute tutorial +----------------- -#### Install Hack +### Install Hack cabal install hack -#### Install Kibro (the only handler at the moment) +### Install Kibro (the only handler at the moment) cabal install kibro -#### Install lighttpd 1.4.19 (used by kibro) +### Install lighttpd 1.4.19 (used by kibro) wget http://www.lighttpd.net/download/lighttpd-1.4.19.tar.gz tar zxfv lighttpd-1.4.19.tar.gz @@ -37,16 +42,16 @@ make make install -#### Create a new Kibro project +### Create a new Kibro project kibro new hello-world -#### Test if Kibro works +### Test if Kibro works cd hello-world kibro start -#### Create our hack app +### Create a Hack app put the following code in `src/Main.hs` @@ -69,8 +74,11 @@ kibro restart -### demo usage of middle-ware +Middleware +----------- +### demo usage of middleware + module Main where import Hack @@ -90,42 +98,75 @@ main = run app -### make a middle-ware +### create a middleware inside Hack.hs: type MiddleWare = Application -> Application -since Haskell has curry, middle-ware api can be of type +since Haskell has curry, middleware api can be of type - Params -> Application -> Application + Anything -> Application -> Application -just pass an applied middle-ware into a chain. +just pass an applied middleware into a chain. finally the source code of SimpleRoute.hs: - {-# LANGUAGE NoMonomorphismRestriction#-} {-# LANGUAGE QuasiQuotes #-} - module Hack.SimpleRoute where + module Hack.Contrib.SimpleRouter where import Hack import Hack.Utils import List (find) import Prelude hiding ((.), (^), (>)) import MPS - + type RoutePath = (String, Application) - route :: [RoutePath] -> Application -> Application + route :: [RoutePath] -> MiddleWare route h _ = \env -> - let path = env.path_info - script = env.script_name + let path = env.path_info + script = env.script_name mod_env location = env - { script_name = script ++ location - , path_info = path.drop (location.length) + { script_name = script ++ location + , path_info = path.drop (location.length) } in case h.find (fst > flip starts_with path) of Nothing -> not_found [$here|Not Found: #{path}|] Just (location, app) -> app (mod_env location) + +### Use the middleware stack + +Rack provides a builder DSL, Hack just use a function. From `Utils.hs`: + + -- usage: app.use [content_type, cache] + use :: [MiddleWare] -> MiddleWare + use = reduce (<<<) + +Handlers +-------- + + +Just like Rack, once an application is written using Hack, it should work on any web server that provides a Hack handler. I'm only familiar with Kibro, so it became the first handler that's included. + +The handler should expose only one function of type: + + run :: Application -> IO () + +Spec + + +Hack spec = Rack spec :) + +Please read [The Rack interface specification](http://rack.rubyforge.org/doc/files/SPEC.html). + +Links +----- + +* [Rack](http://rack.rubyforge.org/ ) +* [Rack wiki](http://wiki.github.com/rack/rack) +* [Rack source](http://github.com/rack/rack/tree/master ) +* [rack-contrib source](http://github.com/rack/rack-contrib/tree/master) + diff --git a/src/Hack.hs b/src/Hack.hs --- a/src/Hack.hs +++ b/src/Hack.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeSynonymInstances #-} + module Hack where import Data.Default @@ -17,6 +19,14 @@ type Map = [(String, String)] +-- newtype HackErrors = HackErrors { unHackErrors :: String -> IO () } + +type Stream = String -> IO () +type HackErrors = Stream + +instance Show HackErrors where + show x = "HackHackErrors" + data Env = Env { request_method :: RequestMethod , script_name :: String @@ -24,11 +34,11 @@ , query_string :: String , server_name :: String , server_port :: Int - , http_ :: Map + , http :: Map , hack_version :: [Int] , hack_url_scheme :: Hack_UrlScheme , hack_input :: String - , hack_errors :: String + , hack_errors :: HackErrors , hack_multithread :: Bool , hack_multiprocess :: Bool , hack_run_once :: Bool @@ -52,8 +62,10 @@ instance Default Response where def = Response def def def +const_io = const (return ()) + instance Default Env where - def = Env def def def def def def def def def def def False False False def + def = Env def def def def def def def def def def const_io False False False def type Application = Env -> IO Response diff --git a/src/Hack/Constants.hs b/src/Hack/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Constants.hs @@ -0,0 +1,4 @@ +module Hack.Constants where + +status_with_no_entity_body :: [Int] +status_with_no_entity_body = [100 .. 199] ++ [204, 304] diff --git a/src/Hack/Contrib/ContentSize.hs b/src/Hack/Contrib/ContentSize.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/ContentSize.hs @@ -0,0 +1,23 @@ +module Hack.Contrib.ContentSize where + +import Hack +import Hack.Utils +import Prelude hiding ((.), (^), (>)) +import MPS +import Hack.Constants +import Data.Maybe (isNothing) + +content_size :: MiddleWare +content_size app = \env -> do + response <- app env + + if should_size response + then response.set_header "Content-Length" (response.body.bytesize.show) .return + else response .return + + where + should_size response = + [ response.header "Content-Length" .isNothing + , response.header "Transfer-Encoding" .isNothing + , not $ status_with_no_entity_body.has(response.status) + ] .and diff --git a/src/Hack/Contrib/ContentType.hs b/src/Hack/Contrib/ContentType.hs --- a/src/Hack/Contrib/ContentType.hs +++ b/src/Hack/Contrib/ContentType.hs @@ -8,12 +8,8 @@ content_type :: String -> MiddleWare content_type s app = \env -> do response <- app env - case response.headers - .filter (fst > is "Content-Type") - .reject (snd > empty) of - - [] -> response - { headers = response.headers ++ [("Content-Type", s)] } - .return - + + case response.header "Content-Type" of + Nothing -> response.set_header "Content-Type" s .return otherwise -> response .return + diff --git a/src/Hack/Contrib/Hub.hs b/src/Hack/Contrib/Hub.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/Hub.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- the entire logging framework is stole from [innate](http://github.com/manveru/innate/tree/master) + + +module Hack.Contrib.Hub where + +import Hack +import Hack.Utils +import Prelude hiding ((.), (^), (>), (+)) +import MPS +import Hack.Constants +import Text.Printf +import System.Posix.Process (getProcessID) +import System.Time +import Data.Maybe (fromMaybe, fromJust) +import Text.PrettyPrint.ANSI.Leijen + +data Severity = + Debug + | Info + | Warn + | Error + | Fatal + | Unknown + deriving (Show, Eq) + +hint :: Severity -> String +hint = show > slice 0 1 + +type Formatter = Severity -> CalendarTime -> Int -> String -> String -> String + +type Logger = String -> Severity -> IO () + +hub :: Stream -> Formatter -> String -> Logger +hub stream formatter program = \message severity -> + do + time <- now + pid <- getProcessID ^ from_i + stream $ formatter severity time pid program message + + + +simple_logger :: Maybe Stream -> Maybe Formatter -> String -> Env -> Logger +simple_logger l f program env = do + let stream = l.fromMaybe (env.hack_errors) + let formatter = f.fromMaybe simple_formatter + hub stream formatter program + +simple_formatter :: Formatter +simple_formatter severity time pid program message = + printf line_format h t pid l program s + where + time_format = "%Y-%m-%d %H:%M:%S" + line_format = "%s [%s $%d] %5s | %s: %s\n" + + h = severity.hint + t = time.format_time time_format + l = severity.show.upper + s = colorize severity message + +colorize :: Severity -> String -> String +colorize severity message = color severity (text message) .show + where + level_color = + [ ( Debug , blue ) + , ( Info , white ) + , ( Warn , yellow ) + , ( Error , red ) + , ( Fatal , red ) + , ( Unknown , green ) + ] + just_lookup s xs = xs.lookup s .fromJust + + color severity = level_color.lookup severity .fromMaybe green + diff --git a/src/Hack/Contrib/SimpleAccessLogger.hs b/src/Hack/Contrib/SimpleAccessLogger.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/SimpleAccessLogger.hs @@ -0,0 +1,14 @@ +module Hack.Contrib.SimpleAccessLogger where + +import Hack +import Hack.Utils +import Hack.Request +import Hack.Contrib.Hub +import Prelude hiding ((.), (^), (>)) +import MPS + +simple_access_logger :: Maybe Stream -> Maybe Formatter -> String -> MiddleWare +simple_access_logger stream formatter program app = \env -> do + let log = simple_logger stream formatter program env + Debug .log (env.url) + app env diff --git a/src/Hack/Contrib/SimpleRouter.hs b/src/Hack/Contrib/SimpleRouter.hs --- a/src/Hack/Contrib/SimpleRouter.hs +++ b/src/Hack/Contrib/SimpleRouter.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoMonomorphismRestriction#-} {-# LANGUAGE QuasiQuotes #-} module Hack.Contrib.SimpleRouter where diff --git a/src/Hack/Handler/Kibro.hs b/src/Hack/Handler/Kibro.hs --- a/src/Hack/Handler/Kibro.hs +++ b/src/Hack/Handler/Kibro.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoMonomorphismRestriction#-} - module Hack.Handler.Kibro (run) where import Hack @@ -9,6 +7,7 @@ import Data.Default import Prelude hiding ((.), (^)) import MPS +import System.IO get_env = do uri <- requestURI @@ -28,6 +27,7 @@ , server_name = server_name' , server_port = server_port' , hack_input = hack_input' + , hack_errors = hPutStr stderr } .return where diff --git a/src/Hack/Request.hs b/src/Hack/Request.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Request.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Hack.Request where + +import Hack +import Prelude hiding ((.), (^), (>), lookup, (+)) +import MPS +import Hack.Utils +import List (lookup) +import Data.Maybe (fromJust) + +body :: Env -> String +body = hack_input + +scheme :: Env -> String +scheme = hack_url_scheme > show > lower + +port :: Env -> Int +port = server_port + +path :: Env -> String +path env = env.script_name ++ env.path_info + +fullpath :: Env -> String +fullpath env = + if env.query_string.empty + then env.path + else env.path ++ "?" ++ env.query_string + +http_ :: String -> Env -> Maybe String +http_ s env = env.http.reverse.lookup s + +host :: Env -> String +host env = ( env.http_"HOST" + Just (env.server_name) ) .fromJust .gsub ":\\d+\\z" "" + +url :: Env -> String +url env = + [ env.scheme + , "://" + , env.host + , port_string + , env.fullpath + ] + .join' + where + port_string = + if (env.scheme.is "https" && env.port.is_not 443 || + env.scheme.is "http" && env.port.is_not 80 ) + then ":" ++ env.server_port.show + else "" diff --git a/src/Hack/Utils.hs b/src/Hack/Utils.hs --- a/src/Hack/Utils.hs +++ b/src/Hack/Utils.hs @@ -1,21 +1,28 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Hack.Utils where import Hack import Network.CGI hiding (Html) -import Network.URI +import Network.URI hiding (path) import Data.Default -import Data.Monoid -import Prelude hiding ((.), (^), (>)) +import Prelude hiding ((.), (^), (>), lookup, (+)) import MPS import Control.Arrow ((>>>), (<<<)) +import Data.Map (toList, lookup) +import System.Time +import System.Locale +import Text.Template +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Monad (mplus) (>) = (>>>) infixl 8 > +(+) = mplus +infixl 8 + + not_found :: String -> IO Response not_found x = return $ Response { status = 404 @@ -32,3 +39,27 @@ not_found_app :: Application not_found_app = \env -> not_found [$here|Not Found: #{env.path_info}|] + +header :: String -> Response -> Maybe String +header s r = r.headers.to_h.lookup s + +set_header :: String -> String -> Response -> Response +set_header k v r = r + { headers = (r.headers ++ [(k,v)] ) .to_h .toList } + +bytesize :: String -> Int +bytesize = u2b > length + +-- MPS candidate + +now :: IO CalendarTime +now = getClockTime >>= toCalendarTime + +format_time :: String -> CalendarTime -> String +format_time = formatCalendarTime defaultTimeLocale + +interpolate :: String -> [(String, String)] -> String +interpolate s params = B.unpack $ substitute (B.pack s) (context params) + where + context = map packPair > to_h + packPair (x, y) = (B.pack x, B.pack y)