snap 0.9.2.2 → 0.10.0
raw patch · 44 files changed
+1387/−937 lines, 44 filesdep +comonaddep +dlistdep +errorsdep −data-lensdep −data-lens-templatedep ~heistdep ~pwstore-fastdep ~snap-core
Dependencies added: comonad, dlist, errors, lens, regex-posix
Dependencies removed: data-lens, data-lens-template
Dependency ranges changed: heist, pwstore-fast, snap-core, snap-server
Files
- CONTRIBUTORS +1/−0
- project_template/barebones/foo.cabal +2/−2
- project_template/default/foo.cabal +14/−15
- project_template/default/snaplets/heist/templates/base.tpl +1/−1
- project_template/default/src/Application.hs +2/−2
- project_template/default/src/Site.hs +4/−3
- project_template/tutorial/foo.cabal +8/−7
- project_template/tutorial/src/Part2.lhs +2/−0
- project_template/tutorial/src/Tutorial.lhs +5/−4
- snap.cabal +37/−33
- src/Snap.hs +2/−4
- src/Snap/Snaplet.hs +37/−34
- src/Snap/Snaplet/Auth.hs +3/−1
- src/Snap/Snaplet/Auth/AuthManager.hs +6/−10
- src/Snap/Snaplet/Auth/Backends/JsonFile.hs +12/−13
- src/Snap/Snaplet/Auth/Handlers.hs +112/−51
- src/Snap/Snaplet/Auth/SpliceHelpers.hs +80/−21
- src/Snap/Snaplet/Auth/Types.hs +39/−22
- src/Snap/Snaplet/Heist.hs +104/−51
- src/Snap/Snaplet/HeistNoClass.hs +216/−220
- src/Snap/Snaplet/Internal/Initializer.hs +89/−89
- src/Snap/Snaplet/Internal/LensT.hs +19/−27
- src/Snap/Snaplet/Internal/Lensed.hs +40/−39
- src/Snap/Snaplet/Internal/Types.hs +69/−30
- src/Snap/Snaplet/Session.hs +6/−7
- src/Snap/Snaplet/Session/Backends/CookieSession.hs +11/−9
- src/Snap/Snaplet/Session/SessionManager.hs +19/−5
- src/Snap/Snaplet/Test.hs +107/−0
- test/non-cabal-appdir/snaplets/heist/templates/page.tpl +1/−1
- test/runTestsAndCoverage.sh +3/−0
- test/snap-testsuite.cabal +116/−63
- test/suite/Blackbox/App.hs +47/−32
- test/suite/Blackbox/BarSnaplet.hs +12/−11
- test/suite/Blackbox/Common.hs +5/−3
- test/suite/Blackbox/EmbeddedSnaplet.hs +8/−9
- test/suite/Blackbox/FooSnaplet.hs +7/−6
- test/suite/Blackbox/Tests.hs +107/−83
- test/suite/Blackbox/Types.hs +2/−2
- test/suite/NestTest.hs +9/−10
- test/suite/Snap/Snaplet/Internal/LensT/Tests.hs +9/−7
- test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs +9/−7
- test/suite/Snap/Snaplet/Internal/RST/Tests.hs +1/−1
- test/suite/Snap/Snaplet/Internal/Tests.hs +2/−2
- test/suite/TestSuite.hs +2/−0
CONTRIBUTORS view
@@ -4,3 +4,4 @@ Carl Howells <chowells79@gmail.com> Chris Smith <cdsmith@gmail.com> Jurriën Stutterheim <j.stutterheim@me.com>+Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
project_template/barebones/foo.cabal view
@@ -19,8 +19,8 @@ bytestring >= 0.9.1 && < 0.11, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3,- snap-core >= 0.9.2 && < 0.10,- snap-server >= 0.9.2 && < 0.10+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
project_template/default/foo.cabal view
@@ -19,24 +19,23 @@ main-is: Main.hs Build-depends:- base >= 4 && < 5,- bytestring >= 0.9.1 && < 0.11,- data-lens >= 2.0.1 && < 2.11,- data-lens-template >= 2.1 && < 2.2,- heist >= 0.8 && < 0.9,- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- mtl >= 2 && < 3,- snap == 0.9.*,- snap-core >= 0.9.2 && <0.10,- snap-server >= 0.9.2 && <0.10,- snap-loader-static == 0.9.*,- text >= 0.11 && < 0.12,- time >= 1.1 && < 1.5,- xmlhtml >= 0.1+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ heist >= 0.10 && < 0.11,+ lens >= 3.7.0.1 && < 3.8,+ MonadCatchIO-transformers >= 0.2.1 && < 0.4,+ mtl >= 2 && < 3,+ snap >= 0.10 && < 0.11,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11,+ snap-loader-static >= 0.9 && < 0.10,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ xmlhtml >= 0.1 if flag(development) build-depends:- snap-loader-dynamic == 0.9.*+ snap-loader-dynamic == 0.10.* cpp-options: -DDEVELOPMENT -- In development mode, speed is already going to suffer, so skip -- the fancy optimization flags. Additionally, disable all
project_template/default/snaplets/heist/templates/base.tpl view
@@ -6,7 +6,7 @@ <body> <div id="content"> - <content/>+ <apply-content/> </div> </body>
project_template/default/src/Application.hs view
@@ -6,7 +6,7 @@ module Application where -------------------------------------------------------------------------------import Data.Lens.Template+import Control.Lens import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Auth@@ -19,7 +19,7 @@ , _auth :: Snaplet (AuthManager App) } -makeLens ''App+makeLenses ''App instance HasHeist App where heistLens = subSnaplet heist
project_template/default/src/Site.hs view
@@ -20,7 +20,8 @@ import Snap.Snaplet.Heist import Snap.Snaplet.Session.Backends.CookieSession import Snap.Util.FileServe-import Text.Templating.Heist+import Heist+import qualified Heist.Interpreted as I ------------------------------------------------------------------------------ import Application @@ -28,9 +29,9 @@ ------------------------------------------------------------------------------ -- | Render login form handleLogin :: Maybe T.Text -> Handler App (AuthManager App) ()-handleLogin authError = heistLocal (bindSplices errs) $ render "login"+handleLogin authError = heistLocal (I.bindSplices errs) $ render "login" where- errs = [("loginError", textSplice c) | c <- maybeToList authError]+ errs = [("loginError", I.textSplice c) | c <- maybeToList authError] ------------------------------------------------------------------------------
project_template/tutorial/foo.cabal view
@@ -15,13 +15,14 @@ main-is: Tutorial.lhs Build-depends:- base >= 4 && < 5,- bytestring >= 0.9.1 && < 0.11,- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- mtl >= 2 && < 3,- snap >= 0.9.2 && < 0.10,- snap-core >= 0.9.2 && < 0.10,- snap-server >= 0.9.2 && < 0.10+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ lens >= 3.7.0.1 && < 3.8,+ MonadCatchIO-transformers >= 0.2.1 && < 0.4,+ mtl >= 2 && < 3,+ snap >= 0.10 && < 0.11,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
project_template/tutorial/src/Part2.lhs view
@@ -7,8 +7,10 @@ > > data Bar = Bar > +> fooInit :: SnapletInit b Foo > fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do > return Foo > +> barInit :: SnapletLens b Foo -> SnapletInit b Bar > barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do > return Bar
project_template/tutorial/src/Tutorial.lhs view
@@ -65,6 +65,7 @@ > > module Main where > +> import Control.Lens.TH > import Data.IORef > import qualified Data.ByteString.Char8 as B > import Data.Maybe@@ -83,7 +84,7 @@ > , _companyName :: IORef B.ByteString > } >-> makeLenses [''App]+> makeLenses ''App The field names begin with an underscore because of some more complicated things going on under the hood. However, all you need to know right now is@@ -103,7 +104,7 @@ > , ("/barname", with bar namePage) > , ("/company", companyHandler) > ]-> wrapHandlers (<|> heistServe)+> wrapSite (<|> heistServe) > ref <- liftIO $ newIORef "fooCorp" > return $ App hs fs bs ref @@ -167,10 +168,10 @@ current snaplet's state, and a `MonadSnap` instance providing the request-processing functions defined in Snap.Types. -wrapHandlers+wrapSite ------------ -`wrapHandlers` allows you to apply an arbitrary `Handler` transformation to+`wrapSite` allows you to apply an arbitrary `Handler` transformation to the top-level handler. This is useful if you want to do some generic processing at the beginning or end of every request. For instance, a session snaplet might use it to touch a session activity token before routing happens.
snap.cabal view
@@ -1,5 +1,5 @@ name: snap-version: 0.9.2.2+version: 0.10.0 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries.@@ -103,35 +103,36 @@ exposed-modules: Snap,- Snap.Snaplet,- Snap.Snaplet.Heist,- Snap.Snaplet.Auth,- Snap.Snaplet.Auth.Backends.JsonFile,- Snap.Snaplet.Config,- Snap.Snaplet.Session,- Snap.Snaplet.Session.Common,+ Snap.Snaplet+ Snap.Snaplet.Heist+ Snap.Snaplet.HeistNoClass+ Snap.Snaplet.Auth+ Snap.Snaplet.Auth.Backends.JsonFile+ Snap.Snaplet.Config+ Snap.Snaplet.Session+ Snap.Snaplet.Session.Common+ Snap.Snaplet.Session.SessionManager Snap.Snaplet.Session.Backends.CookieSession+ Snap.Snaplet.Test other-modules:- Control.Access.RoleBased.Checker,- Control.Access.RoleBased.Role,- Control.Access.RoleBased.Types,- Control.Access.RoleBased.Internal.Role,- Control.Access.RoleBased.Internal.RoleMap,- Control.Access.RoleBased.Internal.Rule,- Control.Access.RoleBased.Internal.Types,- Snap.Snaplet.Auth.AuthManager,- Snap.Snaplet.Auth.Types,- Snap.Snaplet.Auth.Handlers,- Snap.Snaplet.Auth.SpliceHelpers,- Snap.Snaplet.HeistNoClass,- Snap.Snaplet.Internal.Initializer,- Snap.Snaplet.Internal.LensT,- Snap.Snaplet.Internal.Lensed,- Snap.Snaplet.Internal.RST,+ Control.Access.RoleBased.Checker+ Control.Access.RoleBased.Role+ Control.Access.RoleBased.Types+ Control.Access.RoleBased.Internal.Role+ Control.Access.RoleBased.Internal.RoleMap+ Control.Access.RoleBased.Internal.Rule+ Control.Access.RoleBased.Internal.Types+ Snap.Snaplet.Auth.AuthManager+ Snap.Snaplet.Auth.Types+ Snap.Snaplet.Auth.Handlers+ Snap.Snaplet.Auth.SpliceHelpers+ Snap.Snaplet.Internal.Initializer+ Snap.Snaplet.Internal.LensT+ Snap.Snaplet.Internal.Lensed+ Snap.Snaplet.Internal.RST Snap.Snaplet.Internal.Types- Snap.Snaplet.Session.SecureCookie,- Snap.Snaplet.Session.SessionManager+ Snap.Snaplet.Session.SecureCookie build-depends: MonadCatchIO-transformers >= 0.2 && < 0.4,@@ -141,21 +142,24 @@ bytestring >= 0.9.1 && < 0.11, cereal >= 0.3 && < 0.4, clientsession >= 0.8 && < 0.9,+ comonad >= 1.1 && < 3.1, configurator >= 0.1 && < 0.3, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.12,- data-lens >= 2.0.1 && < 2.11,- data-lens-template >= 2.1 && < 2.2,+ dlist >= 0.5 && < 0.6,+ errors >= 1.3 && < 1.4, filepath >= 1.1 && < 1.4, hashable >= 1.1 && < 1.2,- heist >= 0.7 && < 0.9,+ heist >= 0.10 && < 0.11,+ lens >= 3.7.0.1 && < 3.8, logict >= 0.4.2 && < 0.6, mtl > 2.0 && < 2.2, mwc-random >= 0.8 && < 0.13,- pwstore-fast >= 2.3 && < 2.4,- snap-core >= 0.9.2 && < 0.10,- snap-server >= 0.9.2 && < 0.10,+ pwstore-fast >= 2.2 && < 2.4,+ regex-posix >= 0.95 && < 1,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.4, text >= 0.11 && < 0.12,@@ -207,7 +211,7 @@ directory-tree >= 0.10 && < 0.12, filepath >= 1.1 && < 1.4, old-time >= 1.0 && < 1.2,- snap-server >= 0.9.1 && < 0.10,+ snap-server >= 0.9 && < 0.11, template-haskell >= 2.2 && < 2.9, text >= 0.11 && < 0.12
src/Snap.hs view
@@ -8,18 +8,16 @@ module Snap ( module Control.Applicative+ , module Control.Lens.Loupe , module Control.Monad.State- , module Data.Lens.Common- , module Data.Lens.Template , module Snap.Core , module Snap.Http.Server , module Snap.Snaplet ) where import Control.Applicative+import Control.Lens.Loupe import Control.Monad.State-import Data.Lens.Common-import Data.Lens.Template import Snap.Core import Snap.Http.Server import Snap.Snaplet
src/Snap/Snaplet.hs view
@@ -46,15 +46,15 @@ Snaplet , SnapletConfig + -- * Lenses+ -- $lenses+ -- * Snaplet Helper Functions -- $snapletHelpers , snapletConfig , snapletValue , subSnaplet - -- * Lenses- -- $lenses- -- * MonadSnaplet -- $monadSnaplet , MonadSnaplet(..)@@ -95,7 +95,6 @@ -- * Routes -- $routes , addRoutes- , wrapHandlers , wrapSite -- * Handlers@@ -107,6 +106,9 @@ , runSnaplet , combineConfig , serveSnaplet++ -- * Snaplet Lenses+ , SnapletLens ) where @@ -136,7 +138,7 @@ -- contains all of the application state; we call this state the \"base\" -- state. ----- We provide a couple of helper functions for working with Snaplet types.+-- We export several helper lenses for working with Snaplet types. -- $lenses -- In the example above, the @Foo@ snaplet has to be written to work with any@@ -145,37 +147,37 @@ -- /within the context/ of the base state. Given that Haskell datatypes are -- pure, how do you allow for this? ----- Our solution is to use /lenses/, as defined in the @data-lens@ library--- (<http://hackage.haskell.org/package/data-lens>). A lens, notated as--- follows:+-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@+-- library (<http://hackage.haskell.org/package/lens>). A lens, notated+-- as follows: ----- > Lens a b+-- > SimpleLens a b ----- is a \"getter\" and a \"setter\" rolled up into one. The @data-lens@--- library provides the following functions:+-- is conceptually a \"getter\" and a \"setter\" rolled up into one. The+-- @lens@ library provides the following functions: ----- > getL :: (Lens a b) -> a -> b--- > setL :: (Lens a b) -> b -> a -> a--- > modL :: (Lens a b) -> (b -> b) -> a -> a+-- > view :: (SimpleLens a b) -> a -> b+-- > set :: (SimpleLens a b) -> b -> a -> a+-- > over :: (SimpleLens a b) -> (b -> b) -> a -> a -- -- which allow you to get, set, and modify a value of type @b@ within the--- context of type of type @a@. The @data-lens@ package comes with a Template--- Haskell function called 'makeLenses', which auto-magically defines a lens--- for every record field having a name beginning with an underscore. In the--- @App@ example above, adding the declaration:+-- context of type @a@. The @lens@ package comes with a Template Haskell+-- function called 'makeLenses', which auto-magically defines a lens for every+-- record field having a name beginning with an underscore. In the @App@+-- example above, adding the declaration: ----- > makeLenses [''App]+-- > makeLenses ''App -- -- would define lenses: ----- > foo :: Lens App (Snaplet Foo)--- > bar :: Lens App (Snaplet Bar)--- > someNonSnapletData :: Lens App String+-- > foo :: SimpleLens App (Snaplet Foo)+-- > bar :: SimpleLens App (Snaplet Bar)+-- > someNonSnapletData :: SimpleLens App String ----- The coolest thing about @data-lens@ lenses is that they /compose/, using--- the "Control.Category"'s generalization of the @(.)@ operator. If the @Foo@--- type had a field of type @Quux@ within it with a lens @quux :: Lens Foo--- Quux@, then you could create a lens of type @Lens App Quux@ by composition:+-- The coolest thing about @lens@ lenses is that they /compose/ using the+-- @(.)@ operator. If the @Foo@ type had a field of type @Quux@ within it with+-- a lens @quux :: SimpleLens Foo Quux@, then you could create a lens of type+-- @SimpleLens App Quux@ by composition: -- -- > import Control.Category -- > import Prelude hiding ((.)) -- you have to hide (.) from the Prelude@@ -185,13 +187,14 @@ -- > makeLenses [''Foo] -- > -- > -- snapletValue is defined in the framework:--- > snapletValue :: Lens (Snaplet a) a+-- > snapletValue :: SimpleLens (Snaplet a) a -- >--- > appQuuxLens :: Lens App Quux--- > appQuuxLens = quux . snapletValue . foo+-- > appQuuxLens :: SimpleLens App Quux+-- > appQuuxLens = foo . snapletValue . quux ----- Lens composition is very similar to function composition, but it gives you--- a composed getter and setter at the same time.+-- Lens composition is very similar to function composition except it works in+-- the opposite direction (think Java-style System.out.println ordering) and+-- it gives you a composed getter and setter at the same time. -- $monadSnaplet -- The primary abstraction in the snaplet infrastructure is a combination of@@ -201,7 +204,7 @@ -- state. This allows quux snaplet functions to access and modify the Quux -- data structure without knowing anything about the App or Foo data -- structures. It also lets other snaplets call functions from the quux--- snaplet if they have the quux snaplet's lens @Lens App (Snaplet Quux)@.+-- snaplet if they have the quux snaplet's lens @SimpleLens App (Snaplet Quux)@. -- We can view our application as a tree of snaplets and other pieces of data. -- The lenses are like pointers to nodes of the tree. If you have a pointer to -- a node, you can access the node and all of its children without knowing@@ -250,7 +253,7 @@ -- $routes -- Snaplet initializers are also responsible for setting up any routes defined -- by the snaplet. To do that you'll usually use either 'addRoutes' or--- 'wrapHandlers'.+-- 'wrapSite'. {-@@ -303,7 +306,7 @@ > bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist > addRoutes [ ("/hello", writeText "hello world") > ]-> wrapHandlers (<|> with heist heistServe)+> wrapSite (<|> with heist heistServe) > return $ App hs fs bs "fooCorp" Then we define a simple main to run the application.
src/Snap/Snaplet/Auth.hs view
@@ -43,7 +43,6 @@ , UserId(..) , Password(..) , AuthFailure(..)- , BackendError(..) , Role(..) -- * Other Utilities@@ -61,9 +60,12 @@ , loginUser , logoutUser , requireUser+ , setPasswordResetToken+ , clearPasswordResetToken -- * Splice helpers , addAuthSplices+ , compiledAuthSplices , ifLoggedIn , ifLoggedOut , loggedInUser
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -20,7 +20,6 @@ ------------------------------------------------------------------------------ import Data.ByteString (ByteString)-import Data.Lens.Lazy import Data.Text (Text) import Data.Time import Web.ClientSession@@ -33,12 +32,11 @@ ------------------------------------------------------------------------------ -- | Creates a new user from a username and password. ----- May throw a "DuplicateLogin" if given username is not unique buildAuthUser :: IAuthBackend r => r -- ^ An auth backend -> Text -- ^ Username -> ByteString -- ^ Password- -> IO AuthUser+ -> IO (Either AuthFailure AuthUser) buildAuthUser r unm pass = do now <- getCurrentTime let au = defAuthUser {@@ -54,13 +52,11 @@ ------------------------------------------------------------------------------ -- | All storage backends need to implement this typeclass ----- Backend operations may throw 'BackendError's class IAuthBackend r where- -- | Create or update the given 'AuthUser' record. If the 'userId' in the- -- 'AuthUser' already exists in the database, then that user's information- -- should be updated. If it does not exist, then a new user should be- -- created.- save :: r -> AuthUser -> IO AuthUser+ -- | Create or update the given 'AuthUser' record. A 'userId' of Nothing+ -- indicates that a new user should be created, otherwise the user+ -- information for that userId should be updated.+ save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)@@ -73,7 +69,7 @@ backend :: r -- ^ Storage back-end - , session :: Lens b (Snaplet SessionManager)+ , session :: SnapletLens b SessionManager -- ^ A lens pointer to a SessionManager , activeUser :: Maybe AuthUser
src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -11,7 +11,6 @@ import Control.Applicative-import Control.Monad.CatchIO (throw) import Control.Monad.State import Control.Concurrent.STM import Data.Aeson@@ -23,7 +22,6 @@ import Data.Maybe (fromJust, isJust) import Data.Text (Text) import qualified Data.Text as T-import Data.Lens.Lazy import Data.Time import Web.ClientSession import System.Directory@@ -38,12 +36,12 @@ ------------------------------------------------------------------------------ -- | Initialize a JSON file backed 'AuthManager' initJsonFileAuthManager :: AuthSettings- -- ^ Authentication settings for your app- -> Lens b (Snaplet SessionManager)- -- ^ Lens into a 'SessionManager' auth snaplet will+ -- ^ Authentication settings for your app+ -> SnapletLens b SessionManager+ -- ^ Lens into a 'SessionManager' auth snaplet will -- use -> FilePath- -- ^ Where to store user data as JSON+ -- ^ Where to store user data as JSON -> SnapletInit b (AuthManager b) initJsonFileAuthManager s l db = do makeSnaplet@@ -149,7 +147,9 @@ -------------------------------------------------------------------------------jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser+jsonFileSave :: JsonFileAuthManager+ -> AuthUser+ -> IO (Either AuthFailure AuthUser) jsonFileSave mgr u = do now <- getCurrentTime oldByLogin <- lookupByLogin mgr (userLogin u)@@ -169,17 +169,17 @@ return $! Right $! (cache', u') case res of- Left e -> throw e+ Left _ -> return $! Left BackendError Right (cache', u') -> do dumpToDisk cache'- return $! u'+ return $! Right u' where -------------------------------------------------------------------------- create :: UserCache -> UTCTime -> (Maybe AuthUser)- -> STM (Either BackendError (UserCache, AuthUser))+ -> STM (Either AuthFailure (UserCache, AuthUser)) create cache now old = do case old of Just _ -> return $! Left DuplicateLogin@@ -202,11 +202,10 @@ update :: UserCache -> UTCTime -> (Maybe AuthUser)- -> STM (Either BackendError (UserCache, AuthUser))+ -> STM (Either AuthFailure (UserCache, AuthUser)) update cache now old = case old of- Nothing -> return $! Left $- BackendError "User not found; should never happen"+ Nothing -> return $! Left UserNotFound Just x -> do let oldLogin = userLogin x let oldToken = userRememberToken x
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -11,17 +11,14 @@ ------------------------------------------------------------------------------ import Control.Applicative-import Control.Monad.CatchIO (throw)+import Control.Error import Control.Monad.State-import Control.Monad.Trans.Error-import Control.Monad.Trans.Maybe import Data.ByteString (ByteString)-import Data.Lens.Lazy-import Data.Maybe (fromMaybe, isJust) import Data.Serialize hiding (get) import Data.Time import Data.Text.Encoding (decodeUtf8)-import Data.Text (Text)+import Data.Text (Text, null, strip)+import Prelude hiding (null) import Web.ClientSession ------------------------------------------------------------------------------ import Snap.Core@@ -39,12 +36,15 @@ ------------------------------------------------------------------------------ -- | Create a new user from just a username and password ----- May throw a "DuplicateLogin" if given username is not unique.--- createUser :: Text -- ^ Username -> ByteString -- ^ Password- -> Handler b (AuthManager b) AuthUser-createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+createUser unm pwd+ | null $ strip unm = return $ Left UsernameMissing+ | otherwise = do+ uExists <- usernameExists unm+ if uExists then return $ Left DuplicateLogin+ else withBackend $ \r -> liftIO $ buildAuthUser r unm pwd ------------------------------------------------------------------------------@@ -63,8 +63,7 @@ -> Password -- ^ Should be ClearText -> Bool -- ^ Set remember token? -> Handler b (AuthManager b) (Either AuthFailure AuthUser)-loginByUsername _ (Encrypted _) _ =- error "Cannot login with encrypted password"+loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword loginByUsername unm pwd shouldRemember = do sk <- gets siteKey cn <- gets rememberCookieName@@ -157,17 +156,15 @@ ------------------------------------------------------------------------------ -- | Create or update a given user ----- May throw a 'BackendError' if something goes wrong.----saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser-saveUser u = withBackend $ liftIO . flip save u+saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+saveUser u+ | null $ userLogin u = return $ Left UsernameMissing+ | otherwise = withBackend $ \r -> liftIO $ save r u ------------------------------------------------------------------------------ -- | Destroy the given user ----- May throw a 'BackendError' if something goes wrong.--- destroyUser :: AuthUser -> Handler b (AuthManager b) () destroyUser u = withBackend $ liftIO . flip destroy u @@ -181,7 +178,8 @@ -- -- This will save the user to the backend. ---markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser+markAuthFail :: AuthUser+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthFail u = withBackend $ \r -> do lo <- gets lockout incFailCtr u >>= checkLockout lo >>= liftIO . save r@@ -210,7 +208,8 @@ -- -- This will save the user to the backend. ---markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser+markAuthSuccess :: AuthUser+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser) markAuthSuccess u = withBackend $ \r -> incLoginCtr u >>= updateIp >>=@@ -267,6 +266,7 @@ Nothing -> auth u where+ auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser) auth user = case authenticatePassword user pw of Just e -> do@@ -276,8 +276,7 @@ Nothing -> do forceLogin user modify (\mgr -> mgr { activeUser = Just user })- user' <- markAuthSuccess user- return $ Right user'+ markAuthSuccess user ------------------------------------------------------------------------------@@ -290,7 +289,7 @@ -> Handler b (AuthManager b) (Either AuthFailure AuthUser) forceLogin u = do s <- gets session- withSession s $ do+ withSession s $ case userId u of Just x -> do withTop s (setSessionUserId x)@@ -348,7 +347,7 @@ getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do uid <- getFromSession "__user_id"- return $ uid >>= return . UserId+ return $ liftM UserId uid ------------------------------------------------------------------------------@@ -374,7 +373,7 @@ -- cacheOrLookup :: Handler b (AuthManager b) (Maybe AuthUser)- -- ^ Lookup action to perform if request local cache is empty+ -- ^ Lookup action to perform if request local cache is empty -> Handler b (AuthManager b) (Maybe AuthUser) cacheOrLookup f = do au <- gets activeUser@@ -392,50 +391,68 @@ registerUser :: ByteString -- ^ Login field -> ByteString -- ^ Password field- -> Handler b (AuthManager b) AuthUser+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser) registerUser lf pf = do l <- fmap decodeUtf8 <$> getParam lf p <- getParam pf- case liftM2 (,) l p of- Nothing -> throw PasswordMissing- Just (lgn, pwd) -> createUser lgn pwd + let l' = note UsernameMissing l+ let p' = note PasswordMissing p + -- In case of multiple AuthFailure, the first available one+ -- will be propagated.+ case liftM2 (,) l' p' of+ Left e -> return $ Left e+ Right (lgn, pwd) -> createUser lgn pwd++ ------------------------------------------------------------------------------ -- | A 'MonadSnap' handler that processes a login form. -- -- The request paremeters are passed to 'performLogin' --+-- To make your users stay logged in for longer than the session replay+-- prevention timeout, you must pass a field name as the third parameter and+-- that field must be set to a value of \"1\" by the submitting form. This+-- lets you use a user selectable check box. Or if you want user remembering+-- always turned on, you can use a hidden form field. loginUser :: ByteString- -- ^ Username field+ -- ^ Username field -> ByteString- -- ^ Password field+ -- ^ Password field -> Maybe ByteString- -- ^ Remember field; Nothing if you want no remember function.+ -- ^ Remember field; Nothing if you want no remember function. -> (AuthFailure -> Handler b (AuthManager b) ())- -- ^ Upon failure+ -- ^ Upon failure -> Handler b (AuthManager b) ()- -- ^ Upon success+ -- ^ Upon success -> Handler b (AuthManager b) () loginUser unf pwdf remf loginFail loginSucc =- runErrorT go >>= either loginFail (const loginSucc)- where- go = do- mbUsername <- getParam unf- mbPassword <- getParam pwdf- remember <- (runMaybeT $ do- field <- MaybeT $ return remf- value <- MaybeT $ getParam field- return $ value == "1"- ) >>= return . fromMaybe False+ runEitherT (loginUser' unf pwdf remf)+ >>= either loginFail (const loginSucc) - password <- maybe (throwError PasswordMissing) return mbPassword- username <- maybe (fail "Username is missing") return mbUsername- ErrorT $ loginByUsername username (ClearText password) remember+------------------------------------------------------------------------------+loginUser' :: ByteString+ -> ByteString+ -> Maybe ByteString+ -> EitherT AuthFailure (Handler b (AuthManager b)) AuthUser+loginUser' unf pwdf remf = do+ mbUsername <- lift $ getParam unf+ mbPassword <- lift $ getParam pwdf+ remember <- lift $ liftM (fromMaybe False)+ (runMaybeT $+ do field <- MaybeT $ return remf+ value <- MaybeT $ getParam field+ return $ value == "1") + password <- noteT PasswordMissing $ hoistMaybe mbPassword+ username <- noteT UsernameMissing $ hoistMaybe mbUsername + EitherT $ loginByUsername username (ClearText password) remember++ ------------------------------------------------------------------------------ -- | Simple handler to log the user out. Deletes user from session. --@@ -451,12 +468,12 @@ -- This function has no DB cost - only checks to see if a user_id is present -- in the current session. ---requireUser :: Lens b (Snaplet (AuthManager b))- -- ^ Lens reference to an "AuthManager"+requireUser :: SnapletLens b (AuthManager b)+ -- ^ Lens reference to an "AuthManager" -> Handler b v a- -- ^ Do this if no authenticated user is present.+ -- ^ Do this if no authenticated user is present. -> Handler b v a- -- ^ Do this if an authenticated user is present.+ -- ^ Do this if an authenticated user is present. -> Handler b v a requireUser auth bad good = do loggedIn <- withTop auth isLoggedIn@@ -479,3 +496,47 @@ withBackend f = join $ do (AuthManager backend_ _ _ _ _ _ _ _ _) <- get return $ f backend_+++------------------------------------------------------------------------------+-- | This function generates a random password reset token and stores it in+-- the database for the user. Call this function when a user forgets their+-- password. Then use the token to autogenerate a link that the user can+-- visit to reset their password. This function also sets a timestamp so the+-- reset token can be expired.+setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text)+setPasswordResetToken login = do+ tokBS <- liftIO . randomToken 40 =<< gets randomNumberGenerator+ let token = decodeUtf8 tokBS+ now <- liftIO getCurrentTime+ success <- modPasswordResetToken login (Just token) (Just now)+ return $ if success then Just token else Nothing+++------------------------------------------------------------------------------+-- | Clears a user's password reset token. Call this when the user+-- successfully changes their password to ensure that the password reset link+-- cannot be used again.+clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool+clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing+++------------------------------------------------------------------------------+-- | Helper function used for setting and clearing the password reset token+-- and associated timestamp.+modPasswordResetToken :: Text+ -> Maybe Text+ -> Maybe UTCTime+ -> Handler v (AuthManager v) Bool+modPasswordResetToken login token timestamp = do+ res <- runMaybeT $ do+ u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login+ lift $ saveUser $ u+ { userResetToken = token+ , userResetRequestedAt = timestamp+ }+ return ()+ return $ maybe False (\_ -> True) res+++
src/Snap/Snaplet/Auth/SpliceHelpers.hs view
@@ -13,14 +13,22 @@ module Snap.Snaplet.Auth.SpliceHelpers ( addAuthSplices+ , compiledAuthSplices , ifLoggedIn , ifLoggedOut , loggedInUser+ , cIfLoggedIn+ , cIfLoggedOut+ , cLoggedInUser ) where -import Data.Lens.Lazy+import Control.Monad.Trans+import Data.Monoid+import Data.Text (Text) import qualified Text.XmlHtml as X-import Text.Templating.Heist+import Heist+import qualified Heist.Interpreted as I+import qualified Heist.Compiled as C import Snap.Snaplet import Snap.Snaplet.Auth.AuthManager@@ -38,46 +46,97 @@ -- \<loggedInUser\> addAuthSplices :: HasHeist b- => Lens b (Snaplet (AuthManager b))- -- ^ A lens reference to 'AuthManager'+ => SnapletLens b (AuthManager b)+ -- ^ A lens reference to 'AuthManager' -> Initializer b v () addAuthSplices auth = addSplices- [ ("ifLoggedIn", ifLoggedIn auth)- , ("ifLoggedOut", ifLoggedOut auth)- , ("loggedInUser", loggedInUser auth)- ]+ [ ("ifLoggedIn", ifLoggedIn auth)+ , ("ifLoggedOut", ifLoggedOut auth)+ , ("loggedInUser", loggedInUser auth)+ ] +compiledAuthSplices :: SnapletLens b (AuthManager b)+ -> [(Text, SnapletCSplice b)]+compiledAuthSplices auth =+ [ ("ifLoggedIn", cIfLoggedIn auth)+ , ("ifLoggedOut", cIfLoggedOut auth)+ , ("loggedInUser", cLoggedInUser auth)+ ]++ ------------------------------------------------------------------------------ -- | A splice that can be used to check for existence of a user. If a user is -- present, this will run the contents of the node. -- -- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>-ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v+ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedIn auth = do- chk <- liftHandler $ withTop auth isLoggedIn- case chk of- True -> liftHeist $ getParamNode >>= return . X.childNodes- False -> return []+ chk <- lift $ withTop auth isLoggedIn+ case chk of+ True -> getParamNode >>= return . X.childNodes+ False -> return [] ------------------------------------------------------------------------------+-- | A splice that can be used to check for existence of a user. If a user is+-- present, this will run the contents of the node.+--+-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>+cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b+cIfLoggedIn auth = do+ children <- C.promiseChildren+ return $ C.yieldRuntime $ do+ chk <- lift $ withTop auth isLoggedIn+ case chk of+ True -> children+ False -> return mempty+++------------------------------------------------------------------------------ -- | A splice that can be used to check for absence of a user. If a user is -- not present, this will run the contents of the node. -- -- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>-ifLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v+ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b ifLoggedOut auth = do- chk <- liftHandler $ withTop auth isLoggedIn- case chk of- False -> liftHeist $ getParamNode >>= return . X.childNodes- True -> return []+ chk <- lift $ withTop auth isLoggedIn+ case chk of+ False -> getParamNode >>= return . X.childNodes+ True -> return [] +------------------------------------------------------------------------------+-- | A splice that can be used to check for absence of a user. If a user is+-- not present, this will run the contents of the node.+--+-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>+cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b+cIfLoggedOut auth = do+ children <- C.promiseChildren+ return $ C.yieldRuntime $ do+ chk <- lift $ withTop auth isLoggedIn+ case chk of+ False -> children+ True -> return mempty++ ------------------------------------------------------------------------------- -- | A splice that will simply print the current user's login, if -- there is one.-loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v+loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b loggedInUser auth = do- u <- liftHandler $ withTop auth currentUser- liftHeist $ maybe (return []) (textSplice . userLogin) u + u <- lift $ withTop auth currentUser+ maybe (return []) (I.textSplice . userLogin) u +++-------------------------------------------------------------------------------+-- | A splice that will simply print the current user's login, if+-- there is one.+cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b+cLoggedInUser auth =+ return $ C.yieldRuntimeText $ do+ u <- lift $ withTop auth currentUser+ return $ maybe "" userLogin u ++
src/Snap/Snaplet/Auth/Types.hs view
@@ -8,9 +8,7 @@ ------------------------------------------------------------------------------ import Control.Applicative import Control.Arrow-import Control.Monad.CatchIO import Control.Monad.Trans-import Control.Monad.Trans.Error import Crypto.PasswordStore import Data.Aeson import Data.ByteString (ByteString)@@ -77,18 +75,30 @@ -- They may provide useful information to the developer, although it is -- generally not advisable to show the user the exact details about why login -- failed.-data AuthFailure = UserNotFound+data AuthFailure = AuthError String+ | BackendError+ | DuplicateLogin+ | EncryptedPassword | IncorrectPassword- | PasswordMissing | LockedOut UTCTime -- ^ Locked out until given time- | AuthError String- deriving (Read, Show, Ord, Eq, Typeable)+ | PasswordMissing+ | UsernameMissing+ | UserNotFound+ deriving (Read, Ord, Eq, Typeable) -instance Exception AuthFailure -instance Error AuthFailure where- strMsg = AuthError+instance Show AuthFailure where+ show (AuthError s) = s+ show (BackendError) = "Failed to store data in the backend."+ show (DuplicateLogin) = "This login already exists in the backend."+ show (EncryptedPassword) = "Cannot login with encrypted password."+ show (IncorrectPassword) = "The password provided was not valid."+ show (LockedOut time) = "The login is locked out until " ++ show time+ show (PasswordMissing) = "No password provided."+ show (UsernameMissing) = "No username provided."+ show (UserNotFound) = "User not found in the backend." + ------------------------------------------------------------------------------ -- | Internal representation of a 'User'. By convention, we demand that the -- application is able to directly fetch a 'User' using this identifier.@@ -110,6 +120,10 @@ data AuthUser = AuthUser { userId :: Maybe UserId , userLogin :: Text++ -- We have to have an email field for password reset functionality, but we+ -- don't want to force users to log in with their email address.+ , userEmail :: Maybe Text , userPassword :: Maybe Password , userActivatedAt :: Maybe UTCTime , userSuspendedAt :: Maybe UTCTime@@ -123,6 +137,8 @@ , userLastLoginIp :: Maybe ByteString , userCreatedAt :: Maybe UTCTime , userUpdatedAt :: Maybe UTCTime+ , userResetToken :: Maybe Text+ , userResetRequestedAt :: Maybe UTCTime , userRoles :: [Role] , userMeta :: HashMap Text Value }@@ -135,6 +151,7 @@ defAuthUser = AuthUser { userId = Nothing , userLogin = ""+ , userEmail = Nothing , userPassword = Nothing , userActivatedAt = Nothing , userSuspendedAt = Nothing@@ -148,6 +165,8 @@ , userLastLoginIp = Nothing , userCreatedAt = Nothing , userUpdatedAt = Nothing+ , userResetToken = Nothing+ , userResetRequestedAt = Nothing , userRoles = [] , userMeta = HM.empty }@@ -166,20 +185,20 @@ -- | Authetication settings defined at initialization time data AuthSettings = AuthSettings { asMinPasswdLen :: Int- -- ^ Currently not used/checked+ -- ^ Currently not used/checked , asRememberCookieName :: ByteString- -- ^ Name of the desired remember cookie+ -- ^ Name of the desired remember cookie , asRememberPeriod :: Maybe Int- -- ^ How long to remember when the option is used in rest of the API.+ -- ^ How long to remember when the option is used in rest of the API. -- 'Nothing' means remember until end of session. , asLockout :: Maybe (Int, NominalDiffTime)- -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])+ -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) , asSiteKey :: FilePath- -- ^ Location of app's encryption key+ -- ^ Location of app's encryption key } @@ -230,14 +249,6 @@ return $ (pw . rc . rp . lo . sk) defAuthSettings --------------------------------------------------------------------------------data BackendError = DuplicateLogin- | BackendError String- deriving (Eq,Show,Read,Typeable)--instance Exception BackendError-- -------------------- -- JSON Instances -- --------------------@@ -247,6 +258,7 @@ toJSON u = object [ "uid" .= userId u , "login" .= userLogin u+ , "email" .= userEmail u , "pw" .= userPassword u , "activated_at" .= userActivatedAt u , "suspended_at" .= userSuspendedAt u@@ -260,6 +272,8 @@ , "last_ip" .= userLastLoginIp u , "created_at" .= userCreatedAt u , "updated_at" .= userUpdatedAt u+ , "reset_token" .= userResetToken u+ , "reset_requested_at" .= userResetRequestedAt u , "roles" .= userRoles u , "meta" .= userMeta u ]@@ -270,6 +284,7 @@ parseJSON (Object v) = AuthUser <$> v .: "uid" <*> v .: "login"+ <*> v .: "email" <*> v .: "pw" <*> v .: "activated_at" <*> v .: "suspended_at"@@ -283,6 +298,8 @@ <*> v .: "last_ip" <*> v .: "created_at" <*> v .: "updated_at"+ <*> v .: "reset_token"+ <*> v .: "reset_requested_at" <*> v .:? "roles" .!= [] <*> v .: "meta" parseJSON _ = error "Unexpected JSON input"
src/Snap/Snaplet/Heist.hs view
@@ -15,12 +15,18 @@ , heistInit' , addTemplates , addTemplatesAt- , modifyHeistTS- , withHeistTS+ , Unclassed.addConfig+ , modifyHeistState+ , withHeistState , addSplices -- * Handler Functions -- $handlerSection+ , cRender+ , cRenderAs+ , cHeistServe+ , cHeistServeSingle+ , render , renderAs , heistServe@@ -32,12 +38,8 @@ -- * Writing Splices -- $spliceSection , Unclassed.SnapletHeist- , Unclassed.SnapletSplice- , Unclassed.liftHeist- , Unclassed.liftHandler- , Unclassed.liftAppHandler- , Unclassed.liftWith- , Unclassed.bindSnapletSplices+ , Unclassed.SnapletCSplice+ , Unclassed.SnapletISplice , clearHeistCache ) where@@ -45,9 +47,8 @@ ------------------------------------------------------------------------------ import Prelude hiding (id, (.)) import Data.ByteString (ByteString)-import Data.Lens.Lazy import Data.Text (Text)-import Text.Templating.Heist+import Heist ------------------------------------------------------------------------------ import Snap.Snaplet import qualified Snap.Snaplet.HeistNoClass as Unclassed@@ -76,7 +77,7 @@ class HasHeist b where -- | A lens to the Heist snaplet. The b parameter to Heist will -- typically be the base state of your application.- heistLens :: Lens (Snaplet b) (Snaplet (Heist b))+ heistLens :: SnapletLens (Snaplet b) (Heist b) -- $initializerSection@@ -89,10 +90,11 @@ -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root. addTemplates :: HasHeist b- => ByteString- -- ^ The url prefix for the template routes+ => Snaplet (Heist b)+ -> ByteString+ -- ^ The url prefix for the template routes -> Initializer b v ()-addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)+addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx) ------------------------------------------------------------------------------@@ -103,46 +105,53 @@ -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure. addTemplatesAt :: HasHeist b- => ByteString- -- ^ URL prefix for template routes+ => Snaplet (Heist b)+ -> ByteString+ -- ^ URL prefix for template routes -> FilePath- -- ^ Path to templates+ -- ^ Path to templates -> Initializer b v ()-addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)+addTemplatesAt h pfx p =+ withTop' heistLens (Unclassed.addTemplatesAt h pfx p) --------------------------------------------------------------------------------- | Allows snaplets to add splices.+-- | Allows snaplets to add interpreted splices.+--+-- NOTE: The splices added with this function will not work if you render your+-- templates with cRender. To add splices that work with cRender, you have to+-- use the addConfig function to add compiled splices or load time splices. addSplices :: (HasHeist b)- => [(Text, Unclassed.SnapletSplice b v)]- -- ^ Splices to bind+ => [(Text, Unclassed.SnapletISplice b)]+ -- ^ Splices to bind -> Initializer b v () addSplices = Unclassed.addSplices' heistLens ------------------------------------------------------------------------------ -- | More general function allowing arbitrary HeistState modification.--- Without this function you wouldn't be able to bind more complicated splices--- like the cache tag.-modifyHeistTS :: (HasHeist b)- => (HeistState (Handler b b) -> HeistState (Handler b b))- -- ^ HeistState modifying function- -> Initializer b v ()-modifyHeistTS = Unclassed.modifyHeistTS' heistLens+modifyHeistState :: (HasHeist b)+ => (HeistState (Handler b b) -> HeistState (Handler b b))+ -- ^ HeistState modifying function+ -> Initializer b v ()+modifyHeistState = Unclassed.modifyHeistState' heistLens ------------------------------------------------------------------------------ -- | Runs a function on with the Heist snaplet's 'HeistState'.-withHeistTS :: (HasHeist b)- => (HeistState (Handler b b) -> a)- -- ^ HeistState function to run- -> Handler b v a-withHeistTS = Unclassed.withHeistTS' heistLens+withHeistState :: (HasHeist b)+ => (HeistState (Handler b b) -> a)+ -- ^ HeistState function to run+ -> Handler b v a+withHeistState = Unclassed.withHeistState' heistLens -- $handlerSection -- This section contains functions in the 'Handler' monad that you'll use in--- processing requests.+-- processing requests. Functions beginning with a 'c' prefix use compiled+-- template rendering. The other functions use the older interpreted+-- rendering. Splices added with addSplices will only work if you use+-- interpreted rendering. ------------------------------------------------------------------------------@@ -150,7 +159,7 @@ -- this returns 'empty'. render :: HasHeist b => ByteString- -- ^ Template name+ -- ^ Template name -> Handler b v () render t = withTop' heistLens (Unclassed.render t) @@ -160,38 +169,82 @@ -- is not found, this returns 'empty'. renderAs :: HasHeist b => ByteString- -- ^ Content type to render with+ -- ^ Content type to render with -> ByteString- -- ^ Template name+ -- ^ Template name -> Handler b v () renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t) --------------------------------------------------------------------------------- | Analogous to 'fileServe'. If the template specified in the request path--- is not found, it returns 'empty'.+-- | Renders a compiled template as text\/html. If the given template is not+-- found, this returns 'empty'.+cRender :: HasHeist b+ => ByteString+ -- ^ Template name+ -> Handler b v ()+cRender t = withTop' heistLens (Unclassed.cRender t)+++------------------------------------------------------------------------------+-- | Renders a compiled template as the given content type. If the given+-- template is not found, this returns 'empty'.+cRenderAs :: HasHeist b+ => ByteString+ -- ^ Content type to render with+ -> ByteString+ -- ^ Template name+ -> Handler b v ()+cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t)+++------------------------------------------------------------------------------+-- | A handler that serves all the templates (similar to 'serveDirectory').+-- If the template specified in the request path is not found, it returns+-- 'empty'. Also, this function does not serve any templates beginning with+-- an underscore. This gives you a way to prevent some templates from being+-- served. For example, you might have a template that contains only the+-- navbar of your pages, and you probably wouldn't want that template to be+-- visible to the user as a standalone template. So if you put it in a file+-- called \"_nav.tpl\", this function won't serve it. heistServe :: HasHeist b => Handler b v () heistServe = withTop' heistLens Unclassed.heistServe --------------------------------------------------------------------------------- | Analogous to 'fileServeSingle'. If the given template is not found,--- this throws an error.+-- | Handler for serving a single template (similar to 'fileServeSingle'). If+-- the given template is not found, this throws an error. heistServeSingle :: HasHeist b => ByteString- -- ^ Template name+ -- ^ Template name -> Handler b v () heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) ------------------------------------------------------------------------------+-- | A compiled version of 'heistServe'.+cHeistServe :: HasHeist b => Handler b v ()+cHeistServe = withTop' heistLens Unclassed.cHeistServe+++------------------------------------------------------------------------------+-- | Analogous to 'fileServeSingle'. If the given template is not found,+-- this throws an error.+cHeistServeSingle :: HasHeist b+ => ByteString+ -- ^ Template name+ -> Handler b v ()+cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)+++------------------------------------------------------------------------------ -- | Renders a template with a given set of splices. This is syntax sugar for -- a common combination of heistLocal, bindSplices, and render. renderWithSplices :: HasHeist b => ByteString- -- ^ Template name- -> [(Text, Unclassed.SnapletSplice b v)]- -- ^ Splices to bind+ -- ^ Template name+ -> [(Text, Unclassed.SnapletISplice b)]+ -- ^ Splices to bind -> Handler b v () renderWithSplices = Unclassed.renderWithSplices' heistLens @@ -200,10 +253,10 @@ -- | Runs an action with additional splices bound into the Heist -- 'HeistState'. withSplices :: HasHeist b- => [(Text, Unclassed.SnapletSplice b v)]- -- ^ Splices to bind+ => [(Text, Unclassed.SnapletISplice b)]+ -- ^ Splices to bind -> Handler b v a- -- ^ Handler to run+ -- ^ Handler to run -> Handler b v a withSplices = Unclassed.withSplices' heistLens @@ -216,9 +269,9 @@ -- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices heistLocal :: HasHeist b => (HeistState (Handler b b) -> HeistState (Handler b b))- -- ^ HeistState modifying function+ -- ^ HeistState modifying function -> Handler b v a- -- ^ Handler to run+ -- ^ Handler to run -> Handler b v a heistLocal = Unclassed.heistLocal' heistLens @@ -232,6 +285,6 @@ -- work with @Handler b v@ so your local snaplet's state is available. We -- provide the SnapletHeist monad to make this possible. The general rule is -- that when you're using Snaplets and Heist, use SnapletHeist instead of--- HeistT (previously called TemplateMonad) and use SnapletSplice instead of+-- HeistT (previously called TemplateMonad) and use SnapletISplice instead of -- Splice.
src/Snap/Snaplet/HeistNoClass.hs view
@@ -1,9 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}++{-|++This module implements the Heist snaplet without using type classes. It is+provided mainly as an example of how snaplets can be written with and without+a type class for convenience.++-} module Snap.Snaplet.HeistNoClass ( Heist , heistInit@@ -12,12 +23,19 @@ , addTemplates , addTemplatesAt- , modifyHeistTS- , modifyHeistTS'- , withHeistTS- , withHeistTS'+ , modifyHeistState+ , modifyHeistState'+ , withHeistState+ , withHeistState' , addSplices , addSplices'++ , addConfig+ , cRender+ , cRenderAs+ , cHeistServe+ , cHeistServeSingle+ , render , renderAs , heistServe@@ -30,33 +48,32 @@ , renderWithSplices' , SnapletHeist- , SnapletSplice- , runSnapletSplice- , liftHeist- , liftWith- , liftHandler- , liftAppHandler- , bindSnapletSplices+ , SnapletISplice+ , SnapletCSplice ) where import Prelude hiding ((.), id)-import Control.Arrow import Control.Applicative import Control.Category-import Control.Monad.CatchIO (MonadCatchIO)+import Control.Comonad+import Control.Error import Control.Monad.Reader import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B-import Data.Maybe+import Data.DList (DList)+import qualified Data.HashMap.Strict as Map+import Data.IORef+import Data.List import Data.Monoid-import Data.Lens.Lazy import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding import System.FilePath.Posix-import Text.Templating.Heist-import Text.Templating.Heist.Splices.Cache+import Heist+import qualified Heist.Compiled as C+import qualified Heist.Interpreted as I+import Heist.Splices.Cache import Snap.Snaplet import Snap.Core@@ -68,25 +85,27 @@ -- include this in your application state and use 'heistInit' to initialize -- it. The type parameter b will typically be the base state type for your -- application.----data Heist b = Heist- { _heistTS :: HeistState (Handler b b)- , _heistCTS :: CacheTagState- }+data Heist b = Configuring+ { _heistConfig :: IORef (HeistConfig (Handler b b)) }+ | Running+ { _heistState :: HeistState (Handler b b)+ , _heistCTS :: CacheTagState+ } -------------------------------------------------------------------------------changeTS :: (HeistState (Handler a a) -> HeistState (Handler a a))- -> Heist a- -> Heist a-changeTS f (Heist ts cts) = Heist (f ts) cts+changeState :: (HeistState (Handler a a) -> HeistState (Handler a a))+ -> Heist a+ -> Heist a+changeState _ (Configuring _) =+ error "changeState: HeistState has not been initialized"+changeState f (Running hs cts) = Running (f hs) cts ------------------------------------------------------------------------------ -- | Clears data stored by the cache tag. The cache tag automatically reloads -- its data when the specified TTL expires, but sometimes you may want to -- trigger a manual reload. This function lets you do that.--- clearHeistCache :: Heist b -> IO () clearHeistCache = clearCacheTagState . _heistCTS @@ -98,261 +117,189 @@ ------------------------------------------------------------------------------ -- | This instance is here because we don't want the heist package to depend -- on anything from snap packages.----instance MonadSnap m => MonadSnap (HeistT m) where+instance MonadSnap m => MonadSnap (HeistT n m) where liftSnap = lift . liftSnap ---------------------------------------------------------------------------------- | Monad for working with Heist's API from within a snaplet.----newtype SnapletHeist b v a = SnapletHeist- (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)- deriving ( Monad- , Functor- , Applicative- , Alternative- , MonadIO- , MonadPlus- , MonadReader (Lens (Snaplet b) (Snaplet v))- , MonadCatchIO- , MonadSnap- )------------------------------------------------------------------------------------ | Type alias for convenience.----type SnapletSplice b v = SnapletHeist b v Template------------------------------------------------------------------------------------ | Runs the SnapletSplice.----runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))- -> SnapletHeist b v a- -> HeistT (Handler b b) a-runSnapletSplice l (SnapletHeist m) = runReaderT m l----------------------------------------------------------------------------------withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v'))- -> SnapletHeist b v' a- -> SnapletHeist b v a-withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m------------------------------------------------------------------------------------ | Lifts a HeistT action into SnapletHeist. Use this with all the functions--- from the Heist API.----liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a-liftHeist = SnapletHeist . lift------------------------------------------------------------------------------------ | Common idiom for the combination of liftHandler and withTop.----liftWith :: (Lens (Snaplet b) (Snaplet v'))- -> Handler b v' a- -> SnapletHeist b v a-liftWith l = liftHeist . lift . withTop' l------------------------------------------------------------------------------------ | Lifts a Handler into SnapletHeist.----liftHandler :: Handler b v a -> SnapletHeist b v a-liftHandler m = do- l <- ask- liftWith l m------------------------------------------------------------------------------------ | Lifts a (Handler b b) into SnapletHeist.----liftAppHandler :: Handler b b a -> SnapletHeist b v a-liftAppHandler = liftHeist . lift----------------------------------------------------------------------------------instance MonadState v (SnapletHeist b v) where- get = do- l <- ask- b <- liftAppHandler getSnapletState- return $ getL (snapletValue . l) b- put s = do- l <- ask- b <- liftAppHandler getSnapletState- liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b------------------------------------------------------------------------------------ | MonadSnaplet instance gives us access to the snaplet infrastructure.----instance MonadSnaplet SnapletHeist where- getLens = ask- with' l = withSS (l .)- withTop' l = withSS (const id) . with' l- getOpaqueConfig = do- l <- ask- b <- liftAppHandler getSnapletState- return $ getL (snapletConfig . l) b------------------------------------------------------------------------------------ | SnapletSplices version of bindSplices.----bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))- -> [(Text, SnapletSplice b v)]- -> HeistState (Handler b b)- -> HeistState (Handler b b)-bindSnapletSplices l splices =- bindSplices $ map (second $ runSnapletSplice l) splices+type SnapletHeist b m a = HeistT (Handler b b) m a+type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b)))+type SnapletISplice b = SnapletHeist b (Handler b b) Template --------------------------- -- Initializer functions -- --------------------------- + ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper -- around `heistInit'` that uses defaultHeistState and sets up routes for all -- the templates.----heistInit :: FilePath -- ^ Path to templates+heistInit :: FilePath+ -- ^ Path to templates -> SnapletInit b (Heist b) heistInit templateDir = do makeSnaplet "heist" "" Nothing $ do- hs <- heistInitWorker templateDir defaultHeistState+ hs <- heistInitWorker templateDir defaultConfig addRoutes [ ("", heistServe) ] return hs+ where+ defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices } ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'. This initializer requires you--- to specify the initial HeistState. It also does not add any routes for+-- to specify the initial HeistConfig. It also does not add any routes for -- templates, allowing you complete control over which templates get routed.--- heistInit' :: FilePath- -- ^ Path to templates- -> HeistState (Handler b b)- -- ^ Initial HeistState+ -- ^ Path to templates+ -> HeistConfig (Handler b b)+ -- ^ Initial HeistConfig -> SnapletInit b (Heist b)-heistInit' templateDir initialHeistState =- makeSnaplet "heist" "" Nothing $- heistInitWorker templateDir initialHeistState+heistInit' templateDir initialConfig =+ makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig ------------------------------------------------------------------------------ -- | Internal worker function used by variantsof heistInit. This is necessary -- because of the divide between SnapletInit and Initializer.--- heistInitWorker :: FilePath- -> HeistState (Handler b b)- -> Initializer b v (Heist b)-heistInitWorker templateDir initialHeistState = do- (cacheFunc, cts) <- liftIO mkCacheTag- let origTs = cacheFunc initialHeistState+ -> HeistConfig (Handler b b)+ -> Initializer b (Heist b) (Heist b)+heistInitWorker templateDir initialConfig = do snapletPath <- getSnapletFilePath let tDir = snapletPath </> templateDir- ts <- liftIO $ loadTemplates tDir origTs >>=- either error return+ templates <- liftIO $ runEitherT (loadTemplates tDir) >>=+ either (error . concat) return+ let config = initialConfig `mappend` mempty { hcTemplates = templates } printInfo $ T.pack $ unwords [ "...loaded"- , (show $ length $ templateNames ts)+ , (show $ Map.size templates) , "templates from" , tDir ]+ ref <- liftIO $ newIORef config+ addPostInitHook finalLoadHook+ return $ Configuring ref - return $ Heist ts cts +------------------------------------------------------------------------------+-- | Hook that converts the Heist type from Configuring to Running at the end+-- of initialization.+finalLoadHook :: Heist b -> EitherT Text IO (Heist b)+finalLoadHook (Configuring ref) = do+ hc <- lift $ readIORef ref+ (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc+ return $ Running hs cts+ where+ toTextErrors = mapEitherT (T.pack . intercalate "\n") id+finalLoadHook (Running _ _) = left "finalLoadHook called while running" + --------------------------------------------------------------------------------- | Adds templates to the Heist HeistState. Other snaplets should use+-- | Adds templates to the Heist HeistConfig. Other snaplets should use -- this function to add their own templates. The templates are automatically -- read from the templates directory in the current snaplet's filesystem root.-addTemplates :: ByteString- -- ^ The url prefix for the template routes+addTemplates :: Snaplet (Heist b)+ -> ByteString+ -- ^ The url prefix for the template routes -> Initializer b (Heist b) ()-addTemplates urlPrefix = do+addTemplates h urlPrefix = do snapletPath <- getSnapletFilePath- addTemplatesAt urlPrefix (snapletPath </> "templates")+ addTemplatesAt h urlPrefix (snapletPath </> "templates") --------------------------------------------------------------------------------- | Adds templates to the Heist HeistState, and lets you specify where+-- | Adds templates to the Heist HeistConfig, and lets you specify where -- they are found in the filesystem. Note that the path to the template -- directory is an absolute path. This allows you more flexibility in where -- your templates are located, but means that you have to explicitly call -- getSnapletFilePath if you want your snaplet to use templates within its -- normal directory structure.-addTemplatesAt :: ByteString- -- ^ URL prefix for template routes+addTemplatesAt :: Snaplet (Heist b)+ -> ByteString+ -- ^ URL prefix for template routes -> FilePath- -- ^ Path to templates+ -- ^ Path to templates -> Initializer b (Heist b) ()-addTemplatesAt urlPrefix templateDir = do- ts <- liftIO $ loadTemplates templateDir mempty- >>= either error return+addTemplatesAt h urlPrefix templateDir = do rootUrl <- getSnapletRootURL let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) </> (T.unpack $ decodeUtf8 urlPrefix)+ addPrefix = return . addTemplatePathPrefix+ (encodeUtf8 $ T.pack fullPrefix)+ ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=+ either (error . concat) addPrefix printInfo $ T.pack $ unwords [ "...adding"- , (show $ length $ templateNames ts)+ , (show $ Map.size ts) , "templates from" , templateDir , "with route prefix" , fullPrefix ++ "/" ]- addPostInitHook $ return . changeTS- (`mappend` addTemplatePathPrefix (encodeUtf8 $ T.pack fullPrefix) ts)+ liftIO $ atomicModifyIORef (_heistConfig $ extract h)+ (\hc -> (hc `mappend` mempty { hcTemplates = ts }, ())) -------------------------------------------------------------------------------modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))- -> (HeistState (Handler b b) -> HeistState (Handler b b))- -> Initializer b v ()-modifyHeistTS' heist f = do- _lens <- getLens- withTop' heist $ addPostInitHook $ return . changeTS f+modifyHeistState' :: SnapletLens (Snaplet b) (Heist b)+ -> (HeistState (Handler b b) -> HeistState (Handler b b))+ -> Initializer b v ()+modifyHeistState' heist f = do+ withTop' heist $ addPostInitHook $ return . changeState f -------------------------------------------------------------------------------modifyHeistTS :: (Lens b (Snaplet (Heist b)))- -> (HeistState (Handler b b) -> HeistState (Handler b b))- -> Initializer b v ()-modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f+modifyHeistState :: SnapletLens b (Heist b)+ -> (HeistState (Handler b b) -> HeistState (Handler b b))+ -> Initializer b v ()+modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f -------------------------------------------------------------------------------withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))- -> (HeistState (Handler b b) -> a)- -> Handler b v a-withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)+withHeistState' :: SnapletLens (Snaplet b) (Heist b)+ -> (HeistState (Handler b b) -> a)+ -> Handler b v a+withHeistState' heist f = do+ hs <- withTop' heist $ gets _heistState+ return $ f hs -------------------------------------------------------------------------------withHeistTS :: (Lens b (Snaplet (Heist b)))- -> (HeistState (Handler b b) -> a)- -> Handler b v a-withHeistTS heist f = withHeistTS' (subSnaplet heist) f+withHeistState :: SnapletLens b (Heist b)+ -> (HeistState (Handler b b) -> a)+ -> Handler b v a+withHeistState heist f = withHeistState' (subSnaplet heist) f -------------------------------------------------------------------------------addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))- -> [(Text, SnapletSplice b v)]+-- | Adds more HeistConfig data using mappend with whatever is currently+-- there. This is the preferred method for adding all four kinds of splices+-- as well as new templates.+addConfig :: Snaplet (Heist b)+ -> HeistConfig (Handler b b)+ -> Initializer b v ()+addConfig h hc = case extract h of+ Configuring ref ->+ liftIO $ atomicModifyIORef ref (\hc1 -> (hc1 `mappend` hc, ()))+ Running _ _ -> do+ printInfo "finalLoadHook called while running"+ error "this shouldn't happen"+++------------------------------------------------------------------------------+addSplices' :: SnapletLens (Snaplet b) (Heist b)+ -> [(Text, SnapletISplice b)] -> Initializer b v () addSplices' heist splices = do- _lens <- getLens withTop' heist $ addPostInitHook $- return . changeTS (bindSnapletSplices _lens splices)+ return . changeState (I.bindSplices splices) -------------------------------------------------------------------------------addSplices :: (Lens b (Snaplet (Heist b)))- -> [(Text, SnapletSplice b v)]+addSplices :: SnapletLens b (Heist b)+ -> [(Text, SnapletISplice b)] -> Initializer b v () addSplices heist splices = addSplices' (subSnaplet heist) splices @@ -363,12 +310,12 @@ ------------------------------------------------------------------------------ -- | Internal helper function for rendering.-renderHelper :: Maybe MIMEType+iRenderHelper :: Maybe MIMEType -> ByteString -> Handler b (Heist b) ()-renderHelper c t = do- (Heist ts _) <- get- withTop' id $ renderTemplate ts t >>= maybe pass serve+iRenderHelper c t = do+ (Running hs _) <- get+ withTop' id $ I.renderTemplate hs t >>= maybe pass serve where serve (b, mime) = do modifyResponse $ setContentType $ fromMaybe mime c@@ -376,49 +323,99 @@ ------------------------------------------------------------------------------+-- | Internal helper function for rendering.+cRenderHelper :: Maybe MIMEType+ -> ByteString+ -> Handler b (Heist b) ()+cRenderHelper c t = do+ (Running hs _) <- get+ withTop' id $ maybe pass serve $ C.renderTemplate hs t+ where+ serve (b, mime) = do+ modifyResponse $ setContentType $ fromMaybe mime c+ writeBuilder =<< b+++------------------------------------------------------------------------------ render :: ByteString- -- ^ Name of the template+ -- ^ Name of the template -> Handler b (Heist b) ()-render t = renderHelper Nothing t+render t = iRenderHelper Nothing t ------------------------------------------------------------------------------ renderAs :: ByteString- -- ^ Content type+ -- ^ Content type -> ByteString- -- ^ Name of the template+ -- ^ Name of the template -> Handler b (Heist b) ()-renderAs ct t = renderHelper (Just ct) t+renderAs ct t = iRenderHelper (Just ct) t ------------------------------------------------------------------------------+cRender :: ByteString+ -- ^ Name of the template+ -> Handler b (Heist b) ()+cRender t = cRenderHelper Nothing t+++------------------------------------------------------------------------------+cRenderAs :: ByteString+ -- ^ Content type+ -> ByteString+ -- ^ Name of the template+ -> Handler b (Heist b) ()+cRenderAs ct t = cRenderHelper (Just ct) t+++------------------------------------------------------------------------------+serveURI :: Handler b (Heist b) ByteString+serveURI = do+ p <- getSafePath+ -- Allows users to prefix template filenames with an underscore to prevent+ -- the template from being served.+ if head p == '_' then pass else return $ B.pack p+++------------------------------------------------------------------------------ heistServe :: Handler b (Heist b) () heistServe =- ifTop (render "index") <|> (render . B.pack =<< getSafePath)+ ifTop (render "index") <|> (render =<< serveURI) -------------------------------------------------------------------------------heistServeSingle :: ByteString- -> Handler b (Heist b) ()+heistServeSingle :: ByteString -> Handler b (Heist b) () heistServeSingle t = render t <|> error ("Template " ++ show t ++ " not found.") -------------------------------------------------------------------------------heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))+cHeistServe :: Handler b (Heist b) ()+cHeistServe =+ ifTop (cRender "index") <|> (cRender =<< serveURI)+++------------------------------------------------------------------------------+cHeistServeSingle :: ByteString -> Handler b (Heist b) ()+cHeistServeSingle t =+ cRender t <|> error ("Template " ++ show t ++ " not found.")+++------------------------------------------------------------------------------+heistLocal' :: SnapletLens (Snaplet b) (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a heistLocal' heist f m = do hs <- withTop' heist get- withTop' heist $ modify $ changeTS f+ withTop' heist $ modify $ changeState f res <- m withTop' heist $ put hs return res -------------------------------------------------------------------------------heistLocal :: (Lens b (Snaplet (Heist b)))+heistLocal :: SnapletLens b (Heist b) -> (HeistState (Handler b b) -> HeistState (Handler b b)) -> Handler b v a -> Handler b v a@@ -426,36 +423,35 @@ -------------------------------------------------------------------------------withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))- -> [(Text, SnapletSplice b v)]+withSplices' :: SnapletLens (Snaplet b) (Heist b)+ -> [(Text, SnapletISplice b)] -> Handler b v a -> Handler b v a withSplices' heist splices m = do- _lens <- getLens- heistLocal' heist (bindSnapletSplices _lens splices) m+ heistLocal' heist (I.bindSplices splices) m -------------------------------------------------------------------------------withSplices :: (Lens b (Snaplet (Heist b)))- -> [(Text, SnapletSplice b v)]+withSplices :: SnapletLens b (Heist b)+ -> [(Text, SnapletISplice b)] -> Handler b v a -> Handler b v a withSplices heist splices m = withSplices' (subSnaplet heist) splices m -------------------------------------------------------------------------------renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))+renderWithSplices' :: SnapletLens (Snaplet b) (Heist b) -> ByteString- -> [(Text, SnapletSplice b v)]+ -> [(Text, SnapletISplice b)] -> Handler b v () renderWithSplices' heist t splices = withSplices' heist splices $ withTop' heist $ render t -------------------------------------------------------------------------------renderWithSplices :: (Lens b (Snaplet (Heist b)))+renderWithSplices :: SnapletLens b (Heist b) -> ByteString- -> [(Text, SnapletSplice b v)]+ -> [(Text, SnapletISplice b)] -> Handler b v () renderWithSplices heist t splices = renderWithSplices' (subSnaplet heist) t splices
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -13,7 +13,6 @@ , nameSnaplet , onUnload , addRoutes- , wrapHandlers , wrapSite , runInitializer , runSnaplet@@ -22,10 +21,11 @@ , printInfo ) where -import Prelude hiding ((.), id, catch)-import Control.Category+import Prelude hiding (catch) import Control.Concurrent.MVar+import Control.Error import Control.Exception (SomeException)+import Control.Lens import Control.Monad import Control.Monad.CatchIO hiding (Handler) import Control.Monad.Reader@@ -36,7 +36,6 @@ import Data.Configurator import Data.IORef import Data.Maybe-import Data.Lens.Lazy import Data.Text (Text) import qualified Data.Text as T import Snap.Http.Server@@ -77,7 +76,8 @@ ------------------------------------------------------------------------------ -- | Converts a plain hook into a Snaplet hook.-toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v))+toSnapletHook :: (v -> EitherT Text IO v)+ -> (Snaplet v -> EitherT Text IO (Snaplet v)) toSnapletHook f (Snaplet cfg val) = do val' <- f val return $! Snaplet cfg val'@@ -91,11 +91,13 @@ -- define its views. The Heist snaplet provides the 'addTemplates' function -- which allows other snaplets to set up their own templates. 'addTemplates' -- is implemented using this function.-addPostInitHook :: (v -> IO v) -> Initializer b v ()+addPostInitHook :: (v -> EitherT Text IO v)+ -> Initializer b v () addPostInitHook = addPostInitHook' . toSnapletHook -addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v ()+addPostInitHook' :: (Snaplet v -> EitherT Text IO (Snaplet v))+ -> Initializer b v () addPostInitHook' h = do h' <- upHook h addPostInitHookBase h'@@ -103,15 +105,15 @@ ------------------------------------------------------------------------------ -- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.-addPostInitHookBase :: (Snaplet b -> IO (Snaplet b))+addPostInitHookBase :: (Snaplet b -> EitherT Text IO (Snaplet b)) -> Initializer b v () addPostInitHookBase = Initializer . lift . tell . Hook ------------------------------------------------------------------------------ -- | Helper function for transforming hooks.-upHook :: (Snaplet v -> IO (Snaplet v))- -> Initializer b v (Snaplet b -> IO (Snaplet b))+upHook :: (Snaplet v -> EitherT Text IO (Snaplet v))+ -> Initializer b v (Snaplet b -> EitherT Text IO (Snaplet b)) upHook h = Initializer $ do l <- ask return $ upHook' l h@@ -119,27 +121,27 @@ ------------------------------------------------------------------------------ -- | Helper function for transforming hooks.-upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b+upHook' :: Monad m => SimpleLoupe b a -> (a -> m a) -> b -> m b upHook' l h b = do- v <- h (getL l b)- return $ setL l v b+ v <- h (b ^# l)+ return $ storing l v b ------------------------------------------------------------------------------ -- | Modifies the Initializer's SnapletConfig. modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()-modifyCfg f = iModify $ modL curConfig $ \c -> f c+modifyCfg f = iModify $ over curConfig $ \c -> f c ------------------------------------------------------------------------------ -- | If a snaplet has a filesystem presence, this function creates and copies -- the files if they dont' already exist. setupFilesystem :: Maybe (IO FilePath)- -- ^ The directory where the snaplet's reference files are- -- stored. Nothing if the snaplet doesn't come with any files- -- that need to be installed.+ -- ^ The directory where the snaplet's reference files are+ -- stored. Nothing if the snaplet doesn't come with any+ -- files that need to be installed. -> FilePath- -- ^ Directory where the files should be copied.+ -- ^ Directory where the files should be copied. -> Initializer b v () setupFilesystem Nothing _ = return () setupFilesystem (Just getSnapletDataDir) targetDir = do@@ -153,10 +155,10 @@ where doCopy srcRoot targetRoot filename = do createDirectoryIfMissing True directory- copyFile filename to+ copyFile filename toDir where- to = targetRoot </> makeRelative srcRoot filename- directory = dropFileName to+ toDir = targetRoot </> makeRelative srcRoot filename+ directory = dropFileName toDir ------------------------------------------------------------------------------@@ -176,32 +178,34 @@ -- and makeSnaplet converts it into an opaque SnapletInit type. This allows -- us to use the type system to ensure that the API is used correctly. makeSnaplet :: Text- -- ^ A default id for this snaplet. This is only used when the- -- end-user has not already set an id using the nameSnaplet function.- -> Text- -- ^ A human readable description of this snaplet.- -> Maybe (IO FilePath)- -- ^ The path to the directory holding the snaplet's reference- -- filesystem content. This will almost always be the directory- -- returned by Cabal's getDataDir command, but it has to be passed in- -- because it is defined in a package-specific import. Setting this- -- value to Nothing doesn't preclude the snaplet from having files in- -- in the filesystem, it just means that they won't be copied there- -- automatically.- -> Initializer b v v- -- ^ Snaplet initializer.- -> SnapletInit b v+ -- ^ A default id for this snaplet. This is only used when+ -- the end-user has not already set an id using the+ -- nameSnaplet function.+ -> Text+ -- ^ A human readable description of this snaplet.+ -> Maybe (IO FilePath)+ -- ^ The path to the directory holding the snaplet's reference+ -- filesystem content. This will almost always be the+ -- directory returned by Cabal's getDataDir command, but it+ -- has to be passed in because it is defined in a+ -- package-specific import. Setting this value to Nothing+ -- doesn't preclude the snaplet from having files in in the+ -- filesystem, it just means that they won't be copied there+ -- automatically.+ -> Initializer b v v+ -- ^ Snaplet initializer.+ -> SnapletInit b v makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do modifyCfg $ \c -> if isNothing $ _scId c- then setL scId (Just snapletId) c else c+ then set scId (Just snapletId) c else c sid <- iGets (T.unpack . fromJust . _scId . _curConfig) topLevel <- iGets _isTopLevel unless topLevel $ do- modifyCfg $ modL scUserConfig (subconfig (T.pack sid))- modifyCfg $ \c -> setL scFilePath+ modifyCfg $ over scUserConfig (subconfig (T.pack sid))+ modifyCfg $ \c -> set scFilePath (_scFilePath c </> "snaplets" </> sid) c- iModify (setL isTopLevel False)- modifyCfg $ setL scDescription desc+ iModify (set isTopLevel False)+ modifyCfg $ set scDescription desc cfg <- iGets _curConfig printInfo $ T.pack $ concat ["Initializing "@@ -238,7 +242,7 @@ bracketInit m = do s <- iGet res <- m- iModify (setL curConfig (_curConfig s))+ iModify (set curConfig (_curConfig s)) return res @@ -248,9 +252,9 @@ setupSnapletCall :: ByteString -> Initializer b v () setupSnapletCall rte = do curId <- iGets (fromJust . _scId . _curConfig)- modifyCfg (modL scAncestry (curId:))- modifyCfg (modL scId (const Nothing))- unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:))+ modifyCfg (over scAncestry (curId:))+ modifyCfg (over scId (const Nothing))+ unless (B.null rte) $ modifyCfg (over scRouteContext (rte:)) ------------------------------------------------------------------------------@@ -260,16 +264,18 @@ -- possible for the child snaplet to make use of functionality provided by -- sibling snaplets. nestSnaplet :: ByteString- -- ^ The root url for all the snaplet's routes. An empty string- -- gives the routes the same root as the parent snaplet's routes.- -> (Lens v (Snaplet v1))- -- ^ Lens identifying the snaplet+ -- ^ The root url for all the snaplet's routes. An empty+ -- string gives the routes the same root as the parent+ -- snaplet's routes.+ -> SnapletLens v v1+ -- ^ Lens identifying the snaplet -> SnapletInit b v1- -- ^ The initializer function for the subsnaplet.+ -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1)-nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do- setupSnapletCall rte- snaplet+nestSnaplet rte l (SnapletInit snaplet) =+ with l $ bracketInit $ do+ setupSnapletCall rte+ snaplet ------------------------------------------------------------------------------@@ -282,27 +288,28 @@ -- type variable. The embedded snaplet can still get functionality from other -- snaplets, but only if it nests or embeds the snaplet itself. embedSnaplet :: ByteString- -- ^ The root url for all the snaplet's routes. An empty string- -- gives the routes the same root as the parent snaplet's routes.- --- -- NOTE: Because of the stronger isolation provided by- -- embedSnaplet, you should be more careful about using an empty- -- string here.- -> (Lens v (Snaplet v1))- -- ^ Lens identifying the snaplet+ -- ^ The root url for all the snaplet's routes. An empty+ -- string gives the routes the same root as the parent+ -- snaplet's routes.+ --+ -- NOTE: Because of the stronger isolation provided by+ -- embedSnaplet, you should be more careful about using an+ -- empty string here.+ -> SnapletLens v v1+ -- ^ Lens identifying the snaplet -> SnapletInit v1 v1- -- ^ The initializer function for the subsnaplet.+ -- ^ The initializer function for the subsnaplet. -> Initializer b v (Snaplet v1) embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do curLens <- getLens setupSnapletCall ""- chroot rte (subSnaplet l . curLens) snaplet+ chroot rte (cloneLens curLens . subSnaplet l) snaplet ------------------------------------------------------------------------------ -- | Changes the base state of an initializer. chroot :: ByteString- -> (Lens (Snaplet b) (Snaplet v1))+ -> SnapletLens (Snaplet b) v1 -> Initializer v1 v1 a -> Initializer b v a chroot rte l (Initializer m) = do@@ -313,20 +320,20 @@ _hFilter = id } let handler = chrootHandler l $ _hFilter s $ route $ _handlers s- iModify $ modL handlers (++[(rte,handler)])- . setL cleanup (_cleanup s)+ iModify $ over handlers (++[(rte,handler)])+ . set cleanup (_cleanup s) addPostInitHookBase $ upHook' l hook return a ------------------------------------------------------------------------------ -- | Changes the base state of a handler.-chrootHandler :: (Lens (Snaplet v) (Snaplet b'))+chrootHandler :: SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a chrootHandler l (Handler h) = Handler $ do s <- get- (a, s') <- liftSnap $ L.runLensed h id (getL l s)- modify $ setL l s'+ (a, s') <- liftSnap $ L.runLensed h id (s ^# l)+ modify $ storing l s' return a @@ -339,12 +346,12 @@ -- -- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ nameSnaplet :: Text- -- ^ The snaplet name+ -- ^ The snaplet name -> SnapletInit b v- -- ^ The snaplet initializer function+ -- ^ The snaplet initializer function -> SnapletInit b v nameSnaplet nm (SnapletInit m) = SnapletInit $- modifyCfg (setL scId (Just nm)) >> m+ modifyCfg (set scId (Just nm)) >> m ------------------------------------------------------------------------------@@ -359,7 +366,7 @@ let modRoute (r,h) = ( buildPath (r:ctx) , setPattern r >> withTop' l h) let rs' = map modRoute rs- iModify (\v -> modL handlers (++rs') v)+ iModify (\v -> over handlers (++rs') v) where setPattern r = do p <- getRoutePattern@@ -376,19 +383,11 @@ -- > wrapSite (\site -> ensureAdminUser >> site) -- wrapSite :: (Handler b v () -> Handler b v ())- -- ^ Handler modifier function+ -- ^ Handler modifier function -> Initializer b v () wrapSite f0 = do f <- mungeFilter f0- iModify (\v -> modL hFilter (f.) v)------------------------------------------------------------------------------------ | This function has been renamed to 'wrapSite' and is deprecated. It will--- be removed in the next major Snap release. Fix your code now!-wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v ()-wrapHandlers = wrapSite-{-# DEPRECATED wrapHandlers "wrapHandlers was renamed to wrapSite" #-}+ iModify (\v -> over hFilter (f.) v) ------------------------------------------------------------------------------@@ -486,12 +485,12 @@ (mkReloader cwd env mvar cleanupRef b) logRef <- newIORef "" - let body = do- ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $+ let body = runEitherT $ do+ ((res, s), (Hook hook)) <- lift $ runWriterT $ LT.runLensT i id $ InitializerState True cleanupRef builtinHandlers id cfg logRef env res' <- hook res- return $ Right (res', s)+ right (res', s) handler e = do join $ readIORef cleanupRef@@ -549,10 +548,11 @@ -- runs the given Snaplet initializer, and starts an HTTP server running the -- Snaplet's toplevel 'Handler'. serveSnaplet :: Config Snap AppConfig- -- ^ The configuration of the server - you can usually pass a- -- default 'Config' via 'Snap.Http.Server.Config.defaultConfig'.+ -- ^ The configuration of the server - you can usually pass a+ -- default 'Config' via+ -- 'Snap.Http.Server.Config.defaultConfig'. -> SnapletInit b b- -- ^ The snaplet initializer function.+ -- ^ The snaplet initializer function. -> IO () serveSnaplet startConfig initializer = do config <- commandLineAppConfig startConfig
src/Snap/Snaplet/Internal/LensT.hs view
@@ -7,17 +7,18 @@ import Control.Applicative import Control.Category+import Control.Lens (cloneLens)+import Control.Lens.Loupe import Control.Monad.CatchIO import Control.Monad.Reader import Control.Monad.State.Class-import Data.Lens.Lazy import Prelude hiding ((.), id, catch) import Snap.Core import Snap.Snaplet.Internal.RST -newtype LensT b v s m a = LensT (RST (Lens b v) s m a)+newtype LensT b v s m a = LensT (RST (SimpleLoupe b v) s m a) deriving ( Monad , MonadTrans , Functor@@ -26,59 +27,55 @@ , MonadPlus , MonadCatchIO , Alternative- , MonadReader (Lens b v)+ , MonadReader (SimpleLoupe b v) , MonadSnap ) -------------------------------------------------------------------------------instance (Monad m) => MonadState v (LensT b v b m) where+instance Monad m => MonadState v (LensT b v b m) where get = lGet put = lPut -------------------------------------------------------------------------------getBase :: (Monad m) => LensT b v s m s+getBase :: Monad m => LensT b v s m s getBase = LensT get {-# INLINE getBase #-} -------------------------------------------------------------------------------putBase :: (Monad m) => s -> LensT b v s m ()+putBase :: Monad m => s -> LensT b v s m () putBase = LensT . put {-# INLINE putBase #-} -------------------------------------------------------------------------------lGet :: (Monad m) => LensT b v b m v+lGet :: Monad m => LensT b v b m v lGet = LensT $ do !l <- ask !b <- get- return $! l ^$ b+ return $! b ^# l {-# INLINE lGet #-} -------------------------------------------------------------------------------lPut :: (Monad m) => v -> LensT b v b m ()+lPut :: Monad m => v -> LensT b v b m () lPut v = LensT $ do !l <- ask !b <- get- put $! (l ^!= v) b+ put $! storing l v b {-# INLINE lPut #-} -------------------------------------------------------------------------------runLensT :: (Monad m) =>- LensT b v s m a- -> Lens b v- -> s- -> m (a, s)-runLensT (LensT m) = runRST m+runLensT :: Monad m => LensT b v s m a -> SimpleLoupe b v -> s -> m (a, s)+runLensT (LensT m) l = runRST m l {-# INLINE runLensT #-} -------------------------------------------------------------------------------withLensT :: Monad m =>- ((Lens b' v') -> (Lens b v))+withLensT :: Monad m+ => (SimpleLoupe b' v' -> SimpleLoupe b v) -> LensT b v s m a -> LensT b' v' s m a withLensT f (LensT m) = LensT $ withRST f m@@ -87,19 +84,14 @@ ------------------------------------------------------------------------------ withTop :: Monad m- => (Lens b v')+ => SimpleLoupe b v' -> LensT b v' s m a -> LensT b v s m a-withTop !subLens = withLensT (const subLens)+withTop subLens = withLensT (const subLens) {-# INLINE withTop #-} -------------------------------------------------------------------------------with :: Monad m- => (Lens v v')- -> LensT b v' s m a- -> LensT b v s m a-with !subLens = withLensT (subLens .)-{-# INLINE with #-}-+with :: Monad m => SimpleLoupe v v' -> LensT b v' s m a -> LensT b v s m a+with subLens = withLensT (\l -> cloneLens l . subLens)
src/Snap/Snaplet/Internal/Lensed.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} module Snap.Snaplet.Internal.Lensed where import Control.Applicative+import Control.Lens (cloneLens)+import Control.Lens.Loupe import Control.Monad+import Control.Monad.Reader.Class import Control.Monad.Trans-import Data.Lens.Strict import Control.Monad.CatchIO-import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.State.Strict import Control.Category import Prelude hiding (catch, id, (.)) import Snap.Core - ------------------------------------------------------------------------------ newtype Lensed b v m a = Lensed- { unlensed :: Lens b v -> v -> b -> m (a, v, b) }+ { unlensed :: SimpleLoupe b v -> v -> b -> m (a, v, b) } ------------------------------------------------------------------------------@@ -49,20 +50,21 @@ put v' = Lensed $ \_ _ s -> return ((), v', s) --------------------------------------------------------------------------------instance Monad m => MonadReader (Lens b v) (Lensed b v m) where- ask = Lensed $ \l v s -> return (l, v, s)- local f g = do- l' <- asks f- withTop l' g+instance Monad m => MonadReader (SimpleLoupe b v) (Lensed b v m) where+ ask = Lensed $ \l v s -> return (l, v, s)+ local = lensedLocal +------------------------------------------------------------------------------+lensedLocal :: Monad m => (SimpleLoupe b v -> SimpleLoupe b v') -> Lensed b v' m a -> Lensed b v m a+lensedLocal f g = do+ l <- ask+ withTop (f l) g ------------------------------------------------------------------------------ instance MonadTrans (Lensed b v) where lift m = Lensed $ \_ v b -> do- res <- m- return (res, v, b)-+ res <- m+ return (res, v, b) ------------------------------------------------------------------------------ instance MonadIO m => MonadIO (Lensed b v m) where@@ -73,7 +75,7 @@ instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b where- handler l v b e = let (Lensed h) = f e+ handler l v b e = let Lensed h = f e in h l v b block (Lensed m) = Lensed $ \l v b -> block (m l v b)@@ -90,7 +92,7 @@ ------------------------------------------------------------------------------ instance (Monad m, Alternative m) => Alternative (Lensed b v m) where empty = lift empty- (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b+ Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b ------------------------------------------------------------------------------@@ -99,53 +101,52 @@ ------------------------------------------------------------------------------+globally :: Monad m => StateT b m a -> Lensed b v m a+globally (StateT f) = Lensed $ \l v s ->+ liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s)+++------------------------------------------------------------------------------+lensedAsState :: Monad m => Lensed b v m a -> SimpleLoupe b v -> StateT b m a+lensedAsState (Lensed f) l = StateT $ \s -> do+ (a, v', s') <- f l (s ^# l) s+ return (a, storing l v' s')+++------------------------------------------------------------------------------ getBase :: Monad m => Lensed b v m b getBase = Lensed $ \_ v b -> return (b, v, b) -------------------------------------------------------------------------------withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a+withTop :: Monad m => SimpleLoupe b v' -> Lensed b v' m a -> Lensed b v m a withTop l m = globally $ lensedAsState m l -------------------------------------------------------------------------------with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a+with :: Monad m => SimpleLoupe v v' -> Lensed b v' m a -> Lensed b v m a with l g = do- l' <- asks (l .)- withTop l' g+ l' <- ask+ withTop (cloneLens l' . l) g -------------------------------------------------------------------------------embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a+embed :: Monad m => SimpleLoupe v v' -> Lensed v v' m a -> Lensed b v m a embed l m = locally $ lensedAsState m l -------------------------------------------------------------------------------globally :: Monad m => StateT b m a -> Lensed b v m a-globally (StateT f) = Lensed $ \l v s ->- liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s)--------------------------------------------------------------------------------- locally :: Monad m => StateT v m a -> Lensed b v m a locally (StateT f) = Lensed $ \_ v s -> liftM (\(a, v') -> (a, v', s)) $ f v -------------------------------------------------------------------------------lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a-lensedAsState (Lensed f) l = StateT $ \s -> do- (a, v', s') <- f l (l ^$ s) s- return (a, l ^= v' $ s')--------------------------------------------------------------------------------- runLensed :: Monad m => Lensed t1 b m t- -> Lens t1 b+ -> SimpleLoupe t1 b -> t1 -> m (t, t1) runLensed (Lensed f) l s = do- (a, v', s') <- f l (l ^$ s) s- return (a, l ^= v' $ s')-+ (a, v', s') <- f l (s ^# l) s+ return (a, storing l v' s')
src/Snap/Snaplet/Internal/Types.hs view
@@ -1,15 +1,22 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} +#ifndef MIN_VERSION_comonad+#define MIN_VERSION_comonad(x,y,z) 1+#endif+ module Snap.Snaplet.Internal.Types where -import Prelude hiding ((.), id) import Control.Applicative-import Control.Category ((.), id)+import Control.Comonad+import Control.Error+import Control.Lens import Control.Monad.CatchIO hiding (Handler) import Control.Monad.Reader import Control.Monad.State.Class@@ -19,9 +26,8 @@ import Data.Configurator.Types import Data.IORef import Data.Monoid-import Data.Lens.Lazy-import Data.Lens.Template import Data.Text (Text)+import Data.Foldable (Foldable(..)) import Snap.Core import qualified Snap.Snaplet.Internal.LensT as LT@@ -40,12 +46,15 @@ , _scUserConfig :: Config , _scRouteContext :: [ByteString] , _scRoutePattern :: Maybe ByteString- -- ^ Holds the actual route pattern passed to addRoutes for the current- -- handler. Nothing during initialization and before route dispatech.+ -- ^ Holds the actual route pattern passed to addRoutes for the+ -- current handler. Nothing during initialization and before route+ -- dispatech. , _reloader :: IO (Either Text Text) -- might change } +makeLenses ''SnapletConfig + ------------------------------------------------------------------------------ -- | Joins a reversed list of directories into a path. buildPath :: [ByteString] -> ByteString@@ -72,26 +81,45 @@ , _snapletValue :: s } +makeLenses ''Snaplet -makeLenses [''SnapletConfig, ''Snaplet]+instance Functor Snaplet where+ fmap f (Snaplet c a) = Snaplet c (f a) +instance Foldable Snaplet where+ foldMap f (Snaplet _ a) = f a++instance Traversable Snaplet where+ traverse f (Snaplet c a) = Snaplet c <$> f a++instance Comonad Snaplet where+ extract (Snaplet _ a) = a++#if !(MIN_VERSION_comonad(3,0,0))+instance Extend Snaplet where+#endif+ extend f w@(Snaplet c _) = Snaplet c (f w)+ {- ------------------------------------------------------------------------------ -- | A lens referencing the opaque SnapletConfig data type held inside -- Snaplet.-snapletConfig :: Lens (Snaplet a) SnapletConfig+snapletConfig :: SimpleLens (Snaplet a) SnapletConfig ------------------------------------------------------------------------------ -- | A lens referencing the user-defined state type wrapped by a Snaplet.-snapletValue :: Lens (Snaplet a) a+snapletValue :: SimpleLens (Snaplet a) a -} +type SnapletLens s a = SimpleLoupe s (Snaplet a)+ ------------------------------------------------------------------------------ -- | Transforms a lens of the type you get from makeLenses to an similar lens -- that is more suitable for internal use.-subSnaplet :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b))-subSnaplet = (. snapletValue)+subSnaplet :: SnapletLens a b+ -> SnapletLens (Snaplet a) b+subSnaplet l = snapletValue . l ------------------------------------------------------------------------------@@ -108,21 +136,21 @@ -- think about snaplet lenses using a filesystem path metaphor, the lens -- supplied to this snaplet must be a relative path. In other words, the -- lens's base state must be the same as the current snaplet.- with :: (Lens v (Snaplet v'))- -- ^ A relative lens identifying a snaplet+ with :: SnapletLens v v'+ -- ^ A relative lens identifying a snaplet -> m b v' a- -- ^ Action from the lense's snaplet+ -- ^ Action from the lense's snaplet -> m b v a- with = with' . subSnaplet+ with l = with' (subSnaplet l) -- | Like 'with' but doesn't impose the requirement that the action -- being run be a descendant of the current snaplet. Using our filesystem -- metaphor again, the lens for this function must be an absolute -- path--it's base must be the same as the current base.- withTop :: (Lens b (Snaplet v'))- -- ^ An \"absolute\" lens identifying a snaplet+ withTop :: SnapletLens b v'+ -- ^ An \"absolute\" lens identifying a snaplet -> m b v' a- -- ^ Action from the lense's snaplet+ -- ^ Action from the lense's snaplet -> m b v a withTop l = withTop' (subSnaplet l) @@ -133,7 +161,8 @@ -- however the lens returned by 'getLens' will. -- -- @with = with' . subSnaplet@- with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a+ with' :: SnapletLens (Snaplet v) v'+ -> m b v' a -> m b v a -- Not providing a definition for this function in terms of withTop' -- allows us to avoid extra Monad type class constraints, making the type@@ -141,10 +170,11 @@ -- with' l m = flip withTop m . (l .) =<< getLens -- | The absolute version of 'with''- withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a+ withTop' :: SnapletLens (Snaplet b) v'+ -> m b v' a -> m b v a -- | Gets the lens for the current snaplet.- getLens :: m b v (Lens (Snaplet b) (Snaplet v))+ getLens :: m b v (SnapletLens (Snaplet b) v) -- | Gets the current snaplet's opaque config data type. You'll only use -- this function when writing MonadSnaplet instances.@@ -244,7 +274,7 @@ -- | The MonadState instance gives you access to the current snaplet's state. instance MonadState v (Handler b v) where get = getsSnapletState _snapletValue- put v = modifySnapletState (setL snapletValue v)+ put v = modifySnapletState (set snapletValue v) instance MonadSnaplet Handler where@@ -255,10 +285,19 @@ ------------------------------------------------------------------------------+-- | Like 'runBase', but it doesn't require an MVar to be executed.+runPureBase :: Handler b b a -> Snaplet b -> Snap a+runPureBase (Handler m) b = do+ (!a, _) <- L.runLensed m id b+ return $! a+++------------------------------------------------------------------------------ -- | Gets the route pattern that matched for the handler. This lets you find -- out exactly which of the strings you used in addRoutes matched. getRoutePattern :: Handler b v (Maybe ByteString)-getRoutePattern = withTop' id $ liftM _scRoutePattern getOpaqueConfig+getRoutePattern =+ withTop' id $ liftM _scRoutePattern getOpaqueConfig ------------------------------------------------------------------------------@@ -267,7 +306,7 @@ -- addRoutes. setRoutePattern :: ByteString -> Handler b v () setRoutePattern p = withTop' id $- modifySnapletState (setL (scRoutePattern . snapletConfig) (Just p))+ modifySnapletState (set (snapletConfig . scRoutePattern) (Just p)) ------------------------------------------------------------------------------@@ -325,12 +364,12 @@ { _isTopLevel :: Bool , _cleanup :: IORef (IO ()) , _handlers :: [(ByteString, Handler b b ())]- -- ^ Handler routes built up and passed to route.+ -- ^ Handler routes built up and passed to route. , _hFilter :: Handler b b () -> Handler b b ()- -- ^ Generic filtering of handlers+ -- ^ Generic filtering of handlers , _curConfig :: SnapletConfig- -- ^ This snaplet config is the incrementally built config for whatever- -- snaplet is currently being constructed.+ -- ^ This snaplet config is the incrementally built config for+ -- whatever snaplet is currently being constructed. , _initMessages :: IORef Text , _environment :: String }@@ -339,7 +378,7 @@ ------------------------------------------------------------------------------ -- | Wrapper around IO actions that modify state elements created during -- initialization.-newtype Hook a = Hook (Snaplet a -> IO (Snaplet a))+newtype Hook a = Hook (Snaplet a -> EitherT Text IO (Snaplet a)) instance Monoid (Hook a) where@@ -357,7 +396,7 @@ a) deriving (Applicative, Functor, Monad, MonadIO) -makeLenses [''InitializerState]+makeLenses ''InitializerState instance MonadSnaplet Initializer where
src/Snap/Snaplet/Session.hs view
@@ -1,6 +1,5 @@ module Snap.Snaplet.Session- ( SessionManager(..)- , ISessionManager(..)+ ( SessionManager , withSession , commitSession , setInSession@@ -11,21 +10,21 @@ , resetSession , touchSession + -- * Utilities Exported For Convenience , module Snap.Snaplet.Session.Common , module Snap.Snaplet.Session.SecureCookie ) where ------------------------------------------------------------------------------ import Control.Monad.State-import Data.Lens.Lazy-import Data.Text (Text)+import Data.Text (Text) import Snap.Core ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session.Common import Snap.Snaplet.Session.SecureCookie-import Snap.Snaplet.Session.SessionManager- ( SessionManager(..), ISessionManager(..) )+import Snap.Snaplet.Session.SessionManager + ( ISessionManager(..), SessionManager(..) ) import qualified Snap.Snaplet.Session.SessionManager as SM ------------------------------------------------------------------------------ @@ -33,7 +32,7 @@ ------------------------------------------------------------------------------ -- | Wrap around a handler, committing any changes in the session at the end ---withSession :: Lens b (Snaplet SessionManager)+withSession :: SnapletLens b SessionManager -> Handler b v a -> Handler b v a withSession l h = do
src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.Session.Backends.CookieSession ( initCookieSessionManager@@ -10,19 +10,21 @@ ------------------------------------------------------------------------------ import Control.Applicative import Control.Monad.Reader-import Data.ByteString (ByteString)+import Data.ByteString (ByteString) import Data.Generics-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import Data.Hashable (Hashable)-import Data.Serialize (Serialize)-import qualified Data.Serialize as S-import Data.Text (Text)-import Snap.Core (Snap)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Hashable (Hashable)+import Data.Serialize (Serialize)+import qualified Data.Serialize as S+import Data.Text (Text)+import Snap.Core (Snap) import Web.ClientSession ------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Session+import Snap.Snaplet.Session.SessionManager+------------------------------------------------------------------------------- ------------------------------------------------------------------------------
src/Snap/Snaplet/Session/SessionManager.hs view
@@ -1,16 +1,30 @@ {-# LANGUAGE ExistentialQuantification #-} +{-| This module is meant to be used mainly by Session backend+developers, who would naturally need access to ISessionManager class+internals. You can also use it if you need low-level access to the+backend functionality.-}+ module Snap.Snaplet.Session.SessionManager where +------------------------------------------------------------------------------- import Data.Text (Text)-import Prelude hiding (lookup)-+import Prelude hiding (lookup)+------------------------------------------------------------------------------- import Snap.Core (Snap)+------------------------------------------------------------------------------- --- | Any Haskell record that is a member of the 'ISessionManager' typeclass--- can be stuffed inside a 'SessionManager' to enable all session-related--- functionality.++-- | Any Haskell record that is a member of the 'ISessionManager'+-- typeclass can be stuffed inside a 'SessionManager' to enable all+-- session-related functionality.+--+-- To use sessions in your application, just find a Backend that would+-- produce one for you inside of your 'Initializer'. See+-- 'initCookieSessionManager' in+-- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option+-- that would get you started. data SessionManager = forall a. ISessionManager a => SessionManager a
+ src/Snap/Snaplet/Test.hs view
@@ -0,0 +1,107 @@+-- | The Snap.Snaplet.Test module contains primitives and combinators for+-- testing Snaplets.+module Snap.Snaplet.Test+ (+ -- ** Testing handlers+ evalHandler+ , runHandler+ , withTemporaryFile+ )+ where+++------------------------------------------------------------------------------+import Control.Concurrent.MVar+import Control.Exception.Base (finally)+import qualified Control.Exception as E+import Control.Monad.IO.Class+import Data.Text+import System.Directory+import System.IO.Error+++------------------------------------------------------------------------------+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Internal.Types+import Snap.Test hiding (evalHandler, runHandler)+import qualified Snap.Test as ST+import Snap.Snaplet.Internal.Initializer+++------------------------------------------------------------------------------+-- | Remove the given file before running an IO computation. Obviously it+-- can be used with 'Assertion'.+withTemporaryFile :: FilePath -> IO () -> IO ()+withTemporaryFile f = finally (removeFileMayNotExist f)+++------------------------------------------------------------------------------+-- | Utility function taken from Darcs+removeFileMayNotExist :: FilePath -> IO ()+removeFileMayNotExist f = catchNonExistence (removeFile f) ()+ where+ catchNonExistence :: IO a -> a -> IO a+ catchNonExistence job nonexistval =+ E.catch job $+ \e -> if isDoesNotExistError e then return nonexistval+ else ioError e+++------------------------------------------------------------------------------+-- | Given a Snaplet Handler and a 'RequestBuilder' defining+-- a test request, runs the Handler, producing an HTTP 'Response'.+--+-- Note that the output of this function is slightly different from+-- 'runHandler' defined in Snap.Test, because due to the fact running+-- the initializer inside 'SnapletInit' can throw an exception.+runHandler :: MonadIO m+ => RequestBuilder m ()+ -> Handler b b a+ -> SnapletInit b b+ -> m (Either Text Response)+runHandler rq h s = do+ app <- getSnaplet s+ case app of+ (Left e) -> return $ Left e+ (Right (a,_)) -> do+ res <- ST.runHandler rq $ runPureBase h a+ return $ Right res+++------------------------------------------------------------------------------+-- | Given a Snaplet Handler, a 'SnapletInit' specifying the initial state,+-- and a 'RequestBuilder' defining a test request, runs the handler,+-- returning the monadic value it produces.+--+-- Throws an exception if the 'Snap' handler early-terminates with 'finishWith'+-- or 'mzero'.+--+-- Note that the output of this function is slightly different from+-- 'evalHandler defined in Snap.Test, because due to the fact running+-- the initializer inside 'SnapletInit' can throw an exception.+evalHandler :: MonadIO m+ => RequestBuilder m ()+ -> Handler b b a+ -> SnapletInit b b+ -> m (Either Text a)+evalHandler rq h s = do+ app <- getSnaplet s+ case app of+ (Left e) -> return $ Left e+ (Right (a,_)) -> do+ res <- ST.evalHandler rq $ runPureBase h a+ return $ Right res+++------------------------------------------------------------------------------+-- | Run the given initializer, yielding a tuple where the first element is+-- a @Snaplet b@, or an error message whether the initializer threw an+-- exception. +getSnaplet :: MonadIO m+ => SnapletInit b b+ -> m (Either Text (Snaplet b, InitializerState b))+getSnaplet (SnapletInit initializer) = liftIO $ do+ mvar <- newEmptyMVar+ runInitializer mvar "" initializer+
test/non-cabal-appdir/snaplets/heist/templates/page.tpl view
@@ -3,6 +3,6 @@ <title>Example App</title> </head> <body>-<content/>+<apply-content/> </body> </html>
test/runTestsAndCoverage.sh view
@@ -35,6 +35,9 @@ Blackbox.FooSnaplet Blackbox.Tests Blackbox.Types+Snap.Snaplet.Auth.App+Snap.Snaplet.Auth.Handlers.Tests+Snap.Snaplet.Auth.Tests Snap.Snaplet.Internal.Lensed.Tests Snap.Snaplet.Internal.LensT.Tests Snap.Snaplet.Internal.RST.Tests
test/snap-testsuite.cabal view
@@ -1,7 +1,7 @@ name: snap-testsuite version: 0.0.1 build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.8 Executable snap-testsuite hs-source-dirs: ../src suite@@ -10,32 +10,50 @@ build-depends: Glob >= 0.5 && < 0.8, HUnit >= 1.2 && < 2,- MonadCatchIO-transformers >= 0.2 && < 0.4, QuickCheck >= 2.3.0.2,- attoparsec >= 0.10 && < 0.11,- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- containers >= 0.3,- data-lens >= 2.0.1 && < 2.11,- data-lens-template >= 2.1.1 && < 2.2,- directory,- directory-tree >= 0.10 && < 0.12,- filepath,- heist >= 0.7 && < 0.9,- http-conduit >= 1.4 && < 1.7,+ http-conduit >= 1.7 && < 1.9, http-types >= 0.6 && < 0.8,- mtl >= 2, process == 1.*,- snap-core >= 0.9 && < 0.10,- snap-server >= 0.9 && < 0.10, test-framework >= 0.6 && < 0.7, test-framework-hunit >= 0.2.7 && < 0.3, test-framework-quickcheck2 >= 0.2.12.1 && < 0.3,- text >= 0.11 && < 0.12,- transformers >= 0.2, unix >= 2.2.0.0 && < 2.7,- template-haskell + MonadCatchIO-transformers >= 0.2 && < 0.4,+ aeson >= 0.6 && < 0.7,+ attoparsec >= 0.10 && < 0.11,+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ cereal >= 0.3 && < 0.4,+ clientsession >= 0.8 && < 0.9,+ comonad >= 1.1 && < 3.1,+ configurator >= 0.1 && < 0.3,+ containers >= 0.3 && < 0.6,+ directory >= 1.0 && < 1.3,+ directory-tree >= 0.10 && < 0.12,+ dlist >= 0.5 && < 0.6,+ errors >= 1.3 && < 1.4,+ filepath >= 1.1 && < 1.4,+ hashable >= 1.1 && < 1.2,+ heist >= 0.10 && < 0.11,+ lens >= 3.7.0.1 && < 3.8,+ logict >= 0.4.2 && < 0.6,+ mtl > 2.0 && < 2.2,+ mwc-random >= 0.8 && < 0.13,+ pwstore-fast >= 2.2 && < 2.4,+ regex-posix >= 0.95 && < 1,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11,+ stm >= 2.2 && < 2.5,+ syb >= 0.1 && < 0.4,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.1.4 && < 0.3,+ vector >= 0.7.1 && < 0.11,+ vector-algorithms >= 0.4 && < 0.6,+ xmlhtml >= 0.1 && < 0.3+ extensions: BangPatterns, CPP,@@ -64,33 +82,40 @@ main-is: AppMain.hs build-depends:- MonadCatchIO-transformers >= 0.2 && < 0.4,- attoparsec >= 0.10 && < 0.11,- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- cereal >= 0.3,- clientsession >= 0.7.3.6 && < 0.9,- configurator >= 0.1 && < 0.3,- containers >= 0.3,- data-lens >= 2.0.1 && < 2.11,- data-lens-template >= 2.1.1 && < 2.2,- directory,- directory-tree >= 0.10 && < 0.12,- filepath,- hashable >= 1.1,- heist >= 0.7 && < 0.9,- mtl >= 2,- mwc-random >= 0.8,- process == 1.*,- snap-core >= 0.9.2 && < 0.10,- snap-server >= 0.9.2 && < 0.10,- syb >= 0.1,- time >= 1.1,- text >= 0.11 && < 0.12,- transformers >= 0.2,- unordered-containers >= 0.1.4,- template-haskell- --FIXME+ MonadCatchIO-transformers >= 0.2 && < 0.4,+ aeson >= 0.6 && < 0.7,+ attoparsec >= 0.10 && < 0.11,+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ cereal >= 0.3 && < 0.4,+ clientsession >= 0.8 && < 0.9,+ comonad >= 1.1 && < 3.1,+ configurator >= 0.1 && < 0.3,+ containers >= 0.3 && < 0.6,+ directory >= 1.0 && < 1.3,+ directory-tree >= 0.10 && < 0.12,+ dlist >= 0.5 && < 0.6,+ errors >= 1.3 && < 1.4,+ filepath >= 1.1 && < 1.4,+ hashable >= 1.1 && < 1.2,+ heist >= 0.10 && < 0.11,+ lens >= 3.7.0.1 && < 3.8,+ logict >= 0.4.2 && < 0.6,+ mtl > 2.0 && < 2.2,+ mwc-random >= 0.8 && < 0.13,+ pwstore-fast >= 2.2 && < 2.4,+ regex-posix >= 0.95 && < 1,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11,+ stm >= 2.2 && < 2.5,+ syb >= 0.1 && < 0.4,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.1.4 && < 0.3,+ vector >= 0.7.1 && < 0.11,+ vector-algorithms >= 0.4 && < 0.6,+ xmlhtml >= 0.1 && < 0.3 extensions: BangPatterns,@@ -119,24 +144,52 @@ main-is: NestTest.hs build-depends:- MonadCatchIO-transformers >= 0.2 && < 0.4,- attoparsec >= 0.10 && < 0.11,- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- containers >= 0.3,- data-lens >= 2.0.1 && < 2.11,- data-lens-template >= 2.1 && < 2.2,- directory,- directory-tree >= 0.10 && < 0.12,- filepath,- heist >= 0.7 && < 0.9,- mtl >= 2,+ Glob >= 0.5 && < 0.8,+ HUnit >= 1.2 && < 2,+ QuickCheck >= 2.3.0.2,+ http-conduit >= 1.7 && < 1.9,+ http-types >= 0.6 && < 0.8, process == 1.*,- snap-core >= 0.9 && < 0.10,- snap-server >= 0.9 && < 0.10,- text >= 0.11 && < 0.12,- transformers >= 0.2,- template-haskell+ test-framework >= 0.6 && < 0.7,+ test-framework-hunit >= 0.2.7 && < 0.3,+ test-framework-quickcheck2 >= 0.2.12.1 && < 0.3,+ unix >= 2.2.0.0 && < 2.7,++ MonadCatchIO-transformers >= 0.2 && < 0.4,+ aeson >= 0.6 && < 0.7,+ attoparsec >= 0.10 && < 0.11,+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ cereal >= 0.3 && < 0.4,+ clientsession >= 0.8 && < 0.9,+ comonad >= 1.1 && < 3.1,+ configurator >= 0.1 && < 0.3,+ containers >= 0.3 && < 0.6,+ directory >= 1.0 && < 1.3,+ directory-tree >= 0.10 && < 0.12,+ dlist >= 0.5 && < 0.6,+ errors >= 1.3 && < 1.4,+ filepath >= 1.1 && < 1.4,+ hashable >= 1.1 && < 1.2,+ heist >= 0.10 && < 0.11,+ lens >= 3.7.0.1 && < 3.8,+ logict >= 0.4.2 && < 0.6,+ mtl > 2.0 && < 2.2,+ mwc-random >= 0.8 && < 0.13,+ pwstore-fast >= 2.2 && < 2.4,+ regex-posix >= 0.95 && < 1,+ snap-core >= 0.9 && < 0.11,+ snap-server >= 0.9 && < 0.11,+ stm >= 2.2 && < 2.5,+ syb >= 0.1 && < 0.4,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.1.4 && < 0.3,+ vector >= 0.7.1 && < 0.11,+ vector-algorithms >= 0.4 && < 0.6,+ xmlhtml >= 0.1 && < 0.3+ extensions: BangPatterns,
test/suite/Blackbox/App.hs view
@@ -6,11 +6,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Blackbox.App where ++------------------------------------------------------------------------------ import Prelude hiding (lookup) +------------------------------------------------------------------------------ import Control.Applicative+import Control.Lens import Control.Monad.Trans-import Data.Lens.Lazy import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -18,25 +21,59 @@ import Snap.Core import Snap.Util.FileServe +------------------------------------------------------------------------------ import Snap.Snaplet import Snap.Snaplet.Heist import qualified Snap.Snaplet.HeistNoClass as HNC-import Text.Templating.Heist+import Heist.Interpreted +------------------------------------------------------------------------------ import Blackbox.Common import Blackbox.BarSnaplet import Blackbox.FooSnaplet import Blackbox.EmbeddedSnaplet import Blackbox.Types-import Snap.Snaplet.Session hiding (lookup)+import Snap.Snaplet.Session import Snap.Snaplet.Session.Backends.CookieSession + --------------------+ -- THE SNAPLET --+ --------------------+ +------------------------------------------------------------------------------+app :: SnapletInit App App+app = makeSnaplet "app" "Test application" Nothing $ do+ hs <- nestSnaplet "heist" heist $ heistInit "templates"+ fs <- nestSnaplet "foo" foo $ fooInit hs+ bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit hs foo+ sm <- nestSnaplet "session" session $+ initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))+ ns <- embedSnaplet "embed" embedded embeddedInit+ _lens <- getLens+ addSplices+ [("appsplice", textSplice "contents of the app splice")]+ HNC.addSplices heist+ [("appconfig", shConfigSplice _lens)]+ addRoutes [ ("/hello", writeText "hello world")+ , ("/routeWithSplice", routeWithSplice)+ , ("/routeWithConfig", routeWithConfig)+ , ("/public", serveDirectory "public")+ , ("/sessionDemo", sessionDemo)+ , ("/sessionTest", sessionTest)+ ]+ wrapSite (<|> heistServe)+ return $ App hs (over snapletValue fooMod fs) bs sm ns+++------------------------------------------------------------------------------- routeWithSplice :: Handler App App () routeWithSplice = do str <- with foo getFooField writeText $ T.pack $ "routeWithSplice: "++str ++------------------------------------------------------------------------------ routeWithConfig :: Handler App App () routeWithConfig = do cfg <- getSnapletUserConfig@@ -44,20 +81,22 @@ writeText $ "routeWithConfig: " `T.append` fromJust val +------------------------------------------------------------------------------ sessionDemo :: Handler App App () sessionDemo = withSession session $ do with session $ do curVal <- getFromSession "foo" case curVal of- Nothing -> do- setInSession "foo" "bar"+ Nothing -> setInSession "foo" "bar" Just _ -> return () list <- with session $ (T.pack . show) `fmap` sessionToList csrf <- with session $ (T.pack . show) `fmap` csrfToken HNC.renderWithSplices heist "session"- [ ("session", liftHeist $ textSplice list)- , ("csrf", liftHeist $ textSplice csrf) ]+ [ ("session", textSplice list)+ , ("csrf", textSplice csrf) ] ++------------------------------------------------------------------------------ sessionTest :: Handler App App () sessionTest = withSession session $ do q <- getParam "q"@@ -66,33 +105,9 @@ let x' = T.decodeUtf8 x with session $ setInSession "test" x' return x'- Nothing -> maybe "" id `fmap` with session (getFromSession "test")+ Nothing -> fromMaybe "" `fmap` with session (getFromSession "test") writeText val fooMod :: FooSnaplet -> FooSnaplet fooMod f = f { fooField = fooField f ++ "z" }--app :: SnapletInit App App-app = makeSnaplet "app" "Test application" Nothing $ do- hs <- nestSnaplet "heist" heist $ heistInit "templates"- fs <- nestSnaplet "foo" foo fooInit- bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit foo- sm <- nestSnaplet "session" session $- initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))- ns <- embedSnaplet "embed" embedded embeddedInit- addSplices- [("appsplice", liftHeist $ textSplice "contents of the app splice")]- HNC.addSplices heist- [("appconfig", shConfigSplice)]- addRoutes [ ("/hello", writeText "hello world")- , ("/routeWithSplice", routeWithSplice)- , ("/routeWithConfig", routeWithConfig)- , ("/public", serveDirectory "public")- , ("/sessionDemo", sessionDemo)- , ("/sessionTest", sessionTest)- ]- wrapSite (<|> heistServe)- return $ App hs (modL snapletValue fooMod fs) bs sm ns--
test/suite/Blackbox/BarSnaplet.hs view
@@ -7,45 +7,46 @@ import Prelude hiding (lookup) +import Control.Lens import Control.Monad.State import qualified Data.ByteString as B import Data.Configurator-import Data.Lens.Lazy-import Data.Lens.Template import Data.Maybe import Data.Text (Text) import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Core-import Text.Templating.Heist+import Heist.Interpreted import Blackbox.Common import Blackbox.FooSnaplet data BarSnaplet b = BarSnaplet { _barField :: String- , fooLens :: Lens b (Snaplet FooSnaplet)+ , fooLens :: SnapletLens b FooSnaplet } -makeLens ''BarSnaplet+makeLenses ''BarSnaplet -barsplice :: [(Text, SnapletHeist b v Template)]-barsplice = [("barsplice", liftHeist $ textSplice "contents of the bar splice")]+barsplice :: [(Text, SnapletISplice b)]+barsplice = [("barsplice", textSplice "contents of the bar splice")] barInit :: HasHeist b- => Lens b (Snaplet FooSnaplet)+ => Snaplet (Heist b)+ -> SnapletLens b FooSnaplet -> SnapletInit b (BarSnaplet b)-barInit l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do+barInit h l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do config <- getSnapletUserConfig- addTemplates ""+ addTemplates h "" rootUrl <- getSnapletRootURL+ _lens <- getLens addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust) ,("barrooturl", writeBS $ "url" `B.append` rootUrl) ,("bazpage2", renderWithSplices "bazpage" barsplice) ,("bazpage3", heistServeSingle "bazpage") ,("bazpage4", renderAs "text/html" "bazpage") ,("bazpage5", renderWithSplices "bazpage"- [("barsplice", shConfigSplice)])+ [("barsplice", shConfigSplice _lens)]) ,("bazbadpage", heistServeSingle "cpyga") ,("bar/handlerConfig", handlerConfig) ]
test/suite/Blackbox/Common.hs view
@@ -1,10 +1,12 @@ module Blackbox.Common where +import Control.Lens+import Control.Monad.Trans import qualified Data.Text as T import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist-import Text.Templating.Heist+import Heist.Interpreted genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text genericConfigString = do@@ -18,6 +20,6 @@ handlerConfig :: Handler b v () handlerConfig = writeText =<< genericConfigString -shConfigSplice :: SnapletSplice b v-shConfigSplice = liftHeist . textSplice =<< genericConfigString+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b+shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString)
test/suite/Blackbox/EmbeddedSnaplet.hs view
@@ -11,15 +11,14 @@ module Blackbox.EmbeddedSnaplet where import Prelude hiding ((.))+import Control.Lens import Control.Monad.State-import Data.Lens.Lazy-import Data.Lens.Template import qualified Data.Text as T import System.FilePath.Posix import Snap.Snaplet import Snap.Snaplet.Heist-import Text.Templating.Heist+import Heist.Interpreted -- If we universally quantify EmbeddedSnaplet to get rid of the type parameter -- mkLabels throws an error "Can't reify a GADT data constructor"@@ -28,7 +27,7 @@ , _embeddedVal :: Int } -makeLenses [''EmbeddedSnaplet]+makeLenses ''EmbeddedSnaplet instance HasHeist EmbeddedSnaplet where heistLens = subSnaplet embeddedHeist@@ -40,7 +39,7 @@ -- This is the implementation of addTemplates, but we do it here manually -- to test coverage for addTemplatesAt. snapletPath <- getSnapletFilePath- addTemplatesAt "onemoredir" (snapletPath </> "extra-templates")+ addTemplatesAt hs "onemoredir" (snapletPath </> "extra-templates") embeddedLens <- getLens addRoutes [("aoeuhtns", withSplices@@ -50,9 +49,9 @@ return $ EmbeddedSnaplet hs 42 -embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet))- -> SnapletHeist b v Template+embeddedSplice :: (SnapletLens (Snaplet b) EmbeddedSnaplet)+ -> SnapletISplice b embeddedSplice embeddedLens = do- val <- liftWith embeddedLens $ gets _embeddedVal- liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)+ val <- lift $ with' embeddedLens $ gets _embeddedVal+ textSplice $ T.pack $ "splice value" ++ (show val)
test/suite/Blackbox/FooSnaplet.hs view
@@ -11,23 +11,24 @@ import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Core-import Text.Templating.Heist+import Heist.Interpreted import Blackbox.Common data FooSnaplet = FooSnaplet { fooField :: String } -fooInit :: HasHeist b => SnapletInit b FooSnaplet-fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."+fooInit :: HasHeist b => Snaplet (Heist b) -> SnapletInit b FooSnaplet+fooInit h = makeSnaplet "foosnaplet" "A demonstration snaplet called foo." (Just $ return "../foosnaplet") $ do config <- getSnapletUserConfig- addTemplates ""+ addTemplates h "" addSplices- [("foosplice", liftHeist $ textSplice "contents of the foo splice")]+ [("foosplice", textSplice "contents of the foo splice")] rootUrl <- getSnapletRootURL fp <- getSnapletFilePath name <- getSnapletName- addSplices [("fooconfig", shConfigSplice)]+ _lens <- getLens+ addSplices [("fooconfig", shConfigSplice _lens)] addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust) ,("fooRootUrl", writeBS rootUrl) ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)
test/suite/Blackbox/Tests.hs view
@@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import qualified Network.HTTP.Conduit as HTTP import Network.HTTP.Types (Status(..))@@ -25,35 +26,109 @@ import Test.HUnit hiding (Test, path) --------------------------------------------------------------------------------- TODO: fix all the hardcoded ports and strings in here, order the functions--- non-randomly++++ ------------------------------------------------------------------------------+testServer :: String+testServer = "http://127.0.0.1" ------------------------------------------------------------------------------+testPort :: String+testPort = "9753"+++------------------------------------------------------------------------------+-- | The server uri, without the leading slash.+testServerUri :: String+testServerUri = testServer ++ ":" ++ testPort+++------------------------------------------------------------------------------+-- | The server url, with the leading slash.+testServerUrl :: String+testServerUrl = testServerUri ++ "/"+++ --------------------+ -- TEST LOADER --+ --------------------+ +------------------------------------------------------------------------------+tests :: Test+tests = testGroup "non-cabal-tests"+ [ requestTest "hello" "hello world"+ , requestTest "index" "index page\n"+ , requestTest "" "index page\n"+ , requestTest "splicepage" "splice page contents of the app splice\n"+ , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"+ , requestTest "routeWithConfig" "routeWithConfig: topConfigValue"+ , requestTest "foo/foopage" "foo template page\n"+ , requestTest "foo/fooConfig" "fooValue"+ , requestTest "foo/fooRootUrl" "foo"+ , requestTest "barconfig" "barValue"+ , requestTest "bazpage" "baz template page <barsplice></barsplice>\n"+ , requestTest "bazpage2" "baz template page contents of the bar splice\n"+ , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"+ , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"+ , requestTest "barrooturl" "url"+ , requestExpectingError "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."+ , requestTest "foo/fooSnapletName" "foosnaplet"++ , fooConfigPathTest++ -- Test the embedded snaplet+ , requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"+ , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"+ , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"++ -- This set of tests highlights the differences in the behavior of the+ -- get... functions from MonadSnaplet.+ , fooHandlerConfigTest+ , barHandlerConfigTest+ , bazpage5Test+ , bazConfigTest+ , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"+ , reloadTest+ ]+++------------------------------------------------------------------------------ testName :: String -> String testName uri = "internal/" ++ uri + ------------------------------------------------------------------------------ requestTest :: String -> Text -> Test requestTest url desired = testCase (testName url) $ requestTest' url desired -------------------------------------------------------------------------------assertRelativelyTheSame :: FilePath -> FilePath -> IO ()-assertRelativelyTheSame p expected = do- b <- makeRelativeToCurrentDirectory p- assertEqual ("expected " ++ expected) expected b+requestTest' :: String -> Text -> IO ()+requestTest' url desired = do+ actual <- HTTP.simpleHttp $ testServerUrl ++ url+ assertEqual url desired (T.decodeUtf8 actual) -------------------------------------------------------------------------------testServerUri :: String-testServerUri = "http://127.0.0.1:9753"+requestExpectingError :: String -> Int -> Text -> Test+requestExpectingError url status desired =+ testCase (testName url) $ requestExpectingError' url status desired -------------------------------------------------------------------------------grab :: MonadIO m => String -> m L.ByteString-grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path+requestExpectingError' :: String -> Int -> Text -> IO ()+requestExpectingError' url status desired = do+ let fullUrl = testServerUrl ++ url+ req <- HTTP.parseUrl fullUrl+ let req' = req { HTTP.checkStatus = \_ _ -> Nothing }+ resp <- liftIO $ HTTP.withManager $ HTTP.httpLbs req'+ let b = HTTP.responseBody resp+ s = HTTP.responseStatus resp+ assertEqual ("Status code: "++fullUrl) status (statusCode s)+ assertEqual fullUrl desired (T.decodeUtf8 b) ------------------------------------------------------------------------------@@ -64,6 +139,18 @@ ------------------------------------------------------------------------------+assertRelativelyTheSame :: FilePath -> FilePath -> IO ()+assertRelativelyTheSame p expected = do+ b <- makeRelativeToCurrentDirectory p+ assertEqual ("expected " ++ expected) expected b+++------------------------------------------------------------------------------+grab :: MonadIO m => String -> m L.ByteString+grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path+++------------------------------------------------------------------------------ testWithCwd :: String -> (String -> L.ByteString -> Assertion) -> Test@@ -82,7 +169,7 @@ f cwd b where- slashUri = "/" ++ uri+ slashUri = '/' : uri ------------------------------------------------------------------------------@@ -116,7 +203,7 @@ , "/non-cabal-appdir/snaplets/baz\"," , "Just \"baz\",\"An example snaplet called " , "bar.\",\"\")\n" ]- assertEqual "" response b+ assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------@@ -137,7 +224,7 @@ , "called foo.\",\"foo\")\n" ] - assertEqual "" response b+ assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b) ------------------------------------------------------------------------------@@ -145,7 +232,7 @@ expect404 url = action `catch` h where action = do- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url+ HTTP.simpleHttp $ testServerUrl ++ url assertFailure "expected 404" h e@(HTTP.StatusCodeException (Status c _) _)@@ -159,70 +246,6 @@ request404Test url = testCase (testName url) $ expect404 url --------------------------------------------------------------------------------requestTest' :: String -> Text -> IO ()-requestTest' url desired = do- actual <- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url- assertEqual url desired (T.decodeUtf8 actual)----------------------------------------------------------------------------------requestExpectingError :: String -> Int -> Text -> Test-requestExpectingError url status desired =- testCase (testName url) $ requestExpectingError' url status desired----------------------------------------------------------------------------------requestExpectingError' :: String -> Int -> Text -> IO ()-requestExpectingError' url status desired = do- let fullUrl = "http://127.0.0.1:9753/" ++ url- req <- HTTP.parseUrl fullUrl- let req' = req { HTTP.checkStatus = \_ _ -> Nothing }- resp <- liftIO $ HTTP.withManager $ HTTP.httpLbs req'- let b = HTTP.responseBody resp- s = HTTP.responseStatus resp- assertEqual ("Status code: "++fullUrl) status (statusCode s)- assertEqual fullUrl desired (T.decodeUtf8 b)----------------------------------------------------------------------------------tests :: Test-tests = testGroup "non-cabal-tests"- [ requestTest "hello" "hello world"- , requestTest "index" "index page\n"- , requestTest "" "index page\n"- , requestTest "splicepage" "splice page contents of the app splice\n"- , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"- , requestTest "routeWithConfig" "routeWithConfig: topConfigValue"- , requestTest "foo/foopage" "foo template page\n"- , requestTest "foo/fooConfig" "fooValue"- , requestTest "foo/fooRootUrl" "foo"- , requestTest "barconfig" "barValue"- , requestTest "bazpage" "baz template page <barsplice></barsplice>\n"- , requestTest "bazpage2" "baz template page contents of the bar splice\n"- , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"- , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"- , requestTest "barrooturl" "url"- , requestExpectingError "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."- , requestTest "foo/fooSnapletName" "foosnaplet"-- , fooConfigPathTest-- -- Test the embedded snaplet- , requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"- , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"- , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"-- -- This set of tests highlights the differences in the behavior of the- -- get... functions from MonadSnaplet.- , fooHandlerConfigTest- , barHandlerConfigTest- , bazpage5Test- , bazConfigTest- , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"- , reloadTest- ]- remove :: FilePath -> IO () remove f = do exists <- doesFileExist f@@ -259,19 +282,19 @@ testWithCwd' "admin/reload" $ \cwd' b -> do let cwd = S.pack cwd' let response =- L.fromChunks [ "Error reloading site!\n\nInitializer "+ T.concat [ "Error reloading site!\n\nInitializer " , "threw an exception...\n"- , cwd+ , T.pack cwd' , "/non-cabal-appdir/snaplets/heist" , "/templates/bad.tpl \""- , cwd+ , T.pack cwd' , "/non-cabal-appdir/snaplets/heist/templates" , "/bad.tpl\" (line 2, column 1):\nunexpected " , "end of input\nexpecting \"=\", \"/\" or "- , "\">\"\n\n\n...but before it died it generated "+ , "\">\"\n\n...but before it died it generated " , "the following output:\nInitializing app @ /\n" , "Initializing heist @ /heist\n\n" ]- assertEqual "admin/reload" response b+ assertEqual "admin/reload" response (T.decodeUtf8 b) remove badTplNew copyFile goodTplOrig goodTplNew@@ -312,4 +335,5 @@ assertEqual "admin/reload" response b requestTest' "good" "Good template\n"+
test/suite/Blackbox/Types.hs view
@@ -7,7 +7,7 @@ module Blackbox.Types where -import Data.Lens.Template+import Control.Lens import Snap.Snaplet import Snap.Snaplet.Heist@@ -26,7 +26,7 @@ , _embedded :: Snaplet EmbeddedSnaplet } -makeLenses [''App]+makeLenses ''App instance HasHeist App where heistLens = subSnaplet heist
test/suite/NestTest.hs view
@@ -11,9 +11,8 @@ module Main where import Prelude hiding ((.))+import Control.Lens import Control.Monad.State-import Data.Lens.Lazy-import Data.Lens.Template import qualified Data.Text as T import Snap.Http.Server.Config import Snap.Core@@ -21,7 +20,7 @@ import Snap.Snaplet import Snap.Snaplet.Heist-import Text.Templating.Heist+import Heist.Interpreted -- If we universally quantify FooSnaplet to get rid of the type parameter -- mkLabels throws an error "Can't reify a GADT data constructor"@@ -30,7 +29,7 @@ , _fooVal :: Int } -makeLenses [''FooSnaplet]+makeLenses ''FooSnaplet instance HasHeist FooSnaplet where heistLens = subSnaplet fooHeist@@ -38,7 +37,7 @@ fooInit :: SnapletInit FooSnaplet FooSnaplet fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do hs <- nestSnaplet "heist" fooHeist $ heistInit "templates"- addTemplates "foo"+ addTemplates hs "foo" rootUrl <- getSnapletRootURL fooLens <- getLens addRoutes [("fooRootUrl", writeBS rootUrl)@@ -51,11 +50,11 @@ --fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b))) -- -> SnapletSplice (Handler b b)-fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet))- -> SnapletHeist b v Template+fooSplice :: (SnapletLens (Snaplet b) FooSnaplet)+ -> SnapletISplice b fooSplice fooLens = do- val <- liftWith fooLens $ gets _fooVal- liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)+ val <- lift $ with' fooLens $ gets _fooVal+ textSplice $ T.pack $ "splice value" ++ (show val) ------------------------------------------------------------------------------ @@ -63,7 +62,7 @@ { _foo :: Snaplet (FooSnaplet) } -makeLenses [''App]+makeLenses ''App app :: SnapletInit App App app = makeSnaplet "app" "nested snaplet application" Nothing $ do
test/suite/Snap/Snaplet/Internal/LensT/Tests.hs view
@@ -2,11 +2,11 @@ module Snap.Snaplet.Internal.LensT.Tests (tests) where +import Control.Lens import Control.Applicative import Control.Category import Control.Monad.Identity import Control.Monad.State.Strict-import Data.Lens.Template import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit@@ -33,7 +33,9 @@ _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType]+makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType ------------------------------------------------------------------------------@@ -54,10 +56,10 @@ testfmap :: Test testfmap = testCase "lensed/fmap" $ do -- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState- let x = fst $ runIdentity (runLensT (fmap (*2) three) (bot . sub) defaultState)+ let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState) assertEqual "fmap" 6 x - let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)+ let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12 :: Int) y assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'@@ -76,10 +78,10 @@ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do -- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState- let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (bot . sub) defaultState)+ let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState) assertEqual "fmap" 6 x - let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)+ let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState) assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -98,7 +100,7 @@ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do -- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState- let s = snd $ runIdentity (runLensT go (bot0 . bot . sub) defaultState)+ let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState) assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s
test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs view
@@ -5,8 +5,8 @@ import Control.Applicative import Control.Category import Control.Exception+import Control.Lens import Control.Monad.State.Strict-import Data.Lens.Template import Prelude hiding (catch, (.)) import Test.Framework import Test.Framework.Providers.HUnit@@ -33,7 +33,9 @@ _bot0 :: Int } deriving (Show) -makeLenses [''TestType, ''TestSubType, ''TestBotType]+makeLenses ''TestType+makeLenses ''TestSubType+makeLenses ''TestBotType ------------------------------------------------------------------------------@@ -52,10 +54,10 @@ ------------------------------------------------------------------------------ testfmap :: Test testfmap = testCase "lensed/fmap" $ do- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState+ x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState assertEqual "fmap" 6 x - (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState+ (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" 12 y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -73,10 +75,10 @@ ------------------------------------------------------------------------------ testApplicative :: Test testApplicative = testCase "lensed/applicative" $ do- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState+ x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState assertEqual "fmap" 6 x - (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState+ (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState assertEqual "fmap2" (12::Int) y assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'@@ -94,7 +96,7 @@ ------------------------------------------------------------------------------ testMonadState :: Test testMonadState = testCase "lens/MonadState" $ do- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState+ s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s assertEqual "sub0" 3 $ _sub0 $ _sub s
test/suite/Snap/Snaplet/Internal/RST/Tests.hs view
@@ -16,7 +16,7 @@ import Test.Framework.Providers.QuickCheck2 import Test.HUnit hiding (Test, path) -import Snap.Snaplet.Internal.RST+import Snap.Snaplet.Internal.RST tests :: Test
test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -7,10 +7,10 @@ ( tests, initTest ) where ------------------------------------------------------------------------------+import Control.Lens import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString)-import Data.Lens.Template import Data.List import Data.Text import Prelude hiding (catch, (.))@@ -39,7 +39,7 @@ , _bar :: Snaplet Bar } -makeLens ''App+makeLenses ''App --showConfig :: SnapletConfig -> IO () --showConfig c = do
test/suite/TestSuite.hs view
@@ -28,6 +28,7 @@ import qualified Snap.Snaplet.Internal.LensT.Tests import qualified Snap.Snaplet.Internal.RST.Tests import qualified Snap.Snaplet.Internal.Tests+import qualified Snap.Snaplet.Auth.Tests import Snap.TestCommon import SafeCWD@@ -50,6 +51,7 @@ where tests = mutuallyExclusive $ testGroup "snap" [ internalServerTests+ , Snap.Snaplet.Auth.Tests.tests , testDefault , testBarebones , testTutorial