miku 2016.3.16.1 → 2016.3.17
raw patch · 8 files changed
+107/−136 lines, 8 filesdep −lens
Dependencies removed: lens
Files
- changelog.md +5/−0
- miku.cabal +24/−14
- src/Network/Miku.hs +2/−2
- src/Network/Miku/Config.hs +3/−16
- src/Network/Miku/DSL.hs +16/−32
- src/Network/Miku/Engine.hs +34/−40
- src/Network/Miku/Type.hs +8/−16
- src/Network/Miku/Utils.hs +15/−16
changelog.md view
@@ -1,3 +1,8 @@+2016.3.17++* Fix `captures` API to remain compatible with older versions+* Remove `lens` dependenty to stay lean+ 2016.3.16.1 * Switch to WAI
miku.cabal view
@@ -1,21 +1,33 @@-Name: miku-Version: 2016.3.16.1-Build-type: Simple-Synopsis: A minimum web dev DSL in Haskell-Description:+name: miku+category: Web+version: 2016.3.17+cabal-version: >= 1.6 +license: BSD3+license-file: LICENSE++author: Jinjing Wang+maintainer: Jinjing Wang <nfjinjing@gmail.com>++build-type: Simple+tested-with: GHC == 7.10.3++synopsis: A minimum web dev DSL+description:+ A simple library for fast web prototyping in Haskell. -License: BSD3-License-file: LICENSE-Author: Jinjing Wang-Maintainer: Jinjing Wang <nfjinjing@gmail.com>-Cabal-version: >= 1.2-category: Web homepage: https://github.com/nfjinjing/miku extra-doc-files: readme.md, changelog.md, known-issues.md +source-repository head+ type: git+ location: git://github.com/nfjinjing/miku.git+ library+ ghc-options: -Wall -fno-warn-unused-do-bind+ hs-source-dirs: src/+ build-depends: base > 4 && <= 6 , blaze-builder >= 0.4.0.1@@ -24,17 +36,15 @@ , containers , filepath >= 1.4.0.0 , http-types >= 0.9- , lens , mtl , wai , wai-extra -- for testing+ -- , lens -- , foreign-store -- , moe -- , warp -- hs-source-dirs: src/ exposed-modules: Network.Miku Network.Miku.Config
src/Network/Miku.hs view
@@ -5,5 +5,5 @@ ) where -import Network.Miku.Engine (miku)-import Network.Miku.DSL+import Network.Miku.DSL+import Network.Miku.Engine (miku)
src/Network/Miku/Config.hs view
@@ -3,20 +3,7 @@ module Network.Miku.Config where -import Data.ByteString.Char8 (ByteString)-import Network.Miku.Utils-import Network.Wai---pre_installed_middlewares :: [Middleware]-pre_installed_middlewares =- [- -- content_length- -- , content_type default_content_type- ]- where- default_content_type = "text/plain; charset=UTF-8"-+import Data.ByteString.Char8 (ByteString) -miku_captures :: ByteString-miku_captures = "miku-captures-"+mikuCaptures :: ByteString+mikuCaptures = "miku-captures-"
src/Network/Miku/DSL.hs view
@@ -3,12 +3,9 @@ module Network.Miku.DSL where import Blaze.ByteString.Builder (fromByteString)-import Control.Lens import Control.Monad.Reader import Control.Monad.State-import qualified Control.Monad.State as State import Data.ByteString.Char8 (ByteString)-import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as H import Network.Miku.Config@@ -19,37 +16,24 @@ import Network.Wai.Middleware.StripHeaders import Prelude hiding ((-)) --- import Network.Wai.Middleware.Static---- app :: Application -> AppMonad--- app f = ask >>= (liftIO . f) >>= State.put- middleware :: Middleware -> MikuMonad-middleware x = middlewares %= insertLast x+middleware x = do+ modify - \_state -> _state { middlewares = insertLast x - middlewares _state } -get, put, post, delete :: ByteString -> AppMonad -> MikuMonad-get = add_route H.methodGet-put = add_route H.methodPut-post = add_route H.methodPost-delete = add_route H.methodDelete+get, put, post, delete :: ByteString -> AppMonad' -> MikuMonad+get = addRoute H.methodGet+put = addRoute H.methodPut+post = addRoute H.methodPost+delete = addRoute H.methodDelete -add_route :: H.Method -> ByteString -> AppMonad -> MikuMonad-add_route route_method route_string app_monad = do- modifying router - insertLast - miku_router route_method route_string app_monad+addRoute :: H.Method -> ByteString -> AppMonad' -> MikuMonad+addRoute routeMethod routeString appMonad = do+ let newRoute = mikuRouter routeMethod routeString appMonad --- before :: (Env -> IO Env) -> MikuMonad--- before = middleware . ioconfig+ modify - \_state -> _state { router = insertLast newRoute - router _state } --- after :: (Response -> IO Response) -> MikuMonad--- after = middleware . censor --- mime :: ByteString -> ByteString -> MikuMonad--- mime k v = mimes %= insertLast (CI.mk k,v)---- public :: ByteString -> MikuMonad--- public = staticPolicy . addBase . review (utf8 . _Text)- _ContentType :: ByteString _ContentType = "Content-Type" @@ -59,21 +43,21 @@ setBody :: ByteString -> Response -> Response setBody x r = responseBuilder (responseStatus r) (responseHeaders r) - fromByteString x -text :: ByteString -> AppMonad+text :: ByteString -> AppMonad' text x = do modify - setContentType "text/plain; charset=UTF-8" modify - setBody - x -html :: ByteString -> AppMonad+html :: ByteString -> AppMonad' html x = do modify - setContentType "text/html; charset=UTF-8" modify - setBody - x -json :: ByteString -> AppMonad+json :: ByteString -> AppMonad' json x = do modify - setContentType "text/json" modify - setBody - x -captures :: AppMonadT [H.Header]-captures = ask <&> namespace miku_captures+captures :: AppMonad [(ByteString, ByteString)]+captures = namespace mikuCaptures <$> ask
src/Network/Miku/Engine.hs view
@@ -1,16 +1,12 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} - module Network.Miku.Engine where -import Control.Lens hiding (use)-import Control.Monad.Reader hiding (join)-import Control.Monad.State hiding (join)+import Control.Monad.Reader+import Control.Monad.State import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.List import Data.Maybe@@ -31,35 +27,33 @@ emptyApp _ respond = respond - emptyResponse miku :: MikuMonad -> Application-miku = flip miku_middleware emptyApp+miku = flip mikuMiddleware emptyApp use :: [Middleware] -> Middleware use = foldl (.) id -miku_middleware :: MikuMonad -> Middleware-miku_middleware miku_monad =+mikuMiddleware :: MikuMonad -> Middleware+mikuMiddleware mikuMonad = - let miku_state = execState miku_monad mempty- mime_filter = id -- user_mime - miku_state ^. mimes- miku_middleware_stack = use - miku_state ^. middlewares- miku_router_middleware = use - miku_state ^. router- pre_installed_middleware_stack = use - pre_installed_middlewares+ let mikuState = execState mikuMonad mempty+ mikuMiddlewareStack = use - middlewares mikuState+ mikuRouterMiddleware = use - router mikuState in - use [pre_installed_middleware_stack, mime_filter, miku_middleware_stack, miku_router_middleware]+ use [mikuMiddlewareStack, mikuRouterMiddleware] -miku_router :: H.Method -> ByteString -> AppMonad -> Middleware-miku_router route_method route_string app_monad app = \env ->- if requestMethod env == route_method+mikuRouter :: H.Method -> ByteString -> AppMonad a -> Middleware+mikuRouter routeMethod routeString appMonad app = \env ->+ if requestMethod env == routeMethod then- case env & rawPathInfo & parse_params route_string of+ case env & rawPathInfo & parseParams routeString of Nothing -> app env Just (_, params) -> let mikuHeaders = params & map (first CI.mk)- miku_app = run_app_monad - local (putNamespace miku_captures mikuHeaders) app_monad+ mikuApp = _runAppMonad - local (putNamespace mikuCaptures mikuHeaders) appMonad in- miku_app env+ mikuApp env else app env@@ -68,37 +62,37 @@ where - run_app_monad :: AppMonad -> Application- run_app_monad app_monad env respond = do- r <- runReaderT app_monad env & flip execStateT emptyResponse- respond r+ _runAppMonad :: AppMonad a -> Application+ _runAppMonad _appMonad _env _respond = do+ r <- runReaderT _appMonad _env & flip execStateT emptyResponse+ _respond r -parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)])-parse_params "*" x = Just (x, [])-parse_params "" "" = Just ("", [])-parse_params "" _ = Nothing-parse_params "/" "" = Nothing-parse_params "/" "/" = Just ("/", [])+parseParams :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)])+parseParams "*" x = Just (x, [])+parseParams "" "" = Just ("", [])+parseParams "" _ = Nothing+parseParams "/" "" = Nothing+parseParams "/" "/" = Just ("/", []) -parse_params t s =+parseParams t s = - let template_tokens = B.split '/' t- url_tokens = B.split '/' s+ let templateTokens = B.split '/' t+ urlTokens = B.split '/' s - _template_last_token_matches_everything = (template_tokens & length) > 0 && (["*"] `isSuffixOf` template_tokens)- _template_tokens_length_equals_url_token_length = (template_tokens & length) == (url_tokens & length)+ _templateLastTokenMatchesEverything = (templateTokens & length) > 0 && (["*"] `isSuffixOf` templateTokens)+ _templateTokensLengthEqualsUrlTokenLength = (templateTokens & length) == (urlTokens & length) in - if not - _template_last_token_matches_everything || _template_tokens_length_equals_url_token_length+ if not - _templateLastTokenMatchesEverything || _templateTokensLengthEqualsUrlTokenLength then Nothing else- let rs = zipWith capture template_tokens url_tokens+ let rs = zipWith capture templateTokens urlTokens in if all isJust rs then- let token_length = length template_tokens- location = B.pack - "/" </> (B.unpack - B.intercalate "/" - take token_length url_tokens)+ let tokenLength = length templateTokens+ location = B.pack - "/" </> (B.unpack - B.intercalate "/" - take tokenLength urlTokens) in Just - (location, rs & catMaybes & catMaybes) else Nothing
src/Network/Miku/Type.hs view
@@ -1,34 +1,26 @@-{-# LANGUAGE TemplateHaskell #-}- module Network.Miku.Type where -import Control.Lens-import Control.Lens.TH import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State-import Data.ByteString.Char8 (ByteString) import Data.Monoid import Network.Wai-import qualified Network.HTTP.Types as H -type AppReader = Request-type AppState = Response-type AppMonadT = ReaderT AppReader (StateT AppState IO)-type AppMonad = AppMonadT ()+type AppReader = Request+type AppState = Response+type AppMonadT t = ReaderT AppReader (StateT AppState t)+type AppMonad = AppMonadT IO+type AppMonad' = AppMonad () data MikuState = MikuState {- _middlewares :: [Middleware]- , _router :: [Middleware]+ middlewares :: [Middleware]+ , router :: [Middleware] } instance Monoid MikuState where mempty = MikuState [] [] mappend (MikuState x y) (MikuState x' y') = MikuState (x <> x') (y <> y') -makeLenses ''MikuState--type MikuMonadT a = State MikuState a-type MikuMonad = MikuMonadT () -- (Identity ())+type MikuMonad = StateT MikuState Identity ()
src/Network/Miku/Utils.hs view
@@ -2,28 +2,30 @@ module Network.Miku.Utils where -import Control.Lens ((#), (&))-import Control.Monad.State-import Data.Bifunctor (first)-import Data.ByteString.Char8 (ByteString)-import Data.Monoid ((<>))-import Prelude hiding ((-))+import Data.Bifunctor (first)+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B+import qualified Data.CaseInsensitive as CI+import Data.Monoid ((<>))+import qualified Network.HTTP.Types as H import Network.Wai-import qualified Network.HTTP.Types as H-import Data.String-import Data.CaseInsensitive ( CI )-import qualified Data.CaseInsensitive as CI+import Prelude hiding ((-)) infixr 0 - {-# INLINE (-) #-} (-) :: (a -> b) -> a -> b f - x = f x -namespace :: ByteString -> Request -> [H.Header]+infixl 1 &+{-# INLINE (&) #-}+(&) :: a -> (a -> b) -> b+x & f = f x++namespace :: ByteString -> Request -> [(ByteString, ByteString)] namespace x =- map (first . CI.map . B.drop - B.length x)- . filter ((x `B.isPrefixOf`) . CI.original. fst)+ map (first (B.drop - B.length x))+ . filter ((x `B.isPrefixOf`) . fst)+ . map (first CI.original) . requestHeaders putNamespace :: ByteString -> [H.Header] -> Request -> Request@@ -33,11 +35,8 @@ newRequestHeaders = (requestHeaders env & filter (flip notElem newHeaders . fst)) <> adds- in env {requestHeaders = newRequestHeaders}-- insertLast :: a -> [a] -> [a] insertLast x xs = xs <> [x]