diff --git a/Nemesis b/Nemesis --- a/Nemesis +++ b/Nemesis @@ -4,6 +4,8 @@ [ "**/*.hi" , "**/*.o" , "manifest" + , "Test" + , "myloli" ] desc "prepare cabal dist" @@ -23,3 +25,16 @@ sh "ghc --make -isrc src/Test.hs -o Test" sh "echo done.." sh "./Test" + + desc "show sloc" + task "stat" $ do + sh "cloc -match-f=hs$ --quiet src --no3" + + + task "template" $ sh "ghci -isrc src/Network/Loli/Template.hs" + + task "loli" $ do + sh "ghc --make -isrc src/Test/myloli.hs -o myloli" + sh "echo done.." + sh "./myloli" + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,12 @@ +2009.6.27 +--------- + +### Feature + +* add template +* add local binding +* env and response are in reader and state monad respectively + 2009.6.26 --------- diff --git a/loli.cabal b/loli.cabal --- a/loli.cabal +++ b/loli.cabal @@ -1,5 +1,5 @@ Name: loli -Version: 2009.6.26 +Version: 2009.6.27 Build-type: Simple Synopsis: A minimum web dev DSL in Haskell Description: @@ -14,15 +14,18 @@ Cabal-version: >= 1.2 category: Web homepage: http://github.com/nfjinjing/loli -data-files: readme.md, changelog.md, Nemesis, known-issues.md, src/Test.hs +data-files: readme.md, changelog.md, Nemesis, known-issues.md, src/Test.hs, views/hello.html library ghc-options: -Wall - build-depends: base > 4 && <= 5, data-default, hack >= 2009.5.19, hack-contrib >= 2009.6.25, utf8-string, mps >= 2009.6.25, mtl + build-depends: base > 4 && <= 5, data-default, hack >= 2009.5.19, hack-contrib >= 2009.6.25, utf8-string, mps >= 2009.6.25, mtl, containers, template, bytestring hs-source-dirs: src/ exposed-modules: Network.Loli - other-modules: Network.Loli.Config Network.Loli.DSL Network.Loli.Engine + Network.Loli.Template + Network.Loli.Template.TextTemplate + Network.Loli.Utils + diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -1,29 +1,96 @@ -### Example +# loli +A minimum web dev DSL + +## Example + +First app + + -- myloli.hs + import Network.Loli import Hack.Handler.Happstack + main = run . loli $ get "/" (text "loli power") + +Install and compile: + + cabal update + cabal install loli + cabal install hack-handler-happstack - main = run . loli $ do + ghc --make myloli.hs + ./myloli - -- simple - get "/hello" (text "hello world") - - -- io - get "/cabal" $ text =<< io (readFile "loli.cabal") +check: - -- route captures - get "/say/:user/:verb" $ do - text . show =<< captured - -- html output - get "/html" (html "

loli power!

") +## Routes - -- default - get "/" (text "at root") +### Verb - -- public serve, only allows /src - public (Just ".") ["/src"] - - -- treat .hs extension as text/plain - mime "hs" "text/plain" + get "/" $ do + -- something for a get request + + post "/" $ do + -- for a post request + + put "/" $ do + -- put .. + + delete "/" $ do + -- .. +### Captures + + get "/say/:user/:something" $ do + text . show =<< captures + + -- /say/jinjing/hello will output + -- [("user","jinjing"),("something","hello")] + + +## Static + + -- public serve, only allows /src + public (Just ".") ["/src"] + +## Views + + -- in `./views`, can be changed by + views "template" + +### Text Template + + import Network.Loli.Template.TextTemplate + + -- template + get "/hi/:user" $ text_template "hello.html" + + -- in hello.html + + hello + +

hello $user

+ + + +### Local bindings + + get "/local-binding" $ do + bind "user" "alice" (text_template "hello.html") + +### Batched local bindings + + get "/batched-local-binding" $ do + context [("user", "alice"), ("password", "foo")] $ + text . show =<< bindings + + +## Mime types + + -- treat .hs extension as text/plain + mime "hs" "text/plain" + +## Note + +If you see this, use the git version! diff --git a/src/Network/Loli.hs b/src/Network/Loli.hs --- a/src/Network/Loli.hs +++ b/src/Network/Loli.hs @@ -5,5 +5,5 @@ ) where -import Network.Loli.Engine +import Network.Loli.Engine (loli) import Network.Loli.DSL diff --git a/src/Network/Loli/Config.hs b/src/Network/Loli/Config.hs --- a/src/Network/Loli/Config.hs +++ b/src/Network/Loli/Config.hs @@ -1,18 +1,33 @@ module Network.Loli.Config where import Hack +import Hack.Contrib.Middleware.Config import Hack.Contrib.Middleware.ContentLength import Hack.Contrib.Middleware.ContentType +import MPS.Light +import Prelude hiding ((.), (>), (^)) pre_installed_middlewares :: [Middleware] pre_installed_middlewares = [ content_length , content_type default_content_type + , config set_view_root ] where + set_view_root env = + let hack_headers = env.hackHeaders + view_root = (loli_views ++ "root", "views") + in + env {hackHeaders = hack_headers ++ [view_root]} default_content_type :: String default_content_type = "text/plain; charset=UTF-8" -loli_captures_prefix :: String -loli_captures_prefix = "loli_captures_" +loli_captures :: String +loli_captures = "loli_captures_" + +loli_bindings :: String +loli_bindings = "loli_bindings_" + +loli_views :: String +loli_views = "loli_views_" diff --git a/src/Network/Loli/DSL.hs b/src/Network/Loli/DSL.hs --- a/src/Network/Loli/DSL.hs +++ b/src/Network/Loli/DSL.hs @@ -1,32 +1,36 @@ module Network.Loli.DSL where +import Control.Monad.Reader import Control.Monad.State import Data.ByteString.Lazy.UTF8 (fromString) import Hack import Hack.Contrib.Constants +import Hack.Contrib.Middleware.Config import Hack.Contrib.Middleware.Static import Hack.Contrib.Response import MPS -import Network.Loli.Engine import Network.Loli.Config +import Network.Loli.Engine +import Network.Loli.Utils import Prelude hiding ((.), (>), (^)) import qualified Control.Monad.State as State - app :: Application -> AppUnit -app f = do - get_env >>= (f > io) >>= set_response +app f = ask >>= (f > io) >>= State.put text :: String -> AppUnit text x = do - update_response $ set_content_type _TextPlain - update_response $ set_body (x.fromString) + update $ set_content_type _TextPlain + update $ set_body (x.fromString) html :: String -> AppUnit html x = do - update_response $ set_content_type _TextHtml - update_response $ set_body (x.fromString) + update $ set_content_type _TextHtml + update $ set_body (x.fromString) +views :: String -> Unit +views x = middleware $ config (set_namespace loli_views [("root", x)]) + get, put, delete, post :: String -> AppUnit -> Unit get = route GET put = route PUT @@ -45,10 +49,12 @@ io :: (MonadIO m) => IO a -> m a io = liftIO -captured :: AppUnitT [(String, String)] -captured = get_env ^ hackHeaders ^ filter_captured - where - filter_captured = - select (fst > starts_with loli_captures_prefix) - > map_fst (drop (loli_captures_prefix.length)) - +context :: [(String, String)] -> AppUnit -> AppUnit +context = set_namespace loli_bindings > local + +bind :: String -> String -> AppUnit -> AppUnit +bind k v = context [(k, v)] + +captures, bindings :: AppUnitT [(String, String)] +captures = ask ^ namespace loli_captures +bindings = ask ^ namespace loli_bindings diff --git a/src/Network/Loli/Engine.hs b/src/Network/Loli/Engine.hs --- a/src/Network/Loli/Engine.hs +++ b/src/Network/Loli/Engine.hs @@ -2,6 +2,7 @@ module Network.Loli.Engine where +import Control.Monad.Reader hiding (join) import Control.Monad.State hiding (join) import Data.Default import Data.List (find) @@ -12,27 +13,23 @@ import Hack.Contrib.Utils hiding (get, put) import MPS import Network.Loli.Config -import Network.Loli.Config +import Network.Loli.Utils import Prelude hiding ((.), (/), (>), (^)) -type RoutePath = (RequestMethod, String, AppUnit) -type EnvFilter = Env -> Env + +type RoutePath = (RequestMethod, String, AppUnit) +type EnvFilter = Env -> Env type ResponseFilter = Response -> Response -type Param = (String, String) -data AppState = AppState - { - env :: Env - , response :: Response - } +type Param = (String, String) +type AppState = Response +type AppReader = Env -instance Default AppState where - def = AppState def def +type AppUnitT a = ReaderT AppReader (StateT AppState IO) a +type AppUnit = AppUnitT () -type AppUnitT a = StateT AppState IO a -type AppUnit = AppUnitT () run_app :: AppUnit -> Application -run_app unit = \env -> execStateT unit def {env} ^ response +run_app unit = \env -> runReaderT unit env .flip execStateT def router :: [RoutePath] -> Middleware router h app' = \env'' -> @@ -52,14 +49,11 @@ match_route env' (method, template, _) = env'.request_method.is method && env'.path_info.parse_params template .isJust - merge_captured params env' = - let loli_captures = params.map_fst (loli_captures_prefix ++) - new_hack_headers = env'.custom ++ loli_captures - in - env' {hackHeaders = new_hack_headers} - + merge_captured params env' = + env'.set_namespace loli_captures params parse_params :: String -> String -> Maybe (String, [(String, String)]) +parse_params "/" s = Just (s, []) parse_params t s = let template_tokens = t.split "/" url_tokens = s.split "/" @@ -92,10 +86,10 @@ } instance Default Loli where - def = Loli def def def + def = Loli def [dummy_middleware] def type UnitT a = State Loli a -type Unit = UnitT () +type Unit = UnitT () @@ -117,9 +111,6 @@ update :: (MonadState a m, Functor m) => (a -> a) -> m () update f = get ^ f >>= put -insert_last :: a -> [a] -> [a] -insert_last x xs = xs ++ [x] - add_route :: RoutePath -> Loli -> Loli add_route r s = let xs = s.routes in s {routes = xs.insert_last r} @@ -132,21 +123,6 @@ add_mime :: String -> String -> Loli -> Loli add_mime k v s = let xs = s.mimes in s {mimes = xs.insert_last (k, v)} - -update_response :: ResponseFilter -> AppUnit -update_response f = update $ \s -> let x = s.response.f in s {response = x} - -set_response :: Response -> AppUnit -set_response r = update_response $ const r - -get_response :: AppUnitT Response -get_response = get ^ response - -update_env :: EnvFilter -> AppUnit -update_env f = update $ \s -> let x = s.env.f in s {env = x} - -get_env :: AppUnitT Env -get_env = get ^ env -- middleware lookup_mime :: [(String, String)] -> Middleware diff --git a/src/Network/Loli/Template.hs b/src/Network/Loli/Template.hs new file mode 100644 --- /dev/null +++ b/src/Network/Loli/Template.hs @@ -0,0 +1,23 @@ +module Network.Loli.Template where + +import Control.Monad.Reader +import Data.Maybe +import Hack.Contrib.Response +import MPS +import Network.Loli.Config +import Network.Loli.DSL +import Network.Loli.Engine +import Network.Loli.Utils +import Prelude hiding ((.), (>), (^), (/)) +import qualified Data.ByteString.Lazy.Char8 as B + + +type Context = [(String, String)] +type Template = String -> Context -> IO B.ByteString + +template :: Template -> String -> AppUnit +template f x = do + c <- captures + b <- bindings + root <- ask ^ namespace loli_views ^ lookup "root" ^ fromMaybe "." + f (root / x) (c ++ b) .io >>= set_body > update diff --git a/src/Network/Loli/Template/TextTemplate.hs b/src/Network/Loli/Template/TextTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Network/Loli/Template/TextTemplate.hs @@ -0,0 +1,20 @@ +module Network.Loli.Template.TextTemplate (text_template) where + +import Control.Arrow ((***)) +import Data.ByteString.Lazy.UTF8 (fromString) +import MPS +import Network.Loli.Engine +import Network.Loli.Template +import Prelude hiding ((.), (>), (^), (/)) +import Text.Template hiding (Context, Template, template) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Map as Map + +create_context :: [(String, String)] -> Map.Map B.ByteString B.ByteString +create_context = map (fromString *** fromString) > to_h + +backend :: Template +backend x c = readTemplate (x.u2b) ^ flip render (create_context c) + +text_template :: String -> AppUnit +text_template = template backend diff --git a/src/Network/Loli/Utils.hs b/src/Network/Loli/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/Loli/Utils.hs @@ -0,0 +1,29 @@ +module Network.Loli.Utils where + +import Hack +import Hack.Contrib.Utils +import MPS.Light +import Prelude hiding ((.), (/), (>), (^)) + +namespace :: String -> Env -> [(String, String)] +namespace x env = + env + .custom + .select (fst > starts_with x) + .map_fst (drop (x.length)) + +set_namespace :: String -> [(String, String)] -> Env -> Env +set_namespace x xs env = + let adds = xs.map_fst (x ++) + new_headers = adds.map fst + new_hack_headers = + env.custom.reject (fst > belongs_to new_headers) ++ adds + in + env {hackHeaders = new_hack_headers} + + +add_namespace :: String -> String -> String -> Env -> Env +add_namespace x k v = set_namespace x [(k,v)] + +insert_last :: a -> [a] -> [a] +insert_last x xs = xs ++ [x] diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -1,6 +1,12 @@ import Network.Loli import Hack.Handler.Happstack +import Hack.Contrib.Response +import Hack.Contrib.Utils (dummy_middleware) +import Network.Loli.Template.TextTemplate +import Network.Loli.Engine +-- default on port 3000 + main = run . loli $ do -- simple @@ -10,12 +16,31 @@ get "/cabal" $ text =<< io (readFile "loli.cabal") -- route captures - get "/say/:user/:verb" $ do - text . show =<< captured + get "/say/:user/:something" $ do + text . show =<< captures -- html output get "/html" (html "

loli power!

") + -- template + get "/hi/:user" $ text_template "hello.html" + + -- manually tweak the reponse body + get "/hi-html/:user" $ do + update $ set_content_type "text/html" + text_template "hello.html" + + -- add local binding + get "/local-binding" $ do + bind "user" "alice" (text_template "hello.html") + + + -- batched local bindings + get "/batched-local-binding" $ do + context [("user", "alice"), ("password", "foo")] $ + text .show =<< bindings + + -- default get "/" (text "at root") @@ -24,3 +49,4 @@ -- treat .hs extension as text/plain mime "hs" "text/plain" + diff --git a/views/hello.html b/views/hello.html new file mode 100644 --- /dev/null +++ b/views/hello.html @@ -0,0 +1,6 @@ + +hello + +

hello $user

+ +