miku 2011.6.11 → 2011.6.12
raw patch · 7 files changed
+120/−172 lines, 7 filesdep −air-extradep ~hack2dep ~hack2-contrib
Dependencies removed: air-extra
Dependency ranges changed: hack2, hack2-contrib
Files
- miku.cabal +12/−5
- readme.md +5/−7
- src/Network/Miku/DSL.hs +18/−16
- src/Network/Miku/Engine.hs +70/−34
- src/Network/Miku/Middleware/MikuRouter.hs +0/−77
- src/Network/Miku/Type.hs +14/−24
- src/Network/Miku/Utils.hs +1/−9
miku.cabal view
@@ -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
readme.md view
@@ -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
src/Network/Miku/DSL.hs view
@@ -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
src/Network/Miku/Engine.hs view
@@ -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
− src/Network/Miku/Middleware/MikuRouter.hs
@@ -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}-
src/Network/Miku/Type.hs view
@@ -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 ()
src/Network/Miku/Utils.hs view
@@ -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