loli power!
") + -- simple + get "/hello" (text "hello world") + + -- io + get "/cabal" $ text =<< io (readFile "loli.cabal") - public (Just ".") ["/src"] + -- route captures + get "/say/:user/:verb" $ do + text . show =<< captured + -- html output + get "/html" (html "loli power!
") + + -- default + get "/" (text "at root") + + -- public serve, only allows /src + public (Just ".") ["/src"] + + -- treat .hs extension as text/plain mime "hs" "text/plain" 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 @@ -13,3 +13,6 @@ where default_content_type :: String default_content_type = "text/plain; charset=UTF-8" + +loli_captures_prefix :: String +loli_captures_prefix = "loli_captures_" 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,27 +1,31 @@ module Network.Loli.DSL where - -import MPS -import Prelude hiding ((.), (>), (^)) -import Network.Loli.Engine +import Control.Monad.State +import Data.ByteString.Lazy.UTF8 (fromString) import Hack import Hack.Contrib.Constants -import Hack.Contrib.Response -import Data.ByteString.Lazy.UTF8 (fromString) import Hack.Contrib.Middleware.Static +import Hack.Contrib.Response +import MPS +import Network.Loli.Engine +import Network.Loli.Config +import Prelude hiding ((.), (>), (^)) +import qualified Control.Monad.State as State + app :: Application -> AppUnit -app = set_application > update +app f = do + get_env >>= (f > io) >>= set_response text :: String -> AppUnit text x = do - response $ set_content_type _TextPlain - response $ set_body (x.fromString) + update_response $ set_content_type _TextPlain + update_response $ set_body (x.fromString) html :: String -> AppUnit html x = do - response $ set_content_type _TextHtml - response $ set_body (x.fromString) + update_response $ set_content_type _TextHtml + update_response $ set_body (x.fromString) get, put, delete, post :: String -> AppUnit -> Unit get = route GET @@ -37,3 +41,14 @@ public :: Maybe String -> [String] -> Unit public r xs = middleware $ static r xs + +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)) + 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,46 +2,37 @@ module Network.Loli.Engine where -import Control.Monad.State +import Control.Monad.State hiding (join) import Data.Default import Data.List (find) +import Data.Maybe import Hack -import Hack.Contrib.Middleware.Censor -import Hack.Contrib.Middleware.Config import Hack.Contrib.Middleware.NotFound import Hack.Contrib.Response import Hack.Contrib.Utils hiding (get, put) import MPS import Network.Loli.Config +import Network.Loli.Config import Prelude hiding ((.), (/), (>), (^)) - type RoutePath = (RequestMethod, String, AppUnit) type EnvFilter = Env -> Env type ResponseFilter = Response -> Response type Param = (String, String) data AppState = AppState { - application :: Application - , env_filters :: [EnvFilter] - , response_filters :: [ResponseFilter] - , path :: String + env :: Env + , response :: Response } instance Default AppState where - def = AppState def [id] [id] def + def = AppState def def -type AppUnit = State AppState () +type AppUnitT a = StateT AppState IO a +type AppUnit = AppUnitT () -run_app :: String -> AppUnit -> Application -run_app path unit = - let state = execState unit def {path} - before = state.env_filters.map config - after = state.response_filters.map (to_io_filter > censor) - in - state.application.use (before ++ after) - where - to_io_filter f = \x -> return (f x) +run_app :: AppUnit -> Application +run_app unit = \env -> execStateT unit def {env} ^ response router :: [RoutePath] -> Middleware router h app' = \env'' -> @@ -54,12 +45,44 @@ in case h.find (match_route env'') of Nothing -> app' env'' - Just (_, location, app_state) -> - run_app location app_state (mod_env location) + Just (_, template, app_state) -> do + let (location, params) = parse_params template path .fromJust + run_app app_state (mod_env location .merge_captured params) where - match_route env' (method, path, _) = - env'.request_method.is method && env'.path_info.starts_with path + 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} + +parse_params :: String -> String -> Maybe (String, [(String, String)]) +parse_params t s = + let template_tokens = t.split "/" + url_tokens = s.split "/" + in + if url_tokens.length < template_tokens.length + then Nothing + else + let rs = zipWith capture template_tokens url_tokens + in + if rs.all isJust + then + let location = url_tokens.take (template_tokens.length).join "/" + in + Just $ (location, rs.map fromJust.filter isJust.map fromJust) + else Nothing + + where + capture x y + | x.starts_with ":" = Just $ Just (x.tail, y) + | x == y = Just Nothing + | otherwise = Nothing + + data Loli = Loli { @@ -71,7 +94,8 @@ instance Default Loli where def = Loli def def def -type Unit = State Loli () +type UnitT a = State Loli a +type Unit = UnitT () @@ -90,9 +114,6 @@ in use [pre, mime_filter, stack, loli_app] -set_application :: Application -> AppState -> AppState -set_application application x = x { application } - update :: (MonadState a m, Functor m) => (a -> a) -> m () update f = get ^ f >>= put @@ -112,21 +133,20 @@ add_mime :: String -> String -> Loli -> Loli add_mime k v s = let xs = s.mimes in s {mimes = xs.insert_last (k, v)} -add_env_filter :: EnvFilter -> AppState -> AppState -add_env_filter x s = - let xs = s.env_filters in s {env_filters = xs.insert_last x} - -add_response_filter :: ResponseFilter -> AppState -> AppState -add_response_filter x s = - let xs = s.response_filters in s {response_filters = xs.insert_last x} +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 -request :: EnvFilter-> AppUnit -request x = add_env_filter x .update +get_response :: AppUnitT Response +get_response = get ^ response -response :: ResponseFilter -> AppUnit -response x = add_response_filter x .update +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/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -2,10 +2,25 @@ import Hack.Handler.Happstack main = run . loli $ do + + -- simple + get "/hello" (text "hello world") - get "/hello" (text "hello world") - get "/" (html "loli power!
") + -- io + get "/cabal" $ text =<< io (readFile "loli.cabal") + -- route captures + get "/say/:user/:verb" $ do + text . show =<< captured + + -- html output + get "/html" (html "loli power!
") + + -- default + get "/" (text "at root") + + -- public serve, only allows /src public (Just ".") ["/src"] - + + -- treat .hs extension as text/plain mime "hs" "text/plain"