diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ Snap Framework [![Hackage Status](https://img.shields.io/hackage/v/snap.svg)](https://hackage.haskell.org/package/snap) ============== -[![Build Status](https://travis-ci.org/snapframework/snap.svg?branch=master)](https://travis-ci.org/snapframework/snap) +[![GitHub CI](https://github.com/snapframework/snap/workflows/CI/badge.svg)](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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 + + + +## 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) diff --git a/runTestsAndCoverage.sh b/runTestsAndCoverage.sh --- a/runTestsAndCoverage.sh +++ b/runTestsAndCoverage.sh @@ -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 < 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" 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,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) 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 @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Heist/Internal.hs b/src/Snap/Snaplet/Heist/Internal.hs --- a/src/Snap/Snaplet/Heist/Internal.hs +++ b/src/Snap/Snaplet/Heist/Internal.hs @@ -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 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 @@ -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. 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 @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Internal/RST.hs b/src/Snap/Snaplet/Internal/RST.hs --- a/src/Snap/Snaplet/Internal/RST.hs +++ b/src/Snap/Snaplet/Internal/RST.hs @@ -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 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 @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Test.hs b/src/Snap/Snaplet/Test.hs --- a/src/Snap/Snaplet/Test.hs +++ b/src/Snap/Snaplet/Test.hs @@ -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) 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 @@ -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 diff --git a/test/suite/Snap/Snaplet/Config/Tests.hs b/test/suite/Snap/Snaplet/Config/Tests.hs --- a/test/suite/Snap/Snaplet/Config/Tests.hs +++ b/test/suite/Snap/Snaplet/Config/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Test/Tests.hs b/test/suite/Snap/Snaplet/Test/Tests.hs --- a/test/suite/Snap/Snaplet/Test/Tests.hs +++ b/test/suite/Snap/Snaplet/Test/Tests.hs @@ -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