diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +2016.3.16.1 + +* Switch to WAI +* Remove `public` and `mime` helpers, as those functionalities can be achieved through `wai-middleware-static` + 2016.3.16 * Get rid of the Air dependency diff --git a/miku.cabal b/miku.cabal --- a/miku.cabal +++ b/miku.cabal @@ -1,5 +1,5 @@ Name: miku -Version: 2016.3.16 +Version: 2016.3.16.1 Build-type: Simple Synopsis: A minimum web dev DSL in Haskell Description: @@ -17,19 +17,21 @@ library build-depends: - base > 4 && <= 6 - , bytestring - , containers - , data-default - , filepath >= 1.4.0.0 - , hack2 >= 2012.1.19 - , hack2-contrib >= 2012.1.19 - , mtl - , lens - -- for testing - -- , hack2-handler-snap-server - -- , foreign-store - -- , moe + base > 4 && <= 6 + , blaze-builder >= 0.4.0.1 + , bytestring + , case-insensitive >= 1.2.0.5 + , containers + , filepath >= 1.4.0.0 + , http-types >= 0.9 + , lens + , mtl + , wai + , wai-extra + -- for testing + -- , foreign-store + -- , moe + -- , warp hs-source-dirs: src/ diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -6,17 +6,18 @@ {-# LANGUAGE OverloadedStrings #-} - import Network.Miku - import Hack2.Handler.SnapServer + import Network.Miku + import Network.Wai.Handler.Warp (run) - main = run . miku $ get "/" (text "miku power") + main :: IO () + main = run 3000 . miku $ get "/" (text "miku power") ## Installation cabal update cabal install miku - cabal install hack2-handler-snap-server + cabal install warp -- copy and paste the above example to myapp.hs @@ -26,8 +27,7 @@ ## Quick reference - - + ## Routes @@ -35,14 +35,12 @@ {-# LANGUAGE OverloadedStrings #-} - -- use - instead of $ for clarity - import Air.Light ((-)) - import Prelude hiding ((-)) - import Network.Miku - import Hack2.Handler.SnapServer + import Network.Miku.Utils ((-)) + import Network.Wai.Handler.Warp (run) + import Prelude hiding ((-)) - main = run . miku - do + main = run 3000 . miku - do get "/" - do -- something for a get request @@ -65,35 +63,15 @@ -- [("user","miku"),("message","hello")] -## Static - - -- public serve, only allows `./src` - public (Just ".") ["/src"] - -## Mime types - - -- treat .hs extension as text/plain - mime "hs" "text/plain" - -## Filters - - -- before takes a function of type (Env -> IO Env) - before - \e -> do - putStrLn "before called" - return e - - -- after takes that of type (Response -> IO Response) - after return - -## Hack2 integration +## WAI integration -### Use hack2 middleware +### Use WAI middleware - import Hack2.Contrib.Middleware.SimpleAccessLogger + import Network.Wai.Middleware.RequestLogger - middleware - simple_access_logger Nothing + middleware logStdout -### Convert miku into a hack2 application +### Convert miku into a WAI application -- in Network.Miku.Engine @@ -102,9 +80,9 @@ ## Hints -* It's recommended to use your own html combinator / template engine. Try DIY with, e.g. [moe](http://github.com/nfjinjing/moe). -* [Example view using custom html combinator (moe in this case)](http://github.com/nfjinjing/miku/blob/master/src/test/html_using_moe.hs) -* When inspecting the request, use `ask` defined in `ReaderT` monad to get the `Hack2.Environment`, then use helper method defined in `Hack2.Contrib.Request` to query it. +* It's recommended to use your own html combinator / template engine. Try DIY with, e.g. [moe](https://github.com/nfjinjing/moe). +* [Example view using custom html combinator (moe in this case)](https://github.com/nfjinjing/miku/blob/master/test/HTMLUsingMoe.hs) +* When inspecting the request, use `ask` defined in `ReaderT` monad to get the `Request`, then use helper methods for `wai` to query it. * `Response` is in `StateT`, `html` and `text` are simply helper methods that update the state, i.e. setting the response body, content-type, etc. * You do need to understand monad transformers to reach the full power of `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 @@ -4,18 +4,15 @@ module Network.Miku.Config where import Data.ByteString.Char8 (ByteString) -import Hack2 -import Hack2.Contrib.Middleware.Config -import Hack2.Contrib.Middleware.ContentLength -import Hack2.Contrib.Middleware.ContentType import Network.Miku.Utils +import Network.Wai pre_installed_middlewares :: [Middleware] pre_installed_middlewares = [ - content_length - , content_type default_content_type + -- content_length + -- , content_type default_content_type ] where default_content_type = "text/plain; charset=UTF-8" 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 @@ -2,68 +2,78 @@ 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 Hack2 -import Hack2.Contrib.Constants -import Hack2.Contrib.Middleware.Censor -import Hack2.Contrib.Middleware.Config -import Hack2.Contrib.Middleware.IOConfig -import Hack2.Contrib.Middleware.Static -import Hack2.Contrib.Response +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 import Network.Miku.Engine import Network.Miku.Type import Network.Miku.Utils -import Prelude hiding ((-)) +import Network.Wai +import Network.Wai.Middleware.StripHeaders +import Prelude hiding ((-)) -app :: Application -> AppMonad -app f = ask >>= (liftIO . f) >>= State.put +-- import Network.Wai.Middleware.Static +-- app :: Application -> AppMonad +-- app f = ask >>= (liftIO . f) >>= State.put + middleware :: Middleware -> MikuMonad -middleware x = middlewares %= insert_last x +middleware x = middlewares %= insertLast x get, put, post, delete :: ByteString -> AppMonad -> MikuMonad -get = add_route GET -put = add_route PUT -post = add_route POST -delete = add_route DELETE +get = add_route H.methodGet +put = add_route H.methodPut +post = add_route H.methodPost +delete = add_route H.methodDelete -add_route :: RequestMethod -> ByteString -> AppMonad -> MikuMonad +add_route :: H.Method -> ByteString -> AppMonad -> MikuMonad add_route route_method route_string app_monad = do - modifying router - insert_last - miku_router route_method route_string app_monad + modifying router - insertLast - miku_router route_method route_string app_monad -before :: (Env -> IO Env) -> MikuMonad -before = middleware . ioconfig +-- before :: (Env -> IO Env) -> MikuMonad +-- before = middleware . ioconfig -after :: (Response -> IO Response) -> MikuMonad -after = middleware . censor +-- after :: (Response -> IO Response) -> MikuMonad +-- after = middleware . censor -mime :: ByteString -> ByteString -> MikuMonad -mime k v = mimes %= insert_last (k,v) +-- mime :: ByteString -> ByteString -> MikuMonad +-- mime k v = mimes %= insertLast (CI.mk k,v) -public :: Maybe ByteString -> [ByteString] -> MikuMonad -public r xs = middleware - static r xs +-- public :: ByteString -> MikuMonad +-- public = staticPolicy . addBase . review (utf8 . _Text) +_ContentType :: ByteString +_ContentType = "Content-Type" + +setContentType :: ByteString -> Response -> Response +setContentType x = mapResponseHeaders ((CI.mk _ContentType, x):) . stripHeader _ContentType + +setBody :: ByteString -> Response -> Response +setBody x r = responseBuilder (responseStatus r) (responseHeaders r) - fromByteString x + text :: ByteString -> AppMonad text x = do - update - set_content_type _TextPlain - update - set_body_bytestring - x + modify - setContentType "text/plain; charset=UTF-8" + modify - setBody - x html :: ByteString -> AppMonad html x = do - update - set_content_type _TextHtml - update - set_body_bytestring - x + modify - setContentType "text/html; charset=UTF-8" + modify - setBody - x json :: ByteString -> AppMonad json x = do - update - set_content_type "text/json" - update - set_body_bytestring - x + modify - setContentType "text/json" + modify - setBody - x -captures :: AppMonadT [(ByteString, ByteString)] +captures :: AppMonadT [H.Header] 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 @@ -4,33 +4,43 @@ module Network.Miku.Engine where -import Control.Lens hiding (use) -import Control.Monad.Reader hiding (join) -import Control.Monad.State hiding (join) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Default as Default +import Control.Lens hiding (use) +import Control.Monad.Reader hiding (join) +import Control.Monad.State hiding (join) +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 -import Hack2 -import Hack2.Contrib.Middleware.NotFound -import Hack2.Contrib.Middleware.UserMime -import Hack2.Contrib.Utils hiding (get, put) +import qualified Network.HTTP.Types as H import Network.Miku.Config import Network.Miku.Type import Network.Miku.Utils -import Prelude hiding ((-)) -import System.FilePath (()) +import Network.Wai +import Prelude hiding ((-)) +import System.FilePath (()) +emptyResponse :: Response +emptyResponse = responseLBS H.status200 + [("Content-Type", "text/plain")] + "empty app" +emptyApp :: Application +emptyApp _ respond = respond - emptyResponse + miku :: MikuMonad -> Application -miku miku_monad = miku_middleware miku_monad (not_found dummy_app) +miku = flip miku_middleware emptyApp +use :: [Middleware] -> Middleware +use = foldl (.) id + miku_middleware :: MikuMonad -> Middleware miku_middleware miku_monad = let miku_state = execState miku_monad mempty - mime_filter = user_mime - miku_state ^. mimes + 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 @@ -39,14 +49,15 @@ use [pre_installed_middleware_stack, mime_filter, miku_middleware_stack, miku_router_middleware] -miku_router :: RequestMethod -> ByteString -> AppMonad -> Middleware +miku_router :: H.Method -> ByteString -> AppMonad -> Middleware miku_router route_method route_string app_monad app = \env -> - if request_method env == route_method + if requestMethod env == route_method then - case env & path_info & parse_params route_string of + case env & rawPathInfo & parse_params route_string of Nothing -> app env Just (_, params) -> - let miku_app = run_app_monad - local (put_namespace miku_captures params) app_monad + let mikuHeaders = params & map (first CI.mk) + miku_app = run_app_monad - local (putNamespace miku_captures mikuHeaders) app_monad in miku_app env @@ -56,8 +67,11 @@ where + run_app_monad :: AppMonad -> Application - run_app_monad app_monad = \env -> runReaderT app_monad env & flip execStateT Default.def + run_app_monad app_monad env respond = do + r <- runReaderT app_monad env & flip execStateT emptyResponse + respond r parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)]) 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 @@ -9,10 +9,10 @@ import Control.Monad.State import Data.ByteString.Char8 (ByteString) import Data.Monoid -import Hack2 -import Hack2.Contrib.Utils +import Network.Wai +import qualified Network.HTTP.Types as H -type AppReader = Env +type AppReader = Request type AppState = Response type AppMonadT = ReaderT AppReader (StateT AppState IO) type AppMonad = AppMonadT () @@ -22,12 +22,11 @@ { _middlewares :: [Middleware] , _router :: [Middleware] - , _mimes :: [(ByteString, ByteString)] } instance Monoid MikuState where - mempty = MikuState [] [] [] - mappend (MikuState x y z) (MikuState x' y' z') = MikuState (x <> x') (y <> y') (z <> z') + mempty = MikuState [] [] + mappend (MikuState x y) (MikuState x' y') = MikuState (x <> x') (y <> y') makeLenses ''MikuState 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 @@ -7,37 +7,39 @@ import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import Data.Monoid ((<>)) -import Hack2 import Prelude hiding ((-)) import qualified Data.ByteString.Char8 as B +import Network.Wai +import qualified Network.HTTP.Types as H +import Data.String +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI infixr 0 - {-# INLINE (-) #-} (-) :: (a -> b) -> a -> b f - x = f x -namespace :: ByteString -> Env -> [(ByteString, ByteString)] +namespace :: ByteString -> Request -> [H.Header] namespace x = - map (first (B.drop (B.length x))) - . filter ((x `B.isPrefixOf`) . fst) - . hackHeaders + map (first . CI.map . B.drop - B.length x) + . filter ((x `B.isPrefixOf`) . CI.original. fst) + . requestHeaders -put_namespace :: ByteString -> [(ByteString, ByteString)] -> Env -> Env -put_namespace x xs env = - let adds = map (first (x <>)) xs - new_headers = map fst adds - new_hack_headers = - (hackHeaders env & filter (flip notElem new_headers . fst)) +putNamespace :: ByteString -> [H.Header] -> Request -> Request +putNamespace x xs env = + let adds = map (first (CI.map (x <>))) xs + newHeaders = map fst adds + newRequestHeaders = + (requestHeaders env & filter (flip notElem newHeaders . fst)) <> adds in - env {hackHeaders = new_hack_headers} + env {requestHeaders = newRequestHeaders} -insert_last :: a -> [a] -> [a] -insert_last x xs = xs ++ [x] +insertLast :: a -> [a] -> [a] +insertLast x xs = xs <> [x] -update :: (MonadState a m, Functor m) => (a -> a) -> m () -update = modify