diff --git a/Nemesis b/Nemesis deleted file mode 100644 --- a/Nemesis +++ /dev/null @@ -1,42 +0,0 @@ -import System.Nemesis (run) -import System.Nemesis.DSL -import Air.Env ((-)) -import Prelude hiding ((-)) - -main = run nemesis -nemesis = do - - clean - [ "**/*.hi" - , "**/*.o" - , "manifest" - , "test/hello_world" - ] - - desc "prepare cabal dist" - task "dist" - do - sh "cabal clean" - sh "cabal configure" - sh "cabal sdist" - - - desc "show sloc" - task "stat" - do - sh "cloc -match-f=hs- --quiet src --no3" - - - task "i" - do - sh "ghci -isrc src/Test/Test.hs" - - desc "run the test app in src/Test/Test.hs" - task "run" - do - sh "runghc -isrc src/Test/Test.hs" - - task "myapp" - do - sh "runghc -isrc src/Test/myapp.hs" - - task "moe" - do - sh "runghc -isrc src/Test/Moe.hs" - - task "moei" - do - sh "ghci -isrc src/Test/Moe.hs" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -0,0 +1,4 @@ +2016.3.16 + +* Get rid of the Air dependency +* Rewrite using common Haskell coding convention diff --git a/miku.cabal b/miku.cabal --- a/miku.cabal +++ b/miku.cabal @@ -1,5 +1,5 @@ Name: miku -Version: 2014.11.17 +Version: 2016.3.16 Build-type: Simple Synopsis: A minimum web dev DSL in Haskell Description: @@ -10,22 +10,27 @@ License-file: LICENSE Author: Jinjing Wang Maintainer: Jinjing Wang -Build-Depends: base Cabal-version: >= 1.2 category: Web homepage: https://github.com/nfjinjing/miku -extra-doc-files: readme.md, changelog.md, Nemesis, known-issues.md +extra-doc-files: readme.md, changelog.md, known-issues.md library - build-depends: base > 4 && <= 99 + build-depends: + base > 4 && <= 6 + , bytestring + , containers , data-default + , filepath >= 1.4.0.0 , hack2 >= 2012.1.19 , hack2-contrib >= 2012.1.19 - , air >= 2014.5.19 - , air-th , mtl - , containers - , bytestring + , lens + -- for testing + -- , hack2-handler-snap-server + -- , foreign-store + -- , moe + hs-source-dirs: src/ exposed-modules: diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -5,10 +5,10 @@ ## Example {-# LANGUAGE OverloadedStrings #-} - + import Network.Miku import Hack2.Handler.SnapServer - + main = run . miku $ get "/" (text "miku power") @@ -17,31 +17,31 @@ cabal update cabal install miku cabal install hack2-handler-snap-server - + -- copy and paste the above example to myapp.hs - + runghc myapp.hs check: ## Quick reference - + ## Routes ### Verbs - + {-# LANGUAGE OverloadedStrings #-} - + -- use - instead of $ for clarity import Air.Light ((-)) import Prelude hiding ((-)) - + import Network.Miku import Hack2.Handler.SnapServer - + main = run . miku - do get "/" - do @@ -49,10 +49,10 @@ post "/" - do -- for a post request - + put "/" - do -- put .. - + delete "/" - do -- .. @@ -81,7 +81,7 @@ before - \e -> do putStrLn "before called" return e - + -- after takes that of type (Response -> IO Response) after return @@ -90,26 +90,24 @@ ### Use hack2 middleware import Hack2.Contrib.Middleware.SimpleAccessLogger - + middleware - simple_access_logger Nothing ### Convert miku into a hack2 application -- in Network.Miku.Engine - + miku :: MikuMonad -> Application - + ## 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/Moe.hs) +* [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. * `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`. - + ## Reference * miku is inspired by [Rack](http://rack.rubyforge.org), [Rails](http://rubyonrails.org), [Ramaze](http://ramaze.net), [Happstack](http://happstack.com/) and [Sinatra](http://www.sinatrarb.com/). - - 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,17 +3,16 @@ module Network.Miku.Config where -import Hack2 -import Hack2.Contrib.Middleware.Config -import Hack2.Contrib.Middleware.ContentLength -import Hack2.Contrib.Middleware.ContentType -import Network.Miku.Utils -import Prelude hiding ((.), (>), (^), (-)) -import Data.ByteString.Char8 (ByteString) +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 pre_installed_middlewares :: [Middleware] -pre_installed_middlewares = +pre_installed_middlewares = [ content_length , content_type default_content_type 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,31 +2,29 @@ module Network.Miku.DSL where -import Control.Monad.Reader -import Control.Monad.State -import Hack2 -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 Hack2.Contrib.Constants -import Air -import Network.Miku.Config -import Network.Miku.Engine -import Network.Miku.Type -import Network.Miku.Utils -import Prelude hiding ((.), (>), (^), (-)) -import qualified Control.Monad.State as State -import Data.ByteString.Char8 (ByteString) - -import Air.Data.Record.SimpleLabel hiding (get) +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 Network.Miku.Config +import Network.Miku.Engine +import Network.Miku.Type +import Network.Miku.Utils +import Prelude hiding ((-)) app :: Application -> AppMonad -app f = ask >>= (f > io) >>= State.put +app f = ask >>= (liftIO . f) >>= State.put middleware :: Middleware -> MikuMonad -middleware x = modM __middlewares - insert_last x +middleware x = middlewares %= insert_last x get, put, post, delete :: ByteString -> AppMonad -> MikuMonad get = add_route GET @@ -37,16 +35,16 @@ add_route :: RequestMethod -> ByteString -> AppMonad -> MikuMonad add_route route_method route_string app_monad = do - modM __router - insert_last - miku_router route_method route_string app_monad - + modifying router - insert_last - miku_router route_method route_string app_monad + before :: (Env -> IO Env) -> MikuMonad -before = ioconfig > middleware +before = middleware . ioconfig after :: (Response -> IO Response) -> MikuMonad -after = censor > middleware +after = middleware . censor mime :: ByteString -> ByteString -> MikuMonad -mime k v = modM __mimes - insert_last (k,v) +mime k v = mimes %= insert_last (k,v) public :: Maybe ByteString -> [ByteString] -> MikuMonad public r xs = middleware - static r xs @@ -68,4 +66,4 @@ update - set_body_bytestring - x captures :: AppMonadT [(ByteString, ByteString)] -captures = ask ^ namespace miku_captures +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,68 +1,65 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Network.Miku.Engine where -import Control.Monad.Reader hiding (join) -import Control.Monad.State hiding (join) -import Hack2 -import Hack2.Contrib.Middleware.UserMime -import Hack2.Contrib.Middleware.NotFound -import Hack2.Contrib.Utils hiding (get, put) -import Air.Env hiding (mod) -import Network.Miku.Config -import Network.Miku.Type -import Network.Miku.Utils -import Prelude () -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Prelude as P -import Air.Data.Record.SimpleLabel hiding (get) -import Data.Maybe -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.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Default as Default +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 Network.Miku.Config +import Network.Miku.Type +import Network.Miku.Utils +import Prelude hiding ((-)) +import System.FilePath (()) miku :: MikuMonad -> Application miku miku_monad = miku_middleware miku_monad (not_found dummy_app) - miku_middleware :: MikuMonad -> Middleware -miku_middleware miku_monad = - - let miku_state = execState miku_monad def - mime_filter = user_mime (miku_state.mimes) - miku_middleware_stack = use - miku_state.middlewares - miku_router_middleware = use - miku_state.router +miku_middleware miku_monad = + + let miku_state = execState miku_monad mempty + mime_filter = 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 in - + use [pre_installed_middleware_stack, mime_filter, miku_middleware_stack, miku_router_middleware] - + miku_router :: RequestMethod -> ByteString -> AppMonad -> Middleware miku_router route_method route_string app_monad app = \env -> - if env.request_method == route_method + if request_method env == route_method then - case env.path_info.parse_params route_string of + case env & path_info & parse_params route_string of Nothing -> app env - Just (_, params) -> - let miku_app = run_app_monad - local (put_namespace miku_captures params) app_monad + Just (_, params) -> + let miku_app = run_app_monad - local (put_namespace miku_captures params) app_monad in miku_app env - + else app env - - + + 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 -> runReaderT app_monad env & flip execStateT Default.def + parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)]) parse_params "*" x = Just (x, []) parse_params "" "" = Just ("", []) @@ -70,31 +67,31 @@ parse_params "/" "" = Nothing parse_params "/" "/" = Just ("/", []) -parse_params t s = - - let template_tokens = t.B.split '/' - url_tokens = s.B.split '/' - - _template_last_token_matches_everything = template_tokens.length P.> 0 && template_tokens.last.is "*" - _template_tokens_length_equals_url_token_length = template_tokens.length == url_tokens.length +parse_params t s = + + let template_tokens = B.split '/' t + url_tokens = 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) in - + if not - _template_last_token_matches_everything || _template_tokens_length_equals_url_token_length then Nothing - else + 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 "/") + if all isJust rs + then + let token_length = length template_tokens + location = B.pack - "/" (B.unpack - B.intercalate "/" - take token_length url_tokens) in - Just - (location, rs.catMaybes.catMaybes) + Just - (location, rs & catMaybes & catMaybes) else Nothing - + where - capture x y - | x.B.unpack.starts_with ":" = Just - Just (x.B.tail, y) - | x.is "*" = Just Nothing + capture x y + | ":" `isPrefixOf` B.unpack x = Just - Just (B.tail x, y) + | x == "*" = Just Nothing | x == y = Just Nothing | otherwise = 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 @@ -2,15 +2,15 @@ module Network.Miku.Type where -import Control.Monad.Reader -import Control.Monad.State -import Air.Data.Default -import Hack2 -import Hack2.Contrib.Utils -import Data.ByteString.Char8 (ByteString) - -import Air.TH -import Air.Data.Record.SimpleLabel +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 Hack2 +import Hack2.Contrib.Utils type AppReader = Env type AppState = Response @@ -20,13 +20,16 @@ data MikuState = MikuState { - middlewares :: [Middleware] - , router :: [Middleware] - , mimes :: [(ByteString, ByteString)] + _middlewares :: [Middleware] + , _router :: [Middleware] + , _mimes :: [(ByteString, ByteString)] } -mkDefault ''MikuState -mkLabel ''MikuState +instance Monoid MikuState where + mempty = MikuState [] [] [] + mappend (MikuState x y z) (MikuState x' y' z') = MikuState (x <> x') (y <> y') (z <> z') +makeLenses ''MikuState + type MikuMonadT a = State MikuState a -type MikuMonad = MikuMonadT () +type MikuMonad = MikuMonadT () -- (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,27 +2,34 @@ 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 Hack2 -import Air.Env -import Prelude () - +import Prelude hiding ((-)) import qualified Data.ByteString.Char8 as B -import Data.ByteString.Char8 (ByteString) +infixr 0 - +{-# INLINE (-) #-} +(-) :: (a -> b) -> a -> b +f - x = f x + namespace :: ByteString -> Env -> [(ByteString, ByteString)] -namespace x env = - env - .hackHeaders - .select (fst > (x `B.isPrefixOf`)) - .map_fst (B.drop (x.B.length)) +namespace x = + map (first (B.drop (B.length x))) + . filter ((x `B.isPrefixOf`) . fst) + . hackHeaders put_namespace :: ByteString -> [(ByteString, ByteString)] -> Env -> Env put_namespace x xs env = - let adds = xs.map_fst (x +) - new_headers = adds.map fst + let adds = map (first (x <>)) xs + new_headers = map fst adds new_hack_headers = - env.hackHeaders.reject (fst > belongs_to new_headers) ++ adds + (hackHeaders env & filter (flip notElem new_headers . fst)) + <> adds + in env {hackHeaders = new_hack_headers}