simple 0.6.0 → 0.7.0
raw patch · 12 files changed
+273/−97 lines, 12 filesdep +aesondep +mime-typesdep +simple-templatesdep −stringsearchdep ~wai
Dependencies added: aeson, mime-types, simple-templates, unordered-containers, vector
Dependencies removed: stringsearch
Dependency ranges changed: wai
Files
- simple.cabal +17/−8
- src/Web/Simple.hs +2/−0
- src/Web/Simple/Controller.hs +10/−18
- src/Web/Simple/Static.hs +22/−0
- src/Web/Simple/Templates.hs +125/−0
- src/smpl.hs +68/−28
- template/Application_hs.tmpl +4/−3
- template/Common_hs.tmpl +14/−27
- template/Main_hs.tmpl +1/−1
- template/index_html.tmpl +1/−1
- template/main_html.tmpl +3/−3
- template/package_cabal.tmpl +6/−8
simple.cabal view
@@ -1,5 +1,5 @@ name: simple-version: 0.6.0+version: 0.7.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -38,36 +38,43 @@ executable smpl hs-source-dirs: src Main-Is: smpl.hs- ghc-options: -Wall+ ghc-options: -Wall -fno-warn-unused-do-bind build-depends: base < 6+ , aeson , attoparsec- , base64-bytestring , bytestring , cmdargs- , conduit , directory , filepath , process , setenv- , stringsearch+ , simple-templates >= 0.7.0+ , text+ , unordered-containers+ , vector default-language: Haskell2010 library hs-source-dirs: src build-depends: base < 6+ , aeson , base64-bytestring+ , bytestring , conduit , directory , filepath- , wai+ , mime-types+ , monad-peel+ , simple-templates >= 0.7.0+ , wai >= 2.0 , wai-extra , http-types , text , transformers- , bytestring- , monad-peel+ , unordered-containers+ , vector ghc-options: -Wall -fno-warn-unused-do-bind @@ -76,6 +83,8 @@ Web.Simple.Auth, Web.Simple.Controller, Web.Simple.Responses,+ Web.Simple.Static,+ Web.Simple.Templates, Web.Frank, Web.REST default-language: Haskell2010
src/Web/Simple.hs view
@@ -15,6 +15,7 @@ module Web.Simple ( module Web.Simple.Responses , module Web.Simple.Controller+ , module Web.Simple.Static , module Network.Wai -- * Overview -- $Overview@@ -32,6 +33,7 @@ import Network.Wai import Web.Simple.Responses import Web.Simple.Controller+import Web.Simple.Static {- $Overview #overview#
src/Web/Simple/Controller.hs view
@@ -24,7 +24,7 @@ -- * Example -- $Example -- * Controller Monad- Controller(..), runController, runControllerIO+ Controller(..), runController , controllerApp, controllerState, putState , request, localRequest, respond , requestHeader@@ -57,6 +57,7 @@ import Control.Monad.IO.Peel import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Conduit import qualified Data.Conduit.List as CL@@ -79,7 +80,7 @@ -- of the computation can be short-circuited by 'respond'ing with a 'Response'. newtype Controller r a = Controller (ControllerState r ->- ResourceT IO (Either Response a, ControllerState r))+ IO (Either Response a, ControllerState r)) instance Functor (Controller r) where fmap f (Controller act) = Controller $ \st0 -> do@@ -105,11 +106,6 @@ instance MonadIO (Controller r) where liftIO act = Controller $ \st -> liftIO act >>= \r -> return (Right r, st) -liftResourceT :: ResourceT IO a -> Controller r a-liftResourceT act = Controller $ \st -> do- a <- act- return (Right a, st)- hoistEither :: Either Response a -> Controller r a hoistEither eith = Controller $ \st -> return (eith, st) @@ -118,7 +114,7 @@ r <- controllerState req <- request return $ \ctrl -> do- res <- runControllerIO ctrl r req+ res <- runController ctrl r req return $ hoistEither res ask :: Controller r (r, Request)@@ -150,13 +146,9 @@ runController ctrl r req >>= either return (const $ return notFound) -runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)+runController :: Controller r a -> r -> Request -> IO (Either Response a) runController (Controller fun) r req = fst `fmap` fun (r,req) --- | Run a 'Controller' in the @IO@ monad-runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)-runControllerIO ctrl r = runResourceT . runController ctrl r- -- | Decline to handle the request -- -- @pass >> c === c@@@ -175,13 +167,13 @@ fromApp :: ToApplication a => a -> Controller r () fromApp app = do req <- request- resp <- liftResourceT $ (toApp app) req+ resp <- liftIO $ (toApp app) req respond resp -- | Matches on the hostname from the 'Request'. The route only succeeds on -- exact matches. routeHost :: S.ByteString -> Controller r a -> Controller r ()-routeHost host = guardReq $ (host ==) . serverName+routeHost host = guardReq $ \req -> host == (fromMaybe "" $ requestHeaderHost req) -- | Matches if the path is empty. --@@ -335,16 +327,16 @@ -- respond $ redirectTo \"/\" -- Nothing -> redirectBack -- @-parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])+parseForm :: Controller r ([Param], [(S.ByteString, FileInfo L.ByteString)]) parseForm = do req <- request- liftResourceT $ parseRequestBody tempFileBackEnd req+ liftIO $ parseRequestBody lbsBackEnd req -- | Reads and returns the body of the HTTP request. body :: Controller r L8.ByteString body = do req <- request- liftResourceT $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)+ liftIO $ L8.fromChunks `fmap` (requestBody req $$ CL.consume) -- | Returns the value of the given request header or 'Nothing' if it is not -- present in the HTTP request.
+ src/Web/Simple/Static.hs view
@@ -0,0 +1,22 @@+module Web.Simple.Static where++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Text as T+import Network.Wai+import Network.HTTP.Types+import Network.Mime+import Web.Simple.Controller+import System.Directory+import System.FilePath++serveStatic :: FilePath -> Controller a ()+serveStatic baseDir = do+ req <- request+ let fp = foldl (</>) baseDir (map T.unpack $ pathInfo req)+ exists <- liftIO $ doesFileExist fp+ when exists $+ respond $ responseFile status200+ [(hContentType, defaultMimeLookup $ T.pack $ takeFileName fp)]+ fp Nothing+
+ src/Web/Simple/Templates.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Simple.Templates+ ( HasTemplates(..)+ , defaultGetTemplate, defaultRender, defaultFunctionMap+ , H.fromList+ , Function(..), ToFunction(..), FunctionMap+ ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Aeson+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import Data.Text.Encoding+import qualified Data.Vector as V+import Network.Mime+import System.FilePath+import Web.Simple.Controller (Controller, respond)+import Web.Simple.Responses (ok)+import Web.Simple.Templates.Language++class HasTemplates hs where+ -- | The layout to use by default. Layouts are just templates that embed+ -- views. They are rendered with the a global object containing the rendered+ -- view in the \"yield\" field, and the object the view was rendered with in+ -- the \"page\" field. By default, no template is used.+ defaultLayout :: Controller hs (Maybe Template)+ defaultLayout = return Nothing++ -- | The directory to look for views passed to 'render'. This defaults to+ -- \"views\", so+ --+ -- @+ -- render \"index.html.tmpl\" ...+ -- @+ --+ -- will look for a view template in \"views/index.html.tmpl\".+ viewDirectory :: Controller hs FilePath+ viewDirectory = return "views"++ -- | A map of pure functions that can be called from within a template. See+ -- 'FunctionMap' and 'Function' for details.+ functionMap :: Controller hs FunctionMap+ functionMap = return defaultFunctionMap++ -- | Function to use to get a template. By default, it looks in the+ -- 'viewDirectory' for the given file name and compiles the file into a+ -- template. This can be overriden to, for example, cache compiled templates+ -- in memory.+ getTemplate :: FilePath -> Controller hs Template+ getTemplate = defaultGetTemplate++ -- | Renders a view template with the default layout and a global used to+ -- evaluate variables in the template.+ render :: ToJSON a => FilePath -> a -> Controller hs ()+ render = defaultRender++ -- | Same as 'render' but without a template.+ renderPlain :: ToJSON a => FilePath -> a -> Controller hs ()+ renderPlain fp val = do+ fm <- functionMap+ dir <- viewDirectory+ tmpl <- getTemplate (dir </> fp)+ let pageContent =+ L.fromChunks . (:[]) . encodeUtf8 $+ renderTemplate tmpl fm $ toJSON val+ let mime = defaultMimeLookup $ T.pack $ takeFileName fp+ respond $ ok mime pageContent++ -- | Render a view using the layout named by the first argument.+ renderLayout :: ToJSON a => FilePath -> FilePath -> a -> Controller hs ()+ renderLayout lfp fp val = do+ layout <- getTemplate lfp+ renderLayout' layout fp val++ -- | Same as 'renderLayout' but uses an already compiled layout.+ renderLayout' :: ToJSON a => Template -> FilePath -> a -> Controller hs ()+ renderLayout' layout fp val = do+ fm <- functionMap+ dir <- viewDirectory+ tmpl <- getTemplate (dir </> fp)+ let pageContent =+ L.fromChunks . (:[]) . encodeUtf8 $+ renderTemplate tmpl fm $ toJSON val+ let mime = defaultMimeLookup $ T.pack $ takeFileName fp+ respond $ ok mime $ L.fromChunks . (:[]) . encodeUtf8 $+ renderTemplate layout fm $ object ["yield" .= pageContent, "page" .= val]++defaultGetTemplate :: HasTemplates hs => FilePath -> Controller hs Template+defaultGetTemplate fp = do+ eres <- compileTemplate . decodeUtf8 <$>+ liftIO (S.readFile fp)+ case eres of+ Left str -> fail str+ Right tmpl -> return tmpl++defaultRender :: (HasTemplates hs , ToJSON a)+ => FilePath -> a -> Controller hs ()+defaultRender fp val = do+ mlayout <- defaultLayout+ case mlayout of+ Nothing -> renderPlain fp val+ Just layout -> renderLayout' layout fp val++defaultFunctionMap :: FunctionMap+defaultFunctionMap = H.fromList+ [ ("length", toFunction valueLength)+ , ("null", toFunction valueNull)]++valueLength :: Value -> Value+valueLength (Array arr) = toJSON $ V.length arr+valueLength (Object obj) = toJSON $ H.size obj+valueLength (String str) = toJSON $ T.length str+valueLength Null = toJSON (0 :: Int)+valueLength _ = error "length only valid for arrays, objects and strings"++valueNull :: Value -> Value+valueNull (Array arr) = toJSON $ V.null arr+valueNull (Object obj) = toJSON $ H.null obj+valueNull (String str) = toJSON $ T.null str+valueNull Null = toJSON True+valueNull _ = error "null only valid for arrays, objects and strings"+
src/smpl.hs view
@@ -3,11 +3,15 @@ -- | The `smpl` utility for helping a user setup a Simple web project. module Main (main) where -import Prelude hiding (writeFile, FilePath)+import Prelude hiding (writeFile, FilePath, all)+import Control.Applicative+import Control.Monad (when)+import Data.Aeson import Data.Char import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Lazy.Search as L8+import qualified Data.Text.Encoding as T+import Data.Monoid (mempty)+import Data.Version import System.Console.CmdArgs import System.Directory import System.FilePath@@ -15,6 +19,7 @@ import System.Exit import System.SetEnv import System.Process+import Web.Simple.Templates.Language import Paths_simple @@ -23,7 +28,11 @@ { port :: Int , moduleName :: String } |- Create { appDir :: FilePath }+ Create { appDir :: FilePath+ , includeTemplates :: Bool+ , includePostgresql :: Bool+ , includeSessions :: Bool+ , includeAll :: Bool } deriving (Show, Data, Typeable) main :: IO ()@@ -31,13 +40,34 @@ setEnv "ENV" "development" myenv <- getEnvironment let myport = maybe 3000 read $ lookup "PORT" myenv- let develMode = cmdArgsMode $ modes+ let develModes = modes [ Server { port = myport &= typ "PORT" , moduleName = "Application" &= typ "MODULE" &= explicit &= name "module"- } &= auto- , Create { appDir = "" &= argPos 0 &= typ "app_dir" } ]- smpl <- cmdArgsRun develMode+ } &= auto &= help "Run a development server"+ &= details [+ "You must have wai-handler-devel installed " +++ "to run this command"]+ , Create { appDir = "" &= argPos 0 &= typ "app_dir"+ , includeTemplates = False+ &= help "include templates"+ &= explicit &= name "templates"+ &= groupname "Plugins"+ , includePostgresql = False+ &= help "include postgresql-orm"+ &= explicit &= name "postgresql"+ , includeSessions = False+ &= help "include cookie-based sessions"+ &= explicit &= name "sessions"+ , includeAll = False+ &= help+ ("include templates, cookie-based " +++ "sessions and postgresql")+ &= explicit &= name "all"}+ &= help "Create a new application in app_dir"]+ smpl <- cmdArgsRun $ cmdArgsMode $+ develModes &= (summary $+ "Simple web framework " ++ (showVersion version)) case smpl of Server p m -> do exitCode <- rawSystem "wai-handler-devel" [show p, m, "app"]@@ -46,7 +76,8 @@ putStrLn "You must install wai-handler devel first" exitWith $ ExitFailure 1 _ -> exitWith exitCode- Create dir -> createApplication dir+ Create dir tmpls pg sess all ->+ createApplication dir (all || tmpls) (all || sess) (all || pg) humanize :: String -> String humanize = capitalize@@ -66,38 +97,47 @@ capitalize ('_':xs) = go xs capitalize (x:xs) = (toUpper x):(go xs) -createApplication :: FilePath -> IO ()-createApplication dir = do+createApplication :: FilePath -> Bool -> Bool -> Bool -> IO ()+createApplication dir tmpls sessions postgresql = do let myAppName = takeBaseName $ dropTrailingPathSeparator dir modName = moduleCase myAppName- mappings = [ ("appname", myAppName)- , ("name", humanize myAppName)- , ("module", modName)]+ mappings = object+ [ "appname" .= myAppName+ , "name" .= humanize myAppName+ , "module" .= modName+ , "include_templates" .= tmpls+ , "include_sessions" .= sessions+ , "include_postgresql" .= postgresql] createDirectory dir- createDirectory $ dir </> "db"- createDirectory $ dir </> "db" </> "migrations"- createDirectory $ dir </> "views"- createDirectory $ dir </> "templates" createDirectory $ dir </> modName- copyTemplate ("template" </> "Main_hs.tmpl") (dir </> "Main.hs") mappings copyTemplate ("template" </> "Application_hs.tmpl") (dir </> "Application.hs") mappings copyTemplate ("template" </> "package_cabal.tmpl") (dir </> myAppName ++ ".cabal") mappings- copyTemplate ("template" </> "main_html.tmpl")- (dir </> "templates" </> "main.html") mappings- copyTemplate ("template" </> "index_html.tmpl")- (dir </> "views" </> "index.html") mappings copyTemplate ("template" </> "Common_hs.tmpl") (dir </> modName </> "Common.hs") mappings -copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()+ when postgresql $ do+ createDirectory $ dir </> "db"+ createDirectory $ dir </> "db" </> "migrations"++ when tmpls $ do+ createDirectory $ dir </> "views"+ createDirectory $ dir </> "layouts"+ copyTemplate ("template" </> "main_html.tmpl")+ (dir </> "layouts" </> "main.html") mappings+ copyTemplate ("template" </> "index_html.tmpl")+ (dir </> "views" </> "index.html") mappings++copyTemplate :: FilePath -> FilePath -> Value -> IO () copyTemplate orig target mappings = do- tmpl <- getDataFileName orig >>= L8.readFile- L8.writeFile target $- (flip . flip foldl) tmpl mappings $ \accm (key, val) ->- L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm+ etmpl <- compileTemplate <$> T.decodeUtf8 <$>+ (S8.readFile =<< getDataFileName orig)+ case etmpl of+ Left err -> fail err+ Right tmpl -> S8.writeFile target $ T.encodeUtf8 $+ renderTemplate tmpl mempty mappings
template/Application_hs.tmpl view
@@ -1,14 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} module Application where -import {{module}}.Common+import $module$.Common import Web.Simple+$if(include_templates)$import Web.Simple.Templates$endif$ app :: (Application -> IO ()) -> IO () app runner = do settings <- newAppSettings - runner $ controllerApp settings $ do+ runner $$ controllerApp settings $$ do+ routeTop $$ $if(include_templates)$render "index.html" ()$else$respond $$ okHtml "Hello World"$endif$ -- TODO: routes go here- respond $ okHtml "Hello World"
template/Common_hs.tmpl view
@@ -1,41 +1,28 @@-module {{module}}.Common where+module $module$.Common where import Control.Applicative import Web.Simple---- Uncomment the following lines for database, templates, and session support---import Web.Simple.PostgreSQL---import Web.Simple.Templates---import Web.Simple.Session--type AppSettings = ()--newAppSettings :: IO AppSettings-newAppSettings = return ()--{- Replace the above code with this comment block for database, templates and- - session support. Don't forget to uncomment the relevant packages in the- - cabal file and the import statements at the top of this file.+$if(include_templates)$import Web.Simple.Templates$endif$+$if(include_sessions)$import Web.Simple.Session$endif$+$if(include_postgresql)$import Web.Simple.PostgreSQL$endif$ -data AppSettings = AppSettings { appDB :: PostgreSQLConn- , appSession :: Maybe Session }+data AppSettings = AppSettings { $if(include_postgresql)$appDB :: PostgreSQLConn$if(include_postgresql)$+ , appSession :: Maybe Session$endif$$else$$if(include_sessions)$appSession :: Maybe Session$endif$$endif$ } newAppSettings :: IO AppSettings newAppSettings = do- db <- createPostgreSQLConn- return $ AppSettings { appDB = db , appSession = Nothing }-+ $if(include_postgresql)$db <- createPostgreSQLConn$endif$+ return $$ AppSettings$if(include_postgresql)$ db$endif$$if(include_sessions)$ Nothing$endif$+$if(include_postgresql)$ instance HasPostgreSQL AppSettings where postgreSQLConn = appDB-+$endif$$if(include_sessions)$ instance HasSession AppSettings where getSession = appSession setSession sess = do cs <- controllerState- putState $ cs { appSession = Just sess }-+ putState $$ cs { appSession = Just sess }+$endif$$if(include_templates)$ instance HasTemplates AppSettings where- defaultLayout = Just <$> getTemplate "templates/main.html"---}-+ defaultLayout = Just <$$> getTemplate "layouts/main.html"+$endif$
template/Main_hs.tmpl view
@@ -9,6 +9,6 @@ main :: IO () main = do env <- getEnvironment- let port = maybe 3000 read $ lookup "PORT" env+ let port = maybe 3000 read $$ lookup "PORT" env app (run port . logStdout)
template/index_html.tmpl view
@@ -1,1 +1,1 @@-Welcome to your new app! This file lives in "e;views/index.html"e;+Welcome to your new app! This file lives in "views/index.html"
template/main_html.tmpl view
@@ -2,7 +2,7 @@ <html> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">- <title>{{name}}</title>+ <title>$name$</title> <style> body { width: 25em;@@ -22,7 +22,7 @@ </style> </head> <body>- <h1><a href="/">{{name}}</a></h1>-$yield$+ <h1><a href="/">$name$</a></h1>+$$yield$$ </body> </html>
template/package_cabal.tmpl view
@@ -1,4 +1,4 @@-name: {{module}}+name: $module$ version: 0.0.0.0 --author: YOUR NAME --maintainer: your@email.com@@ -6,17 +6,15 @@ build-type: Simple cabal-version: >=1.8 -executable {{appname}}+executable $appname$ main-is: Main.hs ghc-options: -threaded -O2 build-depends: base- , simple >= 0.6.0+ , simple >= 0.7.0 , wai , wai-extra- , warp- -- uncomment for database, session and template support- -- , simple-postgresql-orm- -- , simple-session- -- , simple-templates+ , warp$if(include_sessions)$+ , simple-session >= 0.7.0$endif$$if(include_postgresql)$+ , simple-postgresql-orm >= 0.7.0$endif$