simple 0.8.1.0 → 2.0.0
raw patch · 15 files changed
Files
- CHANGELOG.md +10/−0
- simple.cabal +34/−13
- src/Web/Frank.hs +8/−3
- src/Web/REST.hs +1/−1
- src/Web/Simple.hs +2/−0
- src/Web/Simple/Controller.hs +13/−14
- src/Web/Simple/Controller/Exception.hs +30/−0
- src/Web/Simple/Controller/Trans.hs +18/−12
- src/Web/Simple/Responses.hs +6/−1
- src/Web/Simple/Static.hs +8/−0
- src/Web/Simple/Templates.hs +67/−42
- src/smpl.hs +2/−4
- template/Common_hs.tmpl +1/−1
- template/package_cabal.tmpl +3/−2
- test/Spec.hs +7/−6
+ CHANGELOG.md view
@@ -0,0 +1,10 @@+# Version 0.11.1 (2016-01-11)++* Fixes test dependencies that precluded tests from compiling++# Version 0.11.0.0 (2015-11-23)++* Minimize methods in `HasTemplates` and extract everything else into functions++* Add `layoutObject` method that allows customizing the value passed to the+ layout
simple.cabal view
@@ -1,5 +1,5 @@ name: simple-version: 0.8.1.0+version: 2.0.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -33,6 +33,7 @@ category: Web build-type: Simple cabal-version: >=1.10+extra-source-files: LICENSE CHANGELOG.md data-files: template/*.tmpl @@ -40,6 +41,7 @@ hs-source-dirs: src Main-Is: smpl.hs ghc-options: -Wall -fno-warn-unused-do-bind+ default-language: Haskell2010 build-depends: base < 6 , aeson@@ -50,11 +52,12 @@ , filepath , process , setenv- , simple-templates >= 0.7.0+ , simple-templates >= 2.0.0 , text , unordered-containers , vector- default-language: Haskell2010+ other-modules:+ Paths_simple library hs-source-dirs: src@@ -62,19 +65,20 @@ base < 6 , aeson , base64-bytestring+ , blaze-builder , bytestring- , conduit , directory , filepath , mime-types- , monad-peel+ , monad-control >= 1.0.0.0 , mtl , simple-templates >= 0.7.0- , wai >= 2.0+ , wai >= 3.0 , wai-extra , http-types , text , transformers+ , transformers-base , unordered-containers , vector @@ -84,6 +88,7 @@ Web.Simple, Web.Simple.Auth, Web.Simple.Controller,+ Web.Simple.Controller.Exception, Web.Simple.Controller.Trans, Web.Simple.Responses, Web.Simple.Static,@@ -94,19 +99,35 @@ test-suite test-simple type: exitcode-stdio-1.0- hs-source-dirs: test+ hs-source-dirs: test, src main-is: Spec.hs+ default-language: Haskell2010 build-depends: base < 6- , hspec- , HUnit- , monad-peel+ , aeson+ , base64-bytestring+ , blaze-builder+ , bytestring+ , directory+ , filepath+ , mime-types+ , monad-control >= 1.0.0.0 , mtl- , simple+ , simple-templates >= 0.7.0+ , wai >= 3.0+ , wai-extra+ , http-types+ , hspec+ , hspec-contrib+ , text , transformers- , wai+ , transformers-base+ , unordered-containers+ , vector+ other-modules:+ Web.Simple.Controller.Trans,+ Web.Simple.Responses source-repository head type: git location: http://github.com/alevy/simple.git-
src/Web/Frank.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} {- | Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating routes. It is composable with all 'ToApplication' types, but is designed to be used@@ -11,11 +11,11 @@ main = run 3000 $ controllerApp () $ do get \"\/\" $ do req <- request- return $ okHtml $ fromString $+ respond $ okHtml $ fromString $ \"Welcome Home \" ++ (show $ serverName req) get \"\/user\/:id\" $ do userId \<- queryParam \"id\" >>= fromMaybe \"\"- return $ ok \"text/json\" $ fromString $+ respond $ ok \"text/json\" $ fromString $ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\" put \"\/user\/:id\" $ do ...@@ -26,6 +26,7 @@ ( get , post , put+ , patch , delete , options ) where@@ -51,6 +52,10 @@ -- | Matches the PUT method on the given URL pattern put :: Monad m => Text -> ControllerT s m a -> ControllerT s m () put = frankMethod PUT++-- | Matches the PATCH method on the given URL pattern+patch :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()+patch = frankMethod PATCH -- | Matches the DELETE method on the given URL pattern delete :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
src/Web/REST.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Trustworthy, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE Safe, FlexibleInstances, OverloadedStrings #-} {- | REST is a DSL for creating routes using RESTful HTTP verbs.
src/Web/Simple.hs view
@@ -16,6 +16,7 @@ module Web.Simple ( module Web.Simple.Responses , module Web.Simple.Controller+ , module Web.Simple.Controller.Exception , module Web.Simple.Static , module Network.Wai -- * Overview@@ -34,6 +35,7 @@ import Network.Wai import Web.Simple.Responses import Web.Simple.Controller+import Web.Simple.Controller.Exception import Web.Simple.Static {- $Overview
src/Web/Simple/Controller.hs view
@@ -41,22 +41,17 @@ , redirectBackOr -- * Exception handling , T.ControllerException- , module Control.Exception.Peel- -- * Integrating other WAI components- , fromApp -- * Low-level utilities , body , hoistEither ) where -import Control.Exception.Peel import Control.Monad.IO.Class+import Blaze.ByteString.Builder 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 import Data.Text (Text) import Network.HTTP.Types import Network.Wai@@ -92,7 +87,9 @@ -- | Convert the controller into an 'Application' controllerApp :: s -> Controller s a -> Application-controllerApp = T.controllerApp+controllerApp s ctrl req responseFunc = do+ resp <- T.controllerApp s ctrl req+ responseFunc resp -- | Provide a response --@@ -100,11 +97,6 @@ respond :: Response -> Controller s a respond = T.respond ---- | Lift an application to a controller-fromApp :: Application -> Controller s ()-fromApp = T.fromApp- -- | Matches on the hostname from the 'Request'. The route only succeeds on -- exact matches. routeHost :: S.ByteString -> Controller s a -> Controller s ()@@ -220,8 +212,15 @@ -- | Reads and returns the body of the HTTP request. body :: Controller s L8.ByteString body = do- req <- request- liftIO $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)+ bodyProducer <- getRequestBodyChunk `fmap` request+ liftIO $ do+ result <- consume mempty bodyProducer+ return $ toLazyByteString result+ where consume bldr prod = do+ next <- prod+ if S.null next then+ return bldr+ else consume (mappend bldr (fromByteString next)) prod -- | Returns the value of the given request header or 'Nothing' if it is not -- present in the HTTP request.
+ src/Web/Simple/Controller/Exception.hs view
@@ -0,0 +1,30 @@+module Web.Simple.Controller.Exception where++import qualified Control.Exception as E+import Control.Monad.Trans.Control+import Web.Simple.Controller++onException :: Controller s a -> Controller s b -> Controller s a+onException act handler = control $ \runInM -> do+ runInM act `E.onException` runInM handler++finally :: Controller s a -> Controller s b -> Controller s a+finally act next = control $ \runInM -> E.mask $ \restore -> do+ r <- restore (runInM act) `E.onException` (runInM next)+ _ <- runInM next+ return r++bracket :: Controller s a -> (a -> Controller s b)+ -> (a -> Controller s c) -> Controller s c+bracket aquire release act = control $ \runInM -> E.mask $ \restore -> do+ let release' a = runInM $ restoreM a >>= release+ a <- runInM aquire+ r <- (restore $ runInM $ restoreM a >>= act) `E.onException` release' a+ _ <- release' a+ return r++handle :: E.Exception e => (e -> Controller s a) -> Controller s a+ -> Controller s a+handle handler act = control $ \runInM -> do+ E.handle (runInM . handler) $ runInM act+
src/Web/Simple/Controller/Trans.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {- | 'ControllerT' provides a convenient syntax for writting 'Application' code as a Monadic action with access to an HTTP request as well as app@@ -23,14 +24,15 @@ -} module Web.Simple.Controller.Trans where +import Control.Exception import Control.Monad hiding (guard)+import Control.Monad.Base import Control.Monad.IO.Class-import Control.Monad.IO.Peel import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans.Class+import Control.Monad.Trans.Control import Control.Applicative-import Control.Exception.Peel import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.List (find)@@ -43,7 +45,6 @@ import Network.Wai import Web.Simple.Responses - -- | The ControllerT Monad is both a State-like monad which, when run, computes -- either a 'Response' or a result. Within the ControllerT Monad, the remainder -- of the computation can be short-circuited by 'respond'ing with a 'Response'.@@ -59,11 +60,11 @@ Right result -> (Right $ f result, st) instance (Monad m, Functor m) => Applicative (ControllerT s m) where- pure = return+ pure a = ControllerT $ \st _ -> return $ (Right a, st) (<*>) = ap instance Monad m => Monad (ControllerT s m) where- return a = ControllerT $ \st _ -> return $ (Right a, st)+ return = pure (ControllerT act) >>= fn = ControllerT $ \st0 req -> do (eres, st) <- act st0 req case eres of@@ -94,13 +95,18 @@ instance MonadIO m => MonadIO (ControllerT s m) where liftIO = lift . liftIO -instance MonadPeelIO (ControllerT s IO) where- peelIO = do- s <- controllerState- req <- request- return $ \ctrl -> do- res <- runController ctrl s req- return $ ControllerT $ \_ _ -> return res+instance Monad m => MonadFail (ControllerT s m) where+ fail = err++instance (Applicative m, Monad m, MonadBase m m) => MonadBase m (ControllerT s m) where+ liftBase = liftBaseDefault++instance MonadBaseControl m m => MonadBaseControl m (ControllerT s m) where+ type StM (ControllerT s m) a = (Either Response a, s)+ liftBaseWith fn = ControllerT $ \st req -> do+ res <- fn $ \act -> runController act st req+ return (Right res, st)+ restoreM (a, s) = ControllerT $ \_ _ -> return (a, s) hoistEither :: Monad m => Either Response a -> ControllerT s m a hoistEither eith = ControllerT $ \st _ -> return (eith, st)
src/Web/Simple/Responses.hs view
@@ -3,7 +3,7 @@ -- | This module defines some convenience functions for creating responses. module Web.Simple.Responses- ( ok, okHtml, okJson+ ( ok, okHtml, okJson, okXml , movedTo, redirectTo , badRequest, requireBasicAuth, forbidden , notFound@@ -39,6 +39,11 @@ -- given resposne body okJson :: L8.ByteString -> Response okJson = ok (S8.pack "application/json")++-- | Creates a 200 (OK) 'Response' with content-type \"application/xml\" and the+-- given resposne body+okXml :: L8.ByteString -> Response+okXml = ok (S8.pack "application/xml") -- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to -- that URL.
src/Web/Simple/Static.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Web.Simple.Static where import Control.Monad@@ -19,4 +20,11 @@ respond $ responseFile status200 [(hContentType, defaultMimeLookup $ T.pack $ takeFileName fp)] fp Nothing+ when (null $ takeExtension fp) $ do+ let fpIdx = fp </> "index.html"+ existsIdx <- liftIO $ doesFileExist fpIdx+ when existsIdx $ do+ respond $ responseFile status200+ [(hContentType, "text/html")]+ fpIdx Nothing
src/Web/Simple/Templates.hs view
@@ -2,14 +2,15 @@ {-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-} {-# LANGUAGE DefaultSignatures #-} module Web.Simple.Templates- ( HasTemplates(..)- , defaultGetTemplate, defaultRender, defaultFunctionMap+ ( HasTemplates(..), render, renderPlain, renderLayout, renderLayoutTmpl+ , defaultGetTemplate, defaultFunctionMap, defaultLayoutObject , H.fromList , Function(..), ToFunction(..), FunctionMap ) where import Control.Monad.IO.Class import Data.Aeson+import qualified Data.Aeson.KeyMap as K import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as H@@ -54,40 +55,72 @@ default getTemplate :: MonadIO m => FilePath -> ControllerT hs m 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 -> ControllerT hs m ()- render = defaultRender+ -- | The `Value` passed to a layout given the rendered view template and the+ -- value originally passed to the view template. By default, produces an+ -- `Object` with "yield", containing the rendered view, and "page", containing+ -- the value originally passed to the view.+ layoutObject :: (ToJSON pageContent, ToJSON pageVal)+ => pageContent -> pageVal -> ControllerT hs m Value+ layoutObject = defaultLayoutObject - -- | Same as 'render' but without a template.- renderPlain :: ToJSON a => FilePath -> a -> ControllerT hs m ()- 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+defaultLayoutObject :: (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal)+ => pageContent -> pageVal -> ControllerT hs m Value+defaultLayoutObject pageContent pageVal = return $+ object ["yield" .= pageContent, "page" .= pageVal] - -- | Render a view using the layout named by the first argument.- renderLayout :: ToJSON a => FilePath -> FilePath -> a -> ControllerT hs m ()- renderLayout lfp fp val = do- layout <- getTemplate lfp- renderLayout' layout fp val+-- | Render a view using the layout named by the first argument.+renderLayout :: (HasTemplates m hs, ToJSON a)+ => FilePath -> FilePath -> a -> ControllerT hs m ()+renderLayout lfp fp val = do+ layout <- getTemplate lfp+ viewDir <- viewDirectory+ view <- getTemplate (viewDir </> fp)+ let mime = defaultMimeLookup $ T.pack $ takeFileName fp+ renderLayoutTmpl layout view val mime - -- | Same as 'renderLayout' but uses an already compiled layout.- renderLayout' :: ToJSON a => Template -> FilePath -> a -> ControllerT hs m ()- renderLayout' layout fp val = do- fm <- functionMap- dir <- viewDirectory- tmpl <- getTemplate (dir </> fp)- let pageContent = 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] +-- | Same as 'renderLayout' but uses already compiled layouts.+renderLayoutTmpl :: (HasTemplates m hs, ToJSON a)+ => Template -> Template -> a+ -> S.ByteString -> ControllerT hs m ()+renderLayoutTmpl layout view val mime = do+ fm <- functionMap+ let pageContent = renderTemplate view fm $ toJSON val+ value <- layoutObject pageContent val+ let result = renderTemplate layout fm value+ respond $ ok mime $ L.fromChunks . (:[]) . encodeUtf8 $ result++-- | Renders a view template with the default layout and a global used to+-- evaluate variables in the template.+render :: (HasTemplates m hs , Monad m, ToJSON a)+ => FilePath -- ^ Template to render+ -> a -- ^ Aeson `Value` to pass to the template+ -> ControllerT hs m ()+render fp val = do+ mlayout <- defaultLayout+ case mlayout of+ Nothing -> renderPlain fp val+ Just layout -> do+ viewDir <- viewDirectory+ view <- getTemplate (viewDir </> fp)+ let mime = defaultMimeLookup $ T.pack $ takeFileName fp+ renderLayoutTmpl layout view val mime++-- | Same as 'render' but without a template.+renderPlain :: (HasTemplates m hs, ToJSON a)+ => FilePath -- ^ Template to render+ -> a -- ^ Aeson `Value` to pass to the template+ -> ControllerT hs m ()+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+ defaultGetTemplate :: (HasTemplates m hs, MonadIO m) => FilePath -> ControllerT hs m Template defaultGetTemplate fp = do@@ -96,14 +129,6 @@ Left str -> fail str Right tmpl -> return tmpl -defaultRender :: (HasTemplates m hs , Monad m, ToJSON a)- => FilePath -> a -> ControllerT hs m ()-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)@@ -111,14 +136,14 @@ valueLength :: Value -> Value valueLength (Array arr) = toJSON $ V.length arr-valueLength (Object obj) = toJSON $ H.size obj+valueLength (Object obj) = toJSON $ K.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 (Object obj) = toJSON $ K.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
@@ -4,20 +4,18 @@ module Main (main) where 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.Text.Encoding as T-import Data.Monoid (mempty) import Data.Version import System.Console.CmdArgs import System.Directory import System.FilePath-import System.Environment+import System.Environment (getEnvironment)+import System.SetEnv (setEnv) import System.Exit-import System.SetEnv import System.Process import Web.Simple.Templates.Language
template/Common_hs.tmpl view
@@ -7,7 +7,7 @@ $if(include_sessions)$import Web.Simple.Session$endif$ $if(include_postgresql)$import Web.Simple.PostgreSQL$endif$ -data AppSettings = AppSettings { $if(include_postgresql)$appDB :: PostgreSQLConn$if(include_postgresql)$+data AppSettings = AppSettings { $if(include_postgresql)$appDB :: PostgreSQLConn$if(include_sessions)$ , appSession :: Maybe Session$endif$$else$$if(include_sessions)$appSession :: Maybe Session$endif$$endif$ } newAppSettings :: IO AppSettings
template/package_cabal.tmpl view
@@ -1,4 +1,4 @@-name: $module$+name: $appname$ version: 0.0.0.0 --author: YOUR NAME --maintainer: your@email.com@@ -16,5 +16,6 @@ , wai-extra , warp$if(include_sessions)$ , simple-session >= 0.8.0$endif$$if(include_postgresql)$- , simple-postgresql-orm >= 0.8.0$endif$+ , simple-postgresql-orm >= 0.8.0+ , postgresql-orm$endif$
test/Spec.hs view
@@ -3,10 +3,10 @@ import Control.Monad import Control.Monad.IO.Class-import Control.Monad.IO.Peel import Control.Monad.Trans+import Control.Monad.Trans.Control import Test.Hspec-import Test.Hspec.HUnit+import Test.Hspec.Contrib.HUnit import Network.Wai import Web.Simple.Controller.Trans import Web.Simple.Responses@@ -110,13 +110,14 @@ defaultRequest { requestHeaderHost = Nothing } return () - describe "MonadPeelIO instance" $ do+ describe "MonadBaseControl instance" $ do it "Preserves state changes in inner block" $ do let expected = 1234 ctrl = do- k <- peelIO- join $ liftIO $ k $ do- putState expected+ putState 555+ res <- liftBaseWith $ \f -> do+ f $ putState expected+ restoreM res s <- snd `fmap` runController ctrl 0 defaultRequest s `shouldBe` expected