diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -4,3 +4,4 @@ Carl Howells Chris Smith Jurriën Stutterheim +Alfredo Di Napoli diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal --- a/project_template/barebones/foo.cabal +++ b/project_template/barebones/foo.cabal @@ -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 diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal --- a/project_template/default/foo.cabal +++ b/project_template/default/foo.cabal @@ -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 diff --git a/project_template/default/snaplets/heist/templates/base.tpl b/project_template/default/snaplets/heist/templates/base.tpl --- a/project_template/default/snaplets/heist/templates/base.tpl +++ b/project_template/default/snaplets/heist/templates/base.tpl @@ -6,7 +6,7 @@
- +
diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs --- a/project_template/default/src/Application.hs +++ b/project_template/default/src/Application.hs @@ -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 diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs --- a/project_template/default/src/Site.hs +++ b/project_template/default/src/Site.hs @@ -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] ------------------------------------------------------------------------------ diff --git a/project_template/tutorial/foo.cabal b/project_template/tutorial/foo.cabal --- a/project_template/tutorial/foo.cabal +++ b/project_template/tutorial/foo.cabal @@ -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 diff --git a/project_template/tutorial/src/Part2.lhs b/project_template/tutorial/src/Part2.lhs --- a/project_template/tutorial/src/Part2.lhs +++ b/project_template/tutorial/src/Part2.lhs @@ -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 diff --git a/project_template/tutorial/src/Tutorial.lhs b/project_template/tutorial/src/Tutorial.lhs --- a/project_template/tutorial/src/Tutorial.lhs +++ b/project_template/tutorial/src/Tutorial.lhs @@ -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. diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -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 diff --git a/src/Snap.hs b/src/Snap.hs --- a/src/Snap.hs +++ b/src/Snap.hs @@ -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 diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs --- a/src/Snap/Snaplet.hs +++ b/src/Snap/Snaplet.hs @@ -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 --- (). A lens, notated as --- follows: +-- Our solution is to use /lenses/, as defined in Edward Kmett's @lens@ +-- library (). 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. diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -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 + + + diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs --- a/src/Snap/Snaplet/Auth/SpliceHelpers.hs +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -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 @@ -- \ 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. -- -- > Show this when there is a logged in user -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. +-- +-- > Show this when there is a logged in user +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. -- -- > Show this when there is a logged in user -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. +-- +-- > Show this when there is a logged in user +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 + + diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -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" diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs --- a/src/Snap/Snaplet/Heist.hs +++ b/src/Snap/Snaplet/Heist.hs @@ -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. diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs --- a/src/Snap/Snaplet/HeistNoClass.hs +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -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 diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs --- a/src/Snap/Snaplet/Internal/Initializer.hs +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -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 diff --git a/src/Snap/Snaplet/Internal/LensT.hs b/src/Snap/Snaplet/Internal/LensT.hs --- a/src/Snap/Snaplet/Internal/LensT.hs +++ b/src/Snap/Snaplet/Internal/LensT.hs @@ -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) diff --git a/src/Snap/Snaplet/Internal/Lensed.hs b/src/Snap/Snaplet/Internal/Lensed.hs --- a/src/Snap/Snaplet/Internal/Lensed.hs +++ b/src/Snap/Snaplet/Internal/Lensed.hs @@ -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') diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs --- a/src/Snap/Snaplet/Internal/Types.hs +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -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 diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs --- a/src/Snap/Snaplet/Session.hs +++ b/src/Snap/Snaplet/Session.hs @@ -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 diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs --- a/src/Snap/Snaplet/Session/Backends/CookieSession.hs +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -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 +------------------------------------------------------------------------------- ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Session/SessionManager.hs b/src/Snap/Snaplet/Session/SessionManager.hs --- a/src/Snap/Snaplet/Session/SessionManager.hs +++ b/src/Snap/Snaplet/Session/SessionManager.hs @@ -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 diff --git a/src/Snap/Snaplet/Test.hs b/src/Snap/Snaplet/Test.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Test.hs @@ -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 + diff --git a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl --- a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl +++ b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl @@ -3,6 +3,6 @@ Example App - + diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -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 diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -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, diff --git a/test/suite/Blackbox/App.hs b/test/suite/Blackbox/App.hs --- a/test/suite/Blackbox/App.hs +++ b/test/suite/Blackbox/App.hs @@ -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 - - diff --git a/test/suite/Blackbox/BarSnaplet.hs b/test/suite/Blackbox/BarSnaplet.hs --- a/test/suite/Blackbox/BarSnaplet.hs +++ b/test/suite/Blackbox/BarSnaplet.hs @@ -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) ] diff --git a/test/suite/Blackbox/Common.hs b/test/suite/Blackbox/Common.hs --- a/test/suite/Blackbox/Common.hs +++ b/test/suite/Blackbox/Common.hs @@ -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) diff --git a/test/suite/Blackbox/EmbeddedSnaplet.hs b/test/suite/Blackbox/EmbeddedSnaplet.hs --- a/test/suite/Blackbox/EmbeddedSnaplet.hs +++ b/test/suite/Blackbox/EmbeddedSnaplet.hs @@ -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) diff --git a/test/suite/Blackbox/FooSnaplet.hs b/test/suite/Blackbox/FooSnaplet.hs --- a/test/suite/Blackbox/FooSnaplet.hs +++ b/test/suite/Blackbox/FooSnaplet.hs @@ -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) diff --git a/test/suite/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs --- a/test/suite/Blackbox/Tests.hs +++ b/test/suite/Blackbox/Tests.hs @@ -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 \n" + , requestTest "bazpage2" "baz template page contents of the bar splice\n" + , requestTest "bazpage3" "baz template page \n" + , requestTest "bazpage4" "baz template page \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 \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 \n" - , requestTest "bazpage2" "baz template page contents of the bar splice\n" - , requestTest "bazpage3" "baz template page \n" - , requestTest "bazpage4" "baz template page \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 \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" + diff --git a/test/suite/Blackbox/Types.hs b/test/suite/Blackbox/Types.hs --- a/test/suite/Blackbox/Types.hs +++ b/test/suite/Blackbox/Types.hs @@ -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 diff --git a/test/suite/NestTest.hs b/test/suite/NestTest.hs --- a/test/suite/NestTest.hs +++ b/test/suite/NestTest.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -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 diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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