diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +2009.4.22 +--------- + +### Feature + +* more middleware: RawRouter, ContentType + 2009.4.21 ------------ diff --git a/hack.cabal b/hack.cabal --- a/hack.cabal +++ b/hack.cabal @@ -1,5 +1,5 @@ Name: hack -Version: 2009.4.21 +Version: 2009.4.22 Build-type: Simple Synopsis: a sexy Haskell Webserver Interface Description: a sexy Haskell Webserver Interface @@ -20,5 +20,7 @@ exposed-modules: Hack Hack.Handler.Kibro - Hack.SimpleRoute + 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,8 +1,8 @@ ## Hack: a sexy Haskell Webserver Interface -Hack is a lazy port of [Rack](http://rack.rubyforge.org/): the ruby 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 @@ -71,8 +71,16 @@ ### demo usage of middle-ware - import Hack.SimpleRoute + module Main where + + import Hack import Hack.Utils + import Hack.SimpleRoute + import Hack.Handler.Kibro + + import Data.Default + import MPS + import Prelude hiding ((.)) hello :: Application hello = \env -> def {body = env.show} .return @@ -93,3 +101,31 @@ Params -> Application -> Application just pass an applied middle-ware into a chain. + +finally the source code of SimpleRoute.hs: + + {-# LANGUAGE NoMonomorphismRestriction#-} + {-# LANGUAGE QuasiQuotes #-} + + module Hack.SimpleRoute where + + import Hack + import Hack.Utils + import List (find) + import Prelude hiding ((.), (^), (>)) + import MPS + + type RoutePath = (String, Application) + + route :: [RoutePath] -> Application -> Application + route h _ = \env -> + let path = env.path_info + script = env.script_name + mod_env location = env + { 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) diff --git a/src/Hack.hs b/src/Hack.hs --- a/src/Hack.hs +++ b/src/Hack.hs @@ -2,44 +2,44 @@ import Data.Default -data RequestMethod = - OPTIONS - | GET - | HEAD - | POST - | PUT - | DELETE - | TRACE - | CONNECT +data RequestMethod = + OPTIONS + | GET + | HEAD + | POST + | PUT + | DELETE + | TRACE + | CONNECT deriving (Show, Read, Eq) data Hack_UrlScheme = HTTP | HTTPS deriving (Show, Eq) type Map = [(String, String)] -data Env = Env { - request_method :: RequestMethod, - script_name :: String, - path_info :: String, - query_string :: String, - server_name :: String, - server_port :: Int, - http_ :: Map, - hack_version :: [Int], - hack_url_scheme :: Hack_UrlScheme, - hack_input :: String, - hack_errors :: String, - hack_multithread :: String, - hack_multiprocess :: String, - hack_run_once :: String, - custom :: Map +data Env = Env + { request_method :: RequestMethod + , script_name :: String + , path_info :: String + , query_string :: String + , server_name :: String + , server_port :: Int + , http_ :: Map + , hack_version :: [Int] + , hack_url_scheme :: Hack_UrlScheme + , hack_input :: String + , hack_errors :: String + , hack_multithread :: Bool + , hack_multiprocess :: Bool + , hack_run_once :: Bool + , custom :: Map } deriving (Show) -data Response = Response { - status :: Int, - headers :: Map, - body :: String +data Response = Response + { status :: Int + , headers :: Map + , body :: String } deriving (Show) @@ -49,14 +49,11 @@ instance Default Hack_UrlScheme where def = HTTP -instance Default Bool where - def = False - instance Default Response where def = Response def def def instance Default Env where - def = Env def def def def def def def def def def def def def def def + def = Env def def def def def def def def def def def False False False def type Application = Env -> IO Response diff --git a/src/Hack/Contrib/ContentType.hs b/src/Hack/Contrib/ContentType.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/ContentType.hs @@ -0,0 +1,19 @@ +module Hack.Contrib.ContentType where + +import Hack +import Hack.Utils +import Prelude hiding ((.), (^), (>)) +import MPS + +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 + + otherwise -> response .return diff --git a/src/Hack/Contrib/RawRouter.hs b/src/Hack/Contrib/RawRouter.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/RawRouter.hs @@ -0,0 +1,18 @@ +module Hack.Contrib.RawRouter where + +import Hack +import Hack.Utils +import List (find) +import Prelude hiding ((.), (^), (>)) +import MPS +import Data.Maybe (isJust) + +type RoutePath = (String, Application) + +route :: [RoutePath] -> MiddleWare +route h app = \env -> + let path = env.path_info + in + case h.find (fst > flip match path > isJust) of + Nothing -> app env + Just (_, found_app) -> found_app env diff --git a/src/Hack/Contrib/SimpleRouter.hs b/src/Hack/Contrib/SimpleRouter.hs new file mode 100644 --- /dev/null +++ b/src/Hack/Contrib/SimpleRouter.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} +{-# LANGUAGE QuasiQuotes #-} + +module Hack.Contrib.SimpleRouter where + +import Hack +import Hack.Utils +import List (find) +import Prelude hiding ((.), (^), (>)) +import MPS + +type RoutePath = (String, Application) + +route :: [RoutePath] -> MiddleWare +route h _ = \env -> + let path = env.path_info + script = env.script_name + mod_env location = env + { 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) 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,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction#-} -module Hack.Handler.Kibro where +module Hack.Handler.Kibro (run) where import Hack import Kibro @@ -22,12 +22,12 @@ def { request_method = request_method'.read - , script_name = script_name' - , path_info = path_info' - , query_string = query_string'.remove_question_mark - , server_name = server_name' - , server_port = server_port' - , hack_input = hack_input' + , script_name = script_name' + , path_info = path_info' + , query_string = query_string'.remove_question_mark + , server_name = server_name' + , server_port = server_port' + , hack_input = hack_input' } .return where @@ -42,4 +42,5 @@ response.status.show.setHeader "Status" response.body.output +run :: Application -> IO () run app = startKibro [("", handle app)] diff --git a/src/Hack/SimpleRoute.hs b/src/Hack/SimpleRoute.hs deleted file mode 100644 --- a/src/Hack/SimpleRoute.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction#-} -{-# LANGUAGE QuasiQuotes #-} - -module Hack.SimpleRoute where - -import Hack -import Hack.Utils -import List (find) -import Prelude hiding ((.), (^), (>)) -import MPS - -type RoutePath = (String, Application) - -route :: [RoutePath] -> Application -> Application -route h _ = \env -> - let path = env.path_info - script = env.script_name - mod_env location = env - { 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) diff --git a/src/Hack/Utils.hs b/src/Hack/Utils.hs --- a/src/Hack/Utils.hs +++ b/src/Hack/Utils.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NoMonomorphismRestriction#-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeSynonymInstances #-} module Hack.Utils where @@ -8,18 +8,27 @@ import Network.CGI hiding (Html) import Network.URI import Data.Default +import Data.Monoid import Prelude hiding ((.), (^), (>)) import MPS -import Control.Arrow ((>>>)) +import Control.Arrow ((>>>), (<<<)) (>) = (>>>) infixl 8 > - + +not_found :: String -> IO Response not_found x = return $ Response - { status = 404 - , headers = [("Content-Type", "text/plain")] - , body = x + { status = 404 + , headers = [("Content-Type", "text/plain")] + , body = x } empty_app :: Application empty_app = return def + +-- usage: app.use [content_type, cache] +use :: [MiddleWare] -> MiddleWare +use = reduce (<<<) + +not_found_app :: Application +not_found_app = \env -> not_found [$here|Not Found: #{env.path_info}|]