diff --git a/miku.cabal b/miku.cabal --- a/miku.cabal +++ b/miku.cabal @@ -1,5 +1,5 @@ Name: miku -Version: 2011.6.11 +Version: 2011.6.12 Build-type: Simple Synopsis: A minimum web dev DSL in Haskell Description: @@ -13,18 +13,25 @@ Build-Depends: base Cabal-version: >= 1.2 category: Web -homepage: http://github.com/nfjinjing/miku +homepage: https://github.com/nfjinjing/miku data-files: readme.md, changelog.md, Nemesis, known-issues.md library - ghc-options: -Wall - build-depends: base > 4 && <= 5, data-default, hack2 >= 2009.7.15, hack2-contrib >= 2009.8.18, utf8-string, air >= 2011.6.11, air-extra >= 2011.6.11, mtl, containers, bytestring + build-depends: base > 4 && <= 5 + , data-default + , hack2 >= 2011.6.10 + , hack2-contrib >= 2011.6.10 + , utf8-string + , air >= 2011.6.11 + , mtl + , containers + , bytestring + hs-source-dirs: src/ exposed-modules: Network.Miku Network.Miku.Config Network.Miku.DSL Network.Miku.Engine - Network.Miku.Middleware.MikuRouter Network.Miku.Type Network.Miku.Utils diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -16,7 +16,7 @@ cabal update cabal install miku - cabal install hack2-handler-happstack + cabal install hack2-handler-happstack-server -- copy and paste the above example to myapp.hs @@ -38,7 +38,7 @@ import Prelude hiding ((-)) import Network.Miku - import Hack2.Handler.Happstack + import Hack2.Handler.HappstackServer main = run . miku - do @@ -59,8 +59,8 @@ get "/say/:user/:message" - do text . show =<< captures - -- /say/jinjing/hello will output - -- [("user","jinjing"),("message","hello")] + -- /say/miku/hello will output + -- [("user","miku"),("message","hello")] ## Static @@ -87,8 +87,6 @@ ### Use hack2 middleware - -- note both etag and lambda middleware are removed ... for somce ghc 7.0 compatability >< - import Hack2.Contrib.Middleware.SimpleAccessLogger middleware - simple_access_logger Nothing @@ -97,7 +95,7 @@ -- in Network.Miku.Engine - miku :: Unit -> Application + miku :: MikuMonad -> Application ## Hints diff --git a/src/Network/Miku/DSL.hs b/src/Network/Miku/DSL.hs --- a/src/Network/Miku/DSL.hs +++ b/src/Network/Miku/DSL.hs @@ -18,48 +18,50 @@ import qualified Control.Monad.State as State import Data.ByteString.Lazy.Char8 (ByteString) -app :: Application -> AppUnit -app f = ask >>= (f > io) >>= State.put +import Air.Data.Record.SimpleLabel hiding (get) +app :: Application -> AppMonad +app f = ask >>= (f > io) >>= State.put -router :: Router -> Unit -router = set_router > update +middleware :: Middleware -> MikuMonad +middleware x = modM __middlewares - insert_last x -get, put, post, delete :: ByteString -> AppUnit -> Unit +get, put, post, delete :: ByteString -> AppMonad -> MikuMonad get = add_route GET put = add_route PUT post = add_route POST delete = add_route DELETE -middleware :: Middleware -> Unit -middleware = add_middleware > update - -before :: (Env -> IO Env) -> Unit +add_route :: RequestMethod -> ByteString -> AppMonad -> MikuMonad +add_route route_method route_string app_monad = do + middleware - miku_router route_method route_string app_monad + +before :: (Env -> IO Env) -> MikuMonad before = ioconfig > middleware -after :: (Response -> IO Response) -> Unit +after :: (Response -> IO Response) -> MikuMonad after = censor > middleware -mime :: ByteString -> ByteString -> Unit -mime k v = add_mime k v .update +mime :: ByteString -> ByteString -> MikuMonad +mime k v = modM __mimes - insert_last (k,v) -public :: Maybe ByteString -> [ByteString] -> Unit +public :: Maybe ByteString -> [ByteString] -> MikuMonad public r xs = middleware - static r xs io :: (MonadIO m) => IO a -> m a io = liftIO -text :: ByteString -> AppUnit +text :: ByteString -> AppMonad text x = do update - set_content_type _TextPlain update - set_body x -html :: ByteString -> AppUnit +html :: ByteString -> AppMonad html x = do update - set_content_type _TextHtml update - set_body x -captures :: AppUnitT [(ByteString, ByteString)] +captures :: AppMonadT [(ByteString, ByteString)] captures = ask ^ namespace miku_captures diff --git a/src/Network/Miku/Engine.hs b/src/Network/Miku/Engine.hs --- a/src/Network/Miku/Engine.hs +++ b/src/Network/Miku/Engine.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + module Network.Miku.Engine where import Control.Monad.Reader hiding (join) @@ -9,50 +11,84 @@ import Hack2.Contrib.Middleware.UserMime import Hack2.Contrib.Middleware.NotFound import Hack2.Contrib.Utils hiding (get, put) -import Air.Env +import Air.Env hiding (mod) import Network.Miku.Config -import Network.Miku.Middleware.MikuRouter () import Network.Miku.Type import Network.Miku.Utils import Prelude () import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Prelude as P +import Air.Data.Record.SimpleLabel hiding (get) +import Data.Maybe -run_app :: AppUnit -> Application -run_app unit = \env -> runReaderT unit env .flip execStateT def {status = 200} -miku :: Unit -> Application -miku unit = run unit not_found_app - where - not_found_app = not_found dummy_app - run_route x = (x.router) miku_captures run_app (x.route_path) - - run :: Unit -> Middleware - run unit' = - let miku_state = execState unit' def - route_configs = miku_state.routes - route = route_configs.map run_route .use - mime_filter = user_mime (miku_state.mimes) - stack = miku_state.middlewares.use - pre = pre_installed_middlewares.use - in - use [pre, mime_filter, stack, route] -add_route_config :: RouteConfig -> Miku -> Miku -add_route_config r s = let xs = s.routes in s {routes = xs.insert_last r} -add_route :: RequestMethod -> ByteString -> AppUnit -> Unit -add_route r s u = do - c <- get ^ current_router - update - add_route_config RouteConfig { route_path = (r, s, u), router = c } - -set_router :: Router -> Miku -> Miku -set_router r x = x { current_router = r } +miku :: MikuMonad -> Application +miku miku_monad = miku_middleware miku_monad not_found_app + where + not_found_app = not_found dummy_app -add_middleware :: Middleware -> Miku -> Miku -add_middleware x s = - let xs = s.middlewares in s {middlewares = xs.insert_last x} + +miku_middleware :: MikuMonad -> Middleware +miku_middleware miku_monad = + + let miku_state = execState miku_monad def + mime_filter = user_mime (miku_state.mimes) + miku_middlewares = miku_state.middlewares.use + pre_installed_middleware = pre_installed_middlewares.use + in + + use [pre_installed_middleware, mime_filter, miku_middlewares] + -add_mime :: ByteString -> ByteString -> Miku -> Miku -add_mime k v s = let xs = s.mimes in s {mimes = xs.insert_last (k, v)} +miku_router :: RequestMethod -> ByteString -> AppMonad -> Middleware +miku_router route_method route_string app_monad app = \env -> + if env.request_method == route_method + then + case env.path_info.parse_params route_string of + Nothing -> app env + Just (_, params) -> + let miku_app = run_app - local (put_namespace miku_captures params) app_monad + in + miku_app env + + else + app env + + + where + + run_app :: AppMonad -> Application + run_app app_monad = \env -> runReaderT app_monad env .flip execStateT def {status = 200} + +parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)]) +parse_params "" "" = Just ("", []) +parse_params "" _ = Nothing +parse_params "/" "" = Nothing +parse_params "/" _ = Just ("/", []) +parse_params t s = + let template_tokens = t.B.split '/' + url_tokens = s.B.split '/' + in + if url_tokens.length P.< template_tokens.length + then Nothing + else + let rs = zipWith capture template_tokens url_tokens + in + if rs.all isJust + then + let token_length = template_tokens.length + location = B.pack - "/" / (B.unpack - url_tokens.take token_length .B.intercalate "/") + in + Just - (location, rs.catMaybes.catMaybes) + else Nothing + + where + capture x y + | x.B.unpack.starts_with ":" = Just - Just (x.B.tail, y) + | x == y = Just Nothing + | otherwise = Nothing diff --git a/src/Network/Miku/Middleware/MikuRouter.hs b/src/Network/Miku/Middleware/MikuRouter.hs deleted file mode 100644 --- a/src/Network/Miku/Middleware/MikuRouter.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Miku.Middleware.MikuRouter (miku_router) where - -import Data.Maybe -import Hack2 -import Hack2.Contrib.Utils -import Hack2.Contrib.Utils hiding (get, put) -import Air.Env -import Air.Extra -import Prelude () -import Data.ByteString.UTF8 (fromString) -import qualified Prelude as P -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) - -type RoutePathT a = (RequestMethod, ByteString, a) - - - -miku_router :: ByteString -> (a -> Application) -> RoutePathT a -> Middleware -miku_router prefix runner route_path app = \env -> - if route_path.match_route env.not - then app env - else do - let (_, template, app_state) = route_path - (_, params) = parse_params template (env.path_info) .fromJust - - runner app_state (env .merge_captured params) - where - match_route env' (method, template, _) = - env'.request_method.is method - && env'.path_info.parse_params template .isJust - - merge_captured params env' = - env'.put_namespace prefix params - - -parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)]) -parse_params "" "" = Just ("", []) -parse_params "" _ = Nothing -parse_params "/" "" = Nothing -parse_params "/" _ = Just ("/", []) - -parse_params t s = - let template_tokens = t.B.split '/' - url_tokens = s.B.split '/' - in - if url_tokens.length P.< template_tokens.length - then Nothing - else - let rs = zipWith capture template_tokens url_tokens - in - if rs.all isJust - then - let token_length = template_tokens.length - location = B.pack - "/" / (B.unpack - url_tokens.take token_length .B.intercalate "/") - in - Just - (location, rs.catMaybes.catMaybes) - else Nothing - - where - capture x y - | x.B.unpack.starts_with ":" = Just - Just (x.B.tail, y) - | x == y = Just Nothing - | otherwise = Nothing - --- copy from miku utils -put_namespace :: ByteString -> [(ByteString, ByteString)] -> Env -> Env -put_namespace x xs env = - let adds = xs.map_fst (x +) - new_headers = adds.map fst - new_hack_headers = - env.hackHeaders.reject (fst > belongs_to new_headers) ++ adds - in - env {hackHeaders = new_hack_headers} - diff --git a/src/Network/Miku/Type.hs b/src/Network/Miku/Type.hs --- a/src/Network/Miku/Type.hs +++ b/src/Network/Miku/Type.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + module Network.Miku.Type where import Control.Monad.Reader @@ -5,43 +7,31 @@ import Data.Default import Hack2 import Hack2.Contrib.Utils -import Network.Miku.Middleware.MikuRouter import Data.ByteString.Lazy.Char8 (ByteString) -type RoutePathT a = (RequestMethod, ByteString, a) -type RoutePath = RoutePathT AppUnit +import Air.TH + type AppReader = Env type AppState = Response -type AppUnitT = ReaderT AppReader (StateT AppState IO) -type AppUnit = AppUnitT () +type AppMonadT = ReaderT AppReader (StateT AppState IO) +type AppMonad = AppMonadT () -type RouterT a = ByteString -> (a -> Application) -> RoutePathT a -> Middleware -type Router = RouterT AppUnit -data RouteConfig = RouteConfig - { - route_path :: RoutePath - , router :: Router - } - -data Miku = Miku +data MikuState = MikuState { - current_router :: Router - , routes :: [RouteConfig] - , middlewares :: [Middleware] + middlewares :: [Middleware] , mimes :: [(ByteString, ByteString)] } -instance Default Miku where - def = Miku +instance Default MikuState where + def = MikuState { - current_router = miku_router - , routes = def - , middlewares = [dummy_middleware] + middlewares = [dummy_middleware] , mimes = def } +mkLabel ''MikuState -type UnitT a = State Miku a -type Unit = UnitT () +type MikuMonadT a = State MikuState a +type MikuMonad = MikuMonadT () diff --git a/src/Network/Miku/Utils.hs b/src/Network/Miku/Utils.hs --- a/src/Network/Miku/Utils.hs +++ b/src/Network/Miku/Utils.hs @@ -28,18 +28,10 @@ env {hackHeaders = new_hack_headers} -set_namespace :: ByteString -> ByteString -> ByteString -> Env -> Env -set_namespace x k v = put_namespace x [(k,v)] -delete_namespace :: ByteString -> ByteString -> Env -> Env -delete_namespace x k env = - let new_hack_headers = env.hackHeaders.reject (fst > is (x + k)) - in - env {hackHeaders = new_hack_headers} - insert_last :: a -> [a] -> [a] insert_last x xs = xs ++ [x] update :: (MonadState a m, Functor m) => (a -> a) -> m () -update f = get ^ f >>= put +update = modify