diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/miku.cabal b/miku.cabal --- a/miku.cabal +++ b/miku.cabal @@ -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 + +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 -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 diff --git a/src/Network/Miku.hs b/src/Network/Miku.hs --- a/src/Network/Miku.hs +++ b/src/Network/Miku.hs @@ -5,5 +5,5 @@ ) where -import Network.Miku.Engine (miku) -import Network.Miku.DSL +import Network.Miku.DSL +import Network.Miku.Engine (miku) diff --git a/src/Network/Miku/Config.hs b/src/Network/Miku/Config.hs --- a/src/Network/Miku/Config.hs +++ b/src/Network/Miku/Config.hs @@ -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-" 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 @@ -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 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,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 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,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 () 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 @@ -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]