snap 1.0.0.2 → 1.1.3.3
raw patch · 18 files changed
Files
- README.md +1/−1
- changelog.md +34/−0
- runTestsAndCoverage.sh +27/−24
- snap.cabal +76/−75
- src/Snap/Snaplet/Auth.hs +1/−1
- src/Snap/Snaplet/Auth/AuthManager.hs +2/−1
- src/Snap/Snaplet/Auth/Backends/JsonFile.hs +39/−1
- src/Snap/Snaplet/Auth/Handlers.hs +1/−0
- src/Snap/Snaplet/Config.hs +15/−5
- src/Snap/Snaplet/Heist/Internal.hs +1/−0
- src/Snap/Snaplet/Internal/Initializer.hs +2/−2
- src/Snap/Snaplet/Internal/Lensed.hs +6/−0
- src/Snap/Snaplet/Internal/RST.hs +6/−4
- src/Snap/Snaplet/Internal/Types.hs +18/−7
- src/Snap/Snaplet/Test.hs +1/−1
- test/suite/Blackbox/Tests.hs +28/−30
- test/suite/Snap/Snaplet/Config/Tests.hs +11/−1
- test/suite/Snap/Snaplet/Test/Tests.hs +4/−8
README.md view
@@ -1,7 +1,7 @@ Snap Framework [](https://hackage.haskell.org/package/snap) ============== -[](https://travis-ci.org/snapframework/snap)+[](https://github.com/snapframework/snap/actions) Snap is a simple and fast web development framework and server written in Haskell. For more information about Snap, read the `README.SNAP.md` or visit
+ changelog.md view
@@ -0,0 +1,34 @@+## 1.1.3.3++ - Update for GHC 9.8+ - Support aeson 2.2++## 1.1.3.2++ - Update for GHC 9.0 through 9.6.2++## 1.1.3.1++ - Update for GHC 8.10++<!-- n.b. where did the rest of the change log entries go?? -->++## 1.1.1.0++### Added++ - GHC 8.4 support++## 1.1.0.0++### Added++ - Support for aeson 1.x+ - GHC 8.2 support+ - New [lookupByEmail](src/Snap/Snaplet/Auth/AuthManager.hs#L62) function in the auth snaplet++## 1.0.0.0+### Removed++ - Removed support for `iteratees` in favor of + [io-streams](https://hackage.haskell.org/package/io-streams)
runTestsAndCoverage.sh view
@@ -2,30 +2,31 @@ set -e -# All directory variables relative to project root-DIR=dist-newstyle/hpc--SUITE=./dist-newstyle/build/snap-1.0.0.0/build/testsuite/testsuite--if [ -z "$DEBUG" ]; then- export DEBUG=snap-testsuite-fi--rm -f testsuite.tix-rm -rf "$DIR"-mkdir -p "$DIR"--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal install --enable-tests --only-dependencies- cabal configure --enable-tests- cabal build-EOF- exit;-fi--$SUITE $*+# # All directory variables relative to project root+# DIR=dist-newstyle/hpc+# +# SUITE=./dist-newstyle/build/x86_64-osx/ghc-8.2.2/snap-1.1.1.0/t/testsuite/build/testsuite/testsuite+# +# if [ -z "$DEBUG" ]; then+# export DEBUG=snap-testsuite+# fi+# +# rm -f testsuite.tix+# rm -rf "$DIR"+# mkdir -p "$DIR"+# +# if [ ! -f $SUITE ]; then+# cat <<EOF+# Testsuite executable not found, please run:+# cabal install --enable-tests --only-dependencies+# cabal configure --enable-tests+# cabal new-build --enable-tests+# EOF+# exit;+# fi+# +# # cabal new-run testsuite+# $SUITE $* EXCLUDES='Main Snap@@ -68,6 +69,8 @@ rm -f test/snaplets/heist/templates/bad.tpl rm -f test/snaplets/heist/templates/good.tpl rm -fr test/non-cabal-appdir/snaplets/foosnaplet # TODO++cp ./dist-newstyle/build/x86_64-osx/ghc-8.2.2/snap-1.1.1.0/hpc/vanilla/tix/testsuite/testsuite.tix . # TODO - actually send results to /dev/null when hpc kinks are fully removed hpc markup $EXCL --destdir=$DIR testsuite # >/dev/null 2>&1
snap.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.2 name: snap-version: 1.0.0.2+version: 1.1.3.3 synopsis: Top-level package for the Snap Web Framework description: This is the top-level package for the official Snap Framework libraries.@@ -23,25 +24,31 @@ Note: since version 1.0, the \"snap\" executable program for generating starter projects is provided by the @snap-templates@ package. -license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple-cabal-version: >= 1.8.0.4 homepage: http://snapframework.com/ bug-reports: https://github.com/snapframework/snap/issues category: Web, Snap-Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3,- GHC == 8.0.1, GHC == 8.2.1 +tested-with:+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.8+ GHC == 9.4.5+ GHC == 9.6.2+ extra-source-files:- .ghci+ .ghci, CONTRIBUTORS, LICENSE, README.md, README.SNAP.md,+ changelog.md, design.md, extra/hscolour.css, extra/haddock.css,@@ -52,9 +59,9 @@ test/db.cfg, test/devel.cfg, test/good.tpl,- test/snaplets/baz/devel.cfg- test/snaplets/baz/templates/bazconfig.tpl- test/snaplets/baz/templates/bazpage.tpl+ test/snaplets/baz/devel.cfg,+ test/snaplets/baz/templates/bazconfig.tpl,+ test/snaplets/baz/templates/bazpage.tpl, test/snaplets/embedded/extra-templates/extra.tpl, test/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, test/snaplets/foosnaplet/devel.cfg,@@ -68,11 +75,43 @@ test/snaplets/heist/templates/splicepage.tpl, test/snaplets/heist/templates/userpage.tpl +common universal+ default-language: Haskell2010++ build-depends:+ , base >= 4.5 && < 5++ if !impl(ghc >= 8.0)+ build-depends:+ , semigroups >= 0.16 && < 0.19+ , fail >= 4.9 && < 4.10++ default-extensions:+ BangPatterns+ CPP+ DeriveDataTypeable+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ NoMonomorphismRestriction+ OverloadedStrings+ PackageImports+ Rank2Types+ RecordWildCards+ ScopedTypeVariables+ TemplateHaskell+ TypeFamilies+ TypeOperators+ TypeSynonymInstances+ Library+ import: universal hs-source-dirs: src exposed-modules:- Snap,+ Snap Snap.Snaplet Snap.Snaplet.Heist Snap.Snaplet.HeistNoClass@@ -103,60 +142,40 @@ Snap.Snaplet.Session.SecureCookie build-depends:- aeson >= 0.6 && < 1.2,- attoparsec >= 0.10 && < 0.14,- base >= 4 && < 4.11,- bytestring >= 0.9.1 && < 0.11,+ aeson >= 0.6 && < 2.3,+ attoparsec >= 0.10 && < 0.15,+ attoparsec-aeson >= 2.1.0.0 && < 3.0,+ bytestring >= 0.9.1 && < 0.13, cereal >= 0.3 && < 0.6, clientsession >= 0.8 && < 0.10, configurator >= 0.1 && < 0.4,- containers >= 0.2 && < 0.6,+ containers >= 0.2 && < 0.8, directory >= 1.1 && < 1.4,- directory-tree >= 0.10 && < 0.13,- dlist >= 0.5 && < 0.9,+ directory-tree >= 0.11 && < 0.13,+ dlist >= 0.5 && < 1.1, filepath >= 1.3 && < 1.5, -- hashable is broken from 1.2.0.0 through 1.2.0.5 -- snap does work with hashable 1.1.*, but some have complained that -- the version disjunction causes problems with dependency resolution.- hashable >= 1.2.0.6 && < 1.3,- heist >= 1.0 && < 1.1,- lens >= 3.7.6 && < 4.16,+ hashable >= 1.2.0.6 && < 1.5,+ heist >= 1.1 && < 1.2,+ lens >= 3.7.6 && < 5.3, lifted-base >= 0.2 && < 0.3,- map-syntax >= 0.2 && < 0.3,+ map-syntax >= 0.2 && < 0.4, monad-control >= 0.3 && < 1.1,- mtl >= 2.0 && < 2.3,- mwc-random >= 0.8 && < 0.14,+ mtl >= 2.0 && < 2.4,+ mwc-random >= 0.8 && < 0.16, pwstore-fast >= 2.2 && < 2.5, snap-core >= 1.0 && < 1.1,- snap-server >= 1.0 && < 1.1,- stm >= 2.2 && < 2.5,- text >= 0.11 && < 1.3,- time >= 1.1 && < 1.7,- transformers >= 0.2 && < 0.6,+ snap-server >= 1.0 && < 1.2,+ stm >= 2.2 && < 2.6,+ text >= 1.1.1.0 && < 2.2,+ time >= 1.1 && < 1.14,+ transformers >= 0.2 && < 0.7, transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, xmlhtml >= 0.1 && < 0.3 - extensions:- BangPatterns,- CPP,- DeriveDataTypeable,- ExistentialQuantification,- FlexibleContexts,- FlexibleInstances,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- NoMonomorphismRestriction,- OverloadedStrings,- PackageImports,- Rank2Types,- RecordWildCards,- ScopedTypeVariables,- TemplateHaskell,- TypeFamilies,- TypeOperators,- TypeSynonymInstances- if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind@@ -165,15 +184,19 @@ -fno-warn-orphans Test-suite testsuite+ import: universal hs-source-dirs: src test/suite type: exitcode-stdio-1.0 main-is: TestSuite.hs + autogen-modules:+ Paths_snap+ other-modules: Blackbox.Tests Paths_snap SafeCWD- Snap,+ Snap Snap.Snaplet Snap.Snaplet.Auth Snap.Snaplet.Auth.AuthManager@@ -220,9 +243,9 @@ build-depends: aeson,- async >= 2.0.1.5 && < 2.2,+ async >= 2.0.1.5 && < 2.3, attoparsec,- base,+ attoparsec-aeson, bytestring, cereal, clientsession,@@ -233,7 +256,6 @@ directory-tree, dlist, filepath,- Glob >= 0.7.5 && < 0.9, hashable, heist, http-streams >= 0.7.1.1 && < 0.9,@@ -245,8 +267,8 @@ mtl, mwc-random, pwstore-fast,- QuickCheck >= 2.4.2 && < 2.10,- smallcheck >= 1.1.1 && < 1.2,+ QuickCheck >= 2.4.2 && < 2.15,+ smallcheck >= 1.1.1 && < 1.3, snap-core, snap-server, snap,@@ -262,27 +284,6 @@ transformers-base, unordered-containers, xmlhtml-- extensions:- BangPatterns,- CPP,- DeriveDataTypeable,- ExistentialQuantification,- FlexibleContexts,- FlexibleInstances,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- NoMonomorphismRestriction,- OverloadedStrings,- PackageImports,- Rank2Types,- RecordWildCards,- ScopedTypeVariables,- TemplateHaskell,- TypeFamilies,- TypeOperators,- TypeSynonymInstances- source-repository head type: git
src/Snap/Snaplet/Auth.hs view
@@ -46,7 +46,7 @@ , Role(..) -- * Other Utilities- , authSettingsFromConfig + , authSettingsFromConfig , withBackend , encryptPassword , checkPassword
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -59,6 +59,7 @@ save :: r -> AuthUser -> IO (Either AuthFailure AuthUser) lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) lookupByLogin :: r -> Text -> IO (Maybe AuthUser)+ lookupByEmail :: r -> Text -> IO (Maybe AuthUser) lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) destroy :: r -> AuthUser -> IO () @@ -101,6 +102,6 @@ save AuthManager{..} u = save backend u lookupByUserId AuthManager{..} u = lookupByUserId backend u lookupByLogin AuthManager{..} u = lookupByLogin backend u+ lookupByEmail AuthManager{..} u = lookupByEmail backend u lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u destroy AuthManager{..} u = destroy backend u-
src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -10,15 +10,19 @@ ) where +import Control.Applicative ((<|>))+import Control.Monad (join) import Control.Monad.State import Control.Concurrent.STM import Data.Aeson+import Data.Aeson.Parser (json) import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import qualified Data.Map as HM import Data.Map (Map)-import Data.Maybe (fromJust, isJust)+import Data.Maybe (fromJust, isJust, listToMaybe)+import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Time@@ -104,6 +108,10 @@ ------------------------------------------------------------------------------+type EmailUserCache = Map Text UserId+++------------------------------------------------------------------------------ type RemTokenUserCache = Map Text UserId @@ -113,6 +121,7 @@ data UserCache = UserCache { uidCache :: UserIdCache -- ^ the actual datastore , loginCache :: LoginUserCache -- ^ fast lookup for login field+ , emailCache :: EmailUserCache -- ^ fast lookup for email field , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens , uidCounter :: Int -- ^ user id counter }@@ -123,6 +132,7 @@ defUserCache = UserCache { uidCache = HM.empty , loginCache = HM.empty+ , emailCache = HM.empty , tokenCache = HM.empty , uidCounter = 0 }@@ -198,6 +208,8 @@ return $! cache { uidCache = HM.insert uid' u' $ uidCache cache , loginCache = HM.insert (userLogin u') uid' $ loginCache cache+ , emailCache = maybe id (\em -> HM.insert em uid') (userEmail u) $+ emailCache cache , tokenCache = case userRememberToken u' of Nothing -> tokenCache cache Just x -> HM.insert x uid' $ tokenCache cache@@ -216,9 +228,11 @@ Nothing -> return $! Left UserNotFound Just x -> do let oldLogin = userLogin x+ let oldEmail = userEmail x let oldToken = userRememberToken x let uid = fromJust $ userId u let newLogin = userLogin u+ let newEmail = userEmail u let newToken = userRememberToken u let lc = if oldLogin /= userLogin u@@ -227,6 +241,16 @@ loginCache cache else loginCache cache + let ec = if oldEmail /= newEmail+ then (case (oldEmail, newEmail) of+ (Nothing, Nothing) -> id+ (Just e, Nothing) -> HM.delete e+ (Nothing, Just e ) -> HM.insert e uid+ (Just e, Just e') -> HM.insert e' uid .+ HM.delete e+ ) (emailCache cache)+ else emailCache cache+ let tc = if oldToken /= newToken && isJust oldToken then HM.delete (fromJust oldToken) $ loginCache cache else tokenCache cache@@ -240,6 +264,7 @@ let new = cache { uidCache = HM.insert uid u' $ uidCache cache , loginCache = lc+ , emailCache = ec , tokenCache = tc' } @@ -273,6 +298,16 @@ f cache = getUid >>= getUser cache where getUid = HM.lookup login (loginCache cache) + lookupByEmail mgr email = withCache mgr f+ where+ f cache = getEmail >>= getUser cache+ where getEmail = case HM.lookup email (emailCache cache) of+ Just u -> return u+ Nothing -> (join . fmap userId .+ listToMaybe . HM.elems $+ HM.filter ((== Just email) . userEmail)+ (uidCache cache))+ lookupByRememberToken mgr token = withCache mgr f where f cache = getUid >>= getUser cache@@ -306,6 +341,7 @@ toJSON uc = object [ "uidCache" .= uidCache uc , "loginCache" .= loginCache uc+ , "emailCache" .= emailCache uc , "tokenCache" .= tokenCache uc , "uidCounter" .= uidCounter uc ]@@ -317,6 +353,8 @@ UserCache <$> v .: "uidCache" <*> v .: "loginCache"+ <*> (v .: "emailCache" <|> pure mempty) -- Old versions of users.json do+ -- not carry this field <*> v .: "tokenCache" <*> v .: "uidCounter" parseJSON _ = error "Unexpected JSON input"
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -11,6 +11,7 @@ ------------------------------------------------------------------------------ import Control.Applicative+import Control.Monad (join, liftM, liftM2) import Control.Monad.State import Control.Monad.Trans.Maybe import Data.ByteString (ByteString)
src/Snap/Snaplet/Config.hs view
@@ -22,6 +22,10 @@ import Data.Monoid (Monoid, mappend, mempty) #endif +#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+ import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg)) ------------------------------------------------------------------------------ import Snap.Core@@ -51,14 +55,20 @@ typeOf _ = mkTyConApp appConfigTyCon [] #endif --------------------------------------------------------------------------------instance Monoid AppConfig where- mempty = AppConfig Nothing- mappend a b = AppConfig+instance Semigroup AppConfig where+ a <> b = AppConfig { appEnvironment = ov appEnvironment a b } where- ov f x y = getLast $! (mappend `on` (Last . f)) x y+ ov f x y = getLast $! ((<>) `on` (Last . f)) x y+++------------------------------------------------------------------------------+instance Monoid AppConfig where+ mempty = AppConfig Nothing+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif ------------------------------------------------------------------------------
src/Snap/Snaplet/Heist/Internal.hs view
@@ -3,6 +3,7 @@ import Prelude import Control.Lens+import Control.Monad (liftM) import Control.Monad.State import qualified Data.ByteString as B import Data.Char
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -111,7 +111,7 @@ ------------------------------------------------------------------------------ -- | Return the current environment string. This will be the -- environment given to 'runSnaplet' or from the command line when--- using 'serveSnaplet'. Usefully for changing behavior during+-- using 'serveSnaplet'. Useful for changing behavior during -- development and testing. getEnvironment :: Initializer b v String getEnvironment = iGets _environment@@ -517,7 +517,7 @@ --------------------------------------------------------------------------------- | Lets you change a snaplet's initial state. It's alomst like a reload,+-- | Lets you change a snaplet's initial state. It's almost like a reload, -- except that it doesn't run the initializer. It just modifies the result of -- the initializer. This can be used to let you define actions for reloading -- individual snaplets.
src/Snap/Snaplet/Internal/Lensed.hs view
@@ -14,6 +14,7 @@ import Control.Lens (ALens', cloneLens, storing, (^#)) import Control.Monad (MonadPlus (..), liftM) import Control.Monad.Base (MonadBase (..))+import qualified Control.Monad.Fail as Fail import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Class (MonadState (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..))@@ -44,6 +45,11 @@ Lensed mf <*> Lensed ma = Lensed $ \l v s -> do (f, v', s') <- mf l v s (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s'+++------------------------------------------------------------------------------+instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where+ fail s = Lensed $ \_ _ _ -> Fail.fail s ------------------------------------------------------------------------------
src/Snap/Snaplet/Internal/RST.hs view
@@ -8,9 +8,9 @@ import Control.Applicative (Alternative (..), Applicative (..))-import Control.Category ((.))-import Control.Monad (MonadPlus (..), ap)+import Control.Monad import Control.Monad.Base (MonadBase (..))+import qualified Control.Monad.Fail as Fail import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Class (MonadState (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..))@@ -18,8 +18,6 @@ MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM)-import Prelude (Functor (..), Monad (..), seq,- ($)) import Snap.Core (MonadSnap (..)) @@ -93,8 +91,12 @@ instance (Monad m) => Monad (RST r s m) where return a = RST $ \_ s -> return (a, s) (>>=) = rwsBind+#if !MIN_VERSION_base(4,13,0) fail msg = RST $ \_ _ -> fail msg+#endif +instance Fail.MonadFail m => Fail.MonadFail (RST r s m) where+ fail msg = RST $ \_ _ -> Fail.fail msg instance (MonadPlus m) => MonadPlus (RST r s m) where mzero = RST $ \_ _ -> mzero
src/Snap/Snaplet/Internal/Types.hs view
@@ -18,9 +18,10 @@ ------------------------------------------------------------------------------ import Control.Applicative (Alternative) import Control.Lens (ALens', makeLenses, set)-import Control.Monad (liftM)+import Control.Monad (MonadPlus, liftM) import Control.Monad.Base (MonadBase (..))-import Control.Monad.Reader (MonadIO (..), MonadPlus, MonadReader (ask, local))+import Control.Monad.Fail (MonadFail)+import Control.Monad.Reader (MonadIO (..), MonadReader (ask, local)) import Control.Monad.State.Class (MonadState (get, put), gets) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Writer (WriterT)@@ -38,6 +39,10 @@ import Data.Monoid (Monoid (mappend, mempty)) #endif +#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+ ------------------------------------------------------------------------------ @@ -273,6 +278,7 @@ deriving ( Monad , Functor , Applicative+ , MonadFail , MonadIO , MonadPlus , Alternative@@ -467,11 +473,8 @@ -- initialization. newtype Hook a = Hook (Snaplet a -> IO (Either Text (Snaplet a))) ---------------------------------------------------------------------------------instance Monoid (Hook a) where- mempty = Hook (return . Right)- (Hook a) `mappend` (Hook b) = Hook $ \s -> do+instance Semigroup (Hook a) where+ Hook a <> Hook b = Hook $ \s -> do ea <- a s case ea of Left e -> return $ Left e@@ -480,6 +483,14 @@ case eb of Left e -> return $ Left e Right bres -> return $ Right bres+++------------------------------------------------------------------------------+instance Monoid (Hook a) where+ mempty = Hook (return . Right)+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif ------------------------------------------------------------------------------
src/Snap/Snaplet/Test.hs view
@@ -38,7 +38,7 @@ --------------------------------------------------------------------------------- | Remove the given file before running an IO computation. Obviously it+-- | Remove the given file after running an IO computation. Obviously it -- can be used with 'Assertion'. withTemporaryFile :: FilePath -> IO () -> IO () withTemporaryFile f = finally (removeFileMayNotExist f)
test/suite/Blackbox/Tests.hs view
@@ -272,38 +272,36 @@ flip finally (remove badTplNew) $ testWithCwd' "admin/reload" $ \cwd' b -> do- let cwd = S.pack cwd'- let response =- [T.concat [ "Error reloading site!\n\nInitializer "- , "threw an exception...\n"- , T.pack cwd'- , "/snaplets/heist"- , "/templates/bad.tpl \""- , T.pack cwd'- , "/snaplets/heist/templates"- , "/bad.tpl\" (line 2, column 1):\nunexpected "- , "end of input\nexpecting \"=\", \"/\" or "- , "\">\"\n\n...but before it died it generated "- , "the following output:\nInitializing app @ /\n"- , "Initializing heist @ /heist\n\n" ]+ let cwd = T.pack cwd' - ,T.concat [ "Error reloading site!\n\nInitializer "- , "threw an exception...\n"- , T.pack cwd'- , "/snaplets/heist"- , "/templates/bad.tpl \""- , T.pack cwd'- , "/snaplets/heist/templates"- , "/bad.tpl\" (line 2, column 1):\nunexpected "- , "end of input\nexpecting \"=\", \"/\" or "- , "\">\"\n"- , "CallStack (from HasCallStack):\n error, called at src/Snap/Snaplet/Heist/Internal.hs:74:35 in main:Snap.Snaplet.Heist.Internal\n"- , "\n...but before it died it generated "- , "the following output:\nInitializing app @ /\n"- , "Initializing heist @ /heist\n\n" ]- ]+ let prefix = T.intercalate "\n"+ [ "Error reloading site!"+ , ""+ , "Initializer threw an exception..."+ , T.concat+ [ cwd, "/snaplets/heist/templates/bad.tpl \""+ , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"+ ]+ , "unexpected end of input"+ , "expecting \"=\", \"/\" or \">\"" - assertBool "admin/reload" $ (T.decodeUtf8 b) `elem` response + -- Building with the latest dependency versions produces the following:+ -- "CallStack (from HasCallStack):"+ -- " error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"+ ]++ let suffix = T.intercalate "\n"+ [ "...but before it died it generated the following output:"+ , "Initializing app @ /"+ , "Initializing heist @ /heist"+ , ""+ , ""+ ]++ let response = T.decodeUtf8 b++ assertEqual "admin/reload" prefix (T.take (T.length prefix) response)+ assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response) copyFile goodTplOrig goodTplNew
test/suite/Snap/Snaplet/Config/Tests.hs view
@@ -8,7 +8,12 @@ import qualified Data.Configurator.Types as C import Data.Function import qualified Data.Map as Map+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+import Data.Monoid hiding ((<>))+#else import Data.Monoid+#endif import Data.Typeable import System.Environment ------------------------------------------------------------------------------@@ -50,9 +55,14 @@ instance Arbitrary ArbAppConfig where arbitrary = liftM (ArbAppConfig . AppConfig) arbitrary +instance Semigroup ArbAppConfig where+ a <> b = ArbAppConfig $ ((<>) `on` unArbAppConfig) a b+ instance Monoid ArbAppConfig where mempty = ArbAppConfig mempty- a `mappend` b = ArbAppConfig $ ((<>) `on` unArbAppConfig) a b+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif monoidLeftIdentity :: ArbAppConfig -> Bool monoidLeftIdentity a = mempty <> a == a
test/suite/Snap/Snaplet/Test/Tests.hs view
@@ -12,14 +12,10 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit hiding (Test, path) -------------------------------------------------------------------------------import Snap.Core (readRequestBody,- writeLBS, writeText)-import qualified Snap.Test as ST-import Snap.Snaplet.Test (closeSnaplet,- getSnaplet,- evalHandler, evalHandler',- runHandler, runHandler')+import Snap.Core (readRequestBody, writeLBS, writeText)+import Snap.Snaplet.Test (closeSnaplet, evalHandler, evalHandler', getSnaplet, runHandler, runHandler') import Snap.Snaplet.Test.Common.App (appInit, failingAppInit)+import qualified Snap.Test as ST ------------------------------------------------------------------------------ tests :: Test@@ -121,7 +117,7 @@ assertReadRqBody = do let hdl = readRequestBody 5000 >>= writeLBS res <- race- (threadDelay 1000000)+ (threadDelay 100000000) (runHandler Nothing (ST.get "" Map.empty) hdl appInit) either (assertFailure . ("readRequestBody timeout" ++) . show) (either (assertFailure . show) ST.assertSuccess) res