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 && < 0.11, - snap-server >= 0.9 && < 0.11 + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10 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 @@ -14,24 +14,35 @@ Description: Whether to build the server in development (interpreted) mode Default: False +Flag old-base + default: False + manual: False + Executable projname hs-source-dirs: src main-is: Main.hs Build-depends: - base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, heist >= 0.11 && < 0.12, - lens >= 3.7.0.1 && < 3.9, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, snap >= 0.11 && < 0.12, - snap-core >= 0.9 && < 0.11, - snap-server >= 0.9 && < 0.11, + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10, snap-loader-static >= 0.9 && < 0.10, text >= 0.11 && < 0.12, time >= 1.1 && < 1.5, xmlhtml >= 0.1 + + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 if flag(development) build-depends: 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 @@ -10,19 +10,30 @@ Build-type: Simple Cabal-version: >=1.2 +Flag old-base + default: False + manual: False + Executable projname hs-source-dirs: src main-is: Tutorial.lhs Build-depends: - base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, - lens >= 3.7.0.1 && < 3.9, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, snap >= 0.11 && < 0.12, - snap-core >= 0.9 && < 0.11, - snap-server >= 0.9 && < 0.11 + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10 + + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -1,5 +1,5 @@ name: snap -version: 0.11.1 +version: 0.11.2 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries. @@ -98,6 +98,10 @@ test/foosnaplet/templates/foopage.tpl, test/foosnaplet/devel.cfg +Flag old-base + default: False + manual: False + Library hs-source-dirs: src @@ -140,7 +144,6 @@ 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, @@ -148,20 +151,19 @@ configurator >= 0.1 && < 0.3, containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.3, - directory-tree >= 0.10 && < 0.12, + directory-tree >= 0.11 && < 0.12, dlist >= 0.5 && < 0.6, errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, - hashable >= 1.1 && < 1.3, + hashable >= 1.2 && < 1.3, heist >= 0.11 && < 0.12, - lens >= 3.8.5 && < 3.9, logict >= 0.4.2 && < 0.7, 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, + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.4, text >= 0.11 && < 0.12, @@ -171,6 +173,16 @@ vector >= 0.7.1 && < 0.11, vector-algorithms >= 0.4 && < 0.6, xmlhtml >= 0.1 && < 0.3 + + + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 extensions: BangPatterns, diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs --- a/src/Snap/Snaplet.hs +++ b/src/Snap/Snaplet.hs @@ -91,6 +91,7 @@ , addPostInitHook , addPostInitHookBase , printInfo + , getRoutes -- * Routes -- $routes 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 @@ -11,10 +11,10 @@ -} module Snap.Snaplet.Auth.SpliceHelpers - ( - addAuthSplices + ( addAuthSplices , compiledAuthSplices , userCSplices + , userISplices , ifLoggedIn , ifLoggedOut , loggedInUser @@ -61,6 +61,9 @@ ] +------------------------------------------------------------------------------ +-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and +-- loggedInUser. compiledAuthSplices :: SnapletLens b (AuthManager b) -> [(Text, SnapletCSplice b)] compiledAuthSplices auth = @@ -70,21 +73,44 @@ ] +------------------------------------------------------------------------------ +-- | Function to generate interpreted splices from an AuthUser. +userISplices :: Monad m => AuthUser -> [(Text, I.Splice m)] +userISplices AuthUser{..} = + [ ("userId", I.textSplice $ maybe "-" unUid userId) + , ("userLogin", I.textSplice userLogin) + , ("userEmail", I.textSplice $ fromMaybe "-" userEmail) + , ("userActive", I.textSplice $ T.pack $ show $ isNothing userSuspendedAt) + , ("userLoginCount", I.textSplice $ T.pack $ show userLoginCount) + , ("userFailedCount", I.textSplice $ T.pack $ show userFailedLoginCount) + , ("userLoginAt", I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt) + , ("userLastLoginAt", I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt) + , ("userSuspendedAt", I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt) + , ("userLoginIP", I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp) + , ("userLastLoginIP", I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp) + , ("userIfActive", ifISplice (isNothing userSuspendedAt)) + , ("userIfSuspended", ifISplice (isJust userSuspendedAt)) + ] + + +------------------------------------------------------------------------------ +-- | Compiled splices for AuthUser. userCSplices :: Monad m => [(Text, C.Promise AuthUser -> C.Splice m)] userCSplices = (C.pureSplices $ C.textSplices - [ ("login", userLogin) - , ("email", maybe "-" id . userEmail) - , ("active", T.pack . show . isNothing . userSuspendedAt) - , ("loginCount", T.pack . show . userLoginCount) - , ("failedCount", T.pack . show . userFailedLoginCount) - , ("loginAt", maybe "-" (T.pack . show) . userCurrentLoginAt) - , ("lastLoginAt", maybe "-" (T.pack . show) . userLastLoginAt) - , ("suspendedAt", maybe "-" (T.pack . show) . userSuspendedAt) - , ("loginIP", maybe "-" decodeUtf8 . userCurrentLoginIp) - , ("lastLoginIP", maybe "-" decodeUtf8 . userLastLoginIp) + [ ("userId", maybe "-" unUid . userId) + , ("userLogin", userLogin) + , ("userEmail", fromMaybe "-" . userEmail) + , ("userActive", T.pack . show . isNothing . userSuspendedAt) + , ("userLoginCount", T.pack . show . userLoginCount) + , ("userFailedCount", T.pack . show . userFailedLoginCount) + , ("userLoginAt", maybe "-" (T.pack . show) . userCurrentLoginAt) + , ("userLastLoginAt", maybe "-" (T.pack . show) . userLastLoginAt) + , ("userSuspendedAt", maybe "-" (T.pack . show) . userSuspendedAt) + , ("userLoginIP", maybe "-" decodeUtf8 . userCurrentLoginIp) + , ("userLastLoginIP", maybe "-" decodeUtf8 . userLastLoginIp) ]) ++ - [ ("ifActive", ifCSplice (isNothing . userSuspendedAt)) - , ("ifSuspended", ifCSplice (isJust . userSuspendedAt)) + [ ("userIfActive", ifCSplice (isNothing . userSuspendedAt)) + , ("userIfSuspended", ifCSplice (isJust . userSuspendedAt)) ] diff --git a/src/Snap/Snaplet/Config.hs b/src/Snap/Snaplet/Config.hs --- a/src/Snap/Snaplet/Config.hs +++ b/src/Snap/Snaplet/Config.hs @@ -15,7 +15,20 @@ -- | AppConfig contains the config options for command line arguments in -- snaplet-based apps. newtype AppConfig = AppConfig { appEnvironment :: Maybe String } - deriving (Typeable) + + +------------------------------------------------------------------------------ +-- | AppConfig has a manual instance of Typeable due to limitations in the +-- tools available before GHC 7.4, and the need to make dynamic loading +-- tractable. When support for earlier versions of GHC is dropped, the +-- dynamic loader package can be updated so that manual Typeable instances +-- are no longer needed. +appConfigTyCon :: TyCon +appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig" +{-# NOINLINE appConfigTyCon #-} + +instance Typeable AppConfig where + typeOf _ = mkTyConApp appConfigTyCon [] ------------------------------------------------------------------------------ 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 @@ -21,6 +21,7 @@ , serveSnaplet , loadAppConfig , printInfo + , getRoutes ) where import Prelude hiding (catch) @@ -75,6 +76,13 @@ iGets f = Initializer $ do b <- LT.getBase return $ f b + + +------------------------------------------------------------------------------ +-- | Lets you retrieve the list of routes currently set up by an Initializer. +-- This can be useful in debugging. +getRoutes :: Initializer b v [ByteString] +getRoutes = liftM (map fst) $ iGets _handlers ------------------------------------------------------------------------------ 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 @@ -433,3 +433,4 @@ , riAction :: Initializer b b b } + diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -3,6 +3,10 @@ build-type: Simple cabal-version: >= 1.8 +Flag old-base + default: False + manual: False + Executable snap-testsuite hs-source-dirs: ../src suite main-is: TestSuite.hs @@ -22,7 +26,6 @@ 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, @@ -32,18 +35,17 @@ directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, - errors >= 1.3 && < 1.4, + errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, hashable >= 1.1 && < 1.2, heist >= 0.10 && < 0.12, - 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, + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.4, text >= 0.11 && < 0.12, @@ -54,6 +56,16 @@ vector-algorithms >= 0.4 && < 0.6, xmlhtml >= 0.1 && < 0.3 + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 + + extensions: BangPatterns, CPP, @@ -85,7 +97,6 @@ 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, @@ -95,18 +106,17 @@ directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, - errors >= 1.3 && < 1.4, + errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, hashable >= 1.1 && < 1.2, heist >= 0.10 && < 0.12, - 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, + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.4, text >= 0.11 && < 0.12, @@ -117,6 +127,15 @@ vector-algorithms >= 0.4 && < 0.6, xmlhtml >= 0.1 && < 0.3 + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 + extensions: BangPatterns, CPP, @@ -158,7 +177,6 @@ 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, @@ -168,18 +186,17 @@ directory >= 1.0 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, - errors >= 1.3 && < 1.4, + errors >= 1.4 && < 1.5, filepath >= 1.1 && < 1.4, hashable >= 1.1 && < 1.2, heist >= 0.10 && < 0.12, - 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, + snap-core >= 0.9 && < 0.10, + snap-server >= 0.9 && < 0.10, stm >= 2.2 && < 2.5, syb >= 0.1 && < 0.4, text >= 0.11 && < 0.12, @@ -189,6 +206,15 @@ vector >= 0.7.1 && < 0.11, vector-algorithms >= 0.4 && < 0.6, xmlhtml >= 0.1 && < 0.3 + + if flag(old-base) + build-depends: + base >= 4 && < 4.4, + lens >= 3.7.6 && < 3.8 + else + build-depends: + base >= 4.4 && < 5, + lens >= 3.7.6 && < 3.9 extensions: