Compare commits

..

No commits in common. "master" and "serversession-1.0.1" have entirely different histories.

42 changed files with 224 additions and 517 deletions

3
.gitignore vendored
View File

@ -12,6 +12,3 @@ cabal.sandbox.config
.shelly/ .shelly/
tarballs/ tarballs/
\#*# \#*#
.stack-work
*.sqlite3*
*.db

View File

@ -1,57 +1,64 @@
# Travis file upgraded to stack at 2015-31-12 using template from
# <http://docs.haskellstack.org/en/stable/travis_ci.html>.
#
# Travis file initially created at 2015-05-31 using template from # Travis file initially created at 2015-05-31 using template from
# <https://github.com/hvr/multi-ghc-travis/commit/c9c87d36c450d7f9cb3183dcaf1f77b60f916f28> # <https://github.com/hvr/multi-ghc-travis/commit/c9c87d36c450d7f9cb3183dcaf1f77b60f916f28>
# and taking the idea of using cabal-meta from yesodweb/yesod. # and taking the idea of using cabal-meta from yesodweb/yesod.
sudo: false # NB: don't set `language: haskell` here
dist: trusty
language: c
services: services:
- redis-server - redis-server
addons: addons:
apt: postgresql: "9.3"
packages:
- libgmp-dev
postgresql: "9.3"
cache: # The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.
directories: env:
- $HOME/.stack #- CABALVER=1.16 GHCVER=6.12.3
- .stack-work #- CABALVER=1.16 GHCVER=7.0.1
#- CABALVER=1.16 GHCVER=7.0.2
matrix: #- CABALVER=1.16 GHCVER=7.0.3
include: #- CABALVER=1.16 GHCVER=7.0.4
- env: STACKARGS="--resolver=lts-15" #- CABALVER=1.16 GHCVER=7.2.1
- env: STACKARGS="--resolver=nightly" #- CABALVER=1.16 GHCVER=7.2.2
allow_failures: #- CABALVER=1.16 GHCVER=7.4.1
- env: STACKARGS="--resolver=nightly" #- CABALVER=1.16 GHCVER=7.4.2
#- CABALVER=1.16 GHCVER=7.6.1
#- CABALVER=1.16 GHCVER=7.6.2
#- CABALVER=1.18 GHCVER=7.6.3
#- CABALVER=1.18 GHCVER=7.8.1 # see note about Alex/Happy for GHC >= 7.8
#- CABALVER=1.18 GHCVER=7.8.2
#- CABALVER=1.18 GHCVER=7.8.3
#- CABALVER=1.18 GHCVER=7.8.4
- CABALVER=1.20 GHCVER=7.8.4
- CABALVER=1.22 GHCVER=7.10.1
#- CABALVER=1.22 GHCVER=7.10.2
#- CABALVER=head GHCVER=head # see section about GHC HEAD snapshots
# Note: the distinction between `before_install` and `install` is not important.
before_install: before_install:
# Download and unpack the stack executable - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
- mkdir -p ~/.local/bin - travis_retry sudo apt-get update
- export PATH=$HOME/.local/bin:$PATH - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex
- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
before_script:
- psql -c "CREATE USER test WITH PASSWORD 'test';" -U postgres
- psql -c "CREATE DATABASE test;" -U postgres
- psql -c "GRANT ALL PRIVILEGES ON DATABASE test TO test;" -U postgres
install: install:
- stack setup $STACKARGS - cabal --version
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- travis_retry cabal update
- cabal install cabal-src cabal-meta alex happy
before_script:
- psql -c "CREATE USER test WITH PASSWORD 'test';" -U postgres
- psql -c "CREATE DATABASE test;" -U postgres
- psql -c "GRANT ALL PRIVILEGES ON DATABASE test TO test;" -U postgres
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
script: script:
- stack test --fast $STACKARGS serversession - cabal-meta install --enable-tests --enable-benchmarks --force-reinstalls
- stack test --fast $STACKARGS serversession-backend-acid-state - serversession/dist/build/tests/tests
- du -hcs serversession-backend-acid-state/state; rm -Rfv serversession-backend-acid-state/state - serversession-backend-acid-state/dist/build/tests/tests
- stack test --fast $STACKARGS serversession-backend-persistent --test-arguments='"--skip=100 MiB"' - du -hcs state; rm -Rfv state
- du -hcs serversession-backend-persistent/test.db*; rm -Rfv serversession-backend-persistent/test.db* - serversession-backend-persistent/dist/build/tests/tests --skip=100\ MiB
- psql -c 'SELECT COUNT(*) FROM "persistent_session";' -U test test; psql -c 'DROP DATABASE test;' -U postgres - du -hcs test.db*; rm -Rfv test.db*
- stack test --fast $STACKARGS serversession-backend-redis - psql -c 'SELECT COUNT(*) FROM "persistent_session";' -U test test; psql -c 'DROP DATABASE test;' -U postgres
- redis-cli FLUSHALL - serversession-backend-redis/dist/build/tests/tests
- stack test --fast $STACKARGS --no-run-tests # Make sure everything else builds - redis-cli FLUSHALL
- stack $STACKARGS sdist

View File

@ -1,5 +1,3 @@
-- https://ghc.haskell.org/trac/ghc/ticket/12130#comment:9
{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
( getApplicationDev ( getApplicationDev
@ -69,7 +67,7 @@ makeFoundation appSettings = do
-- logging function. To get out of this loop, we initially create a -- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function -- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation. -- from there, and then create the real foundation.
let mkFoundation appConnPool = App appSettings appStatic appConnPool appHttpManager appLogger let mkFoundation appConnPool = App {..}
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
logFunc = messageLoggerSource tempFoundation appLogger logFunc = messageLoggerSource tempFoundation appLogger
@ -128,7 +126,7 @@ getApplicationDev = do
return (wsettings, app) return (wsettings, app)
getAppSettings :: IO AppSettings getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv getAppSettings = loadAppSettings [configSettingsYml] [] useEnv
-- | main function for use by yesod devel -- | main function for use by yesod devel
develMain :: IO () develMain :: IO ()
@ -138,7 +136,7 @@ develMain = develMainHelper getApplicationDev
appMain :: IO () appMain :: IO ()
appMain = do appMain = do
-- Get the settings from all relevant sources -- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs settings <- loadAppSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime -- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue] [configSettingsYmlValue]

View File

@ -6,7 +6,7 @@ import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import Web.ServerSession.Backend.Persistent import Web.ServerSession.Backend.Persistent
import Web.ServerSession.Frontend.Yesod import Web.ServerSession.Frontend.Yesod
import Yesod.Auth.Dummy (authDummy) import Yesod.Auth.BrowserId (authBrowserId)
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
@ -37,7 +37,7 @@ instance HasHttpManager App where
mkYesodData "App" $(parseRoutesFile "config/routes") mkYesodData "App" $(parseRoutesFile "config/routes")
-- | A convenient synonym for creating forms. -- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
-- | Cookie name used for the sessions of this example app. -- | Cookie name used for the sessions of this example app.
sessionCookieName :: Text sessionCookieName :: Text
@ -104,7 +104,7 @@ instance Yesod App where
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLogIO app _source level = return $ shouldLog app _source level =
appShouldLogAll (appSettings app) appShouldLogAll (appSettings app)
|| level == LevelWarn || level == LevelWarn
|| level == LevelError || level == LevelError
@ -117,7 +117,6 @@ instance YesodPersist App where
runDB action = do runDB action = do
master <- getYesod master <- getYesod
runSqlPool action $ appConnPool master runSqlPool action $ appConnPool master
instance YesodPersistRunner App where instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner appConnPool getDBRunner = defaultGetDBRunner appConnPool
@ -131,19 +130,19 @@ instance YesodAuth App where
-- Override the above two destinations when a Referer: header is present -- Override the above two destinations when a Referer: header is present
redirectToReferer _ = True redirectToReferer _ = True
authenticate creds = liftHandler $ runDB $ do getAuthId creds = runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds x <- getBy $ UniqueUser $ credsIdent creds
case x of case x of
Just (Entity uid _) -> return $ Authenticated uid Just (Entity uid _) -> return $ Just uid
Nothing -> Authenticated <$> insert User Nothing -> Just <$> insert User
{ userIdent = credsIdent creds { userIdent = credsIdent creds
, userPassword = Nothing , userPassword = Nothing
} }
-- You can add other plugins like BrowserID, email or OAuth here -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authDummy] authPlugins _ = [authBrowserId def]
authHttpManager = getHttpManager <$> getYesod authHttpManager = getHttpManager
instance YesodAuthPersist App instance YesodAuthPersist App
@ -152,7 +151,7 @@ instance YesodAuthPersist App
instance RenderMessage App FormMessage where instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage renderMessage _ _ = defaultFormMessage
unsafeHandler :: App -> Foundation.Handler a -> IO a unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been -- Note: Some functionality previously present in the scaffolding has been

View File

@ -1,5 +1,3 @@
-- https://ghc.haskell.org/trac/ghc/ticket/12130#comment:9
{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-}
-- | On this serversession example, we simply provide some ways -- | On this serversession example, we simply provide some ways
-- users may interact with the session. -- users may interact with the session.
module Handler.Home where module Handler.Home where
@ -26,12 +24,12 @@ getHomeR = do
-- | Invalidate the session as requested via 'forceForm'. -- | Invalidate the session as requested via 'forceForm'.
postForceR :: Handler () postForceR :: Handler ()
postForceR = postForceR =
processForm "Force form" forceForm $ \frce -> do processForm "Force form" forceForm $ \force -> do
msid <- getSessionId msid <- getSessionId
SS.forceInvalidate frce SS.forceInvalidate force
return $ concat return $ concat
[ "Forced session invalidation using " [ "Forced session invalidation using "
, show frce , show force
, " [old session ID was " , " [old session ID was "
, show msid , show msid
, "]." ] , "]." ]

View File

@ -1,12 +1,5 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation module Import.NoFoundation
( module Import ( module Import
#if !MIN_VERSION_yaml(0,8,16)
, loadYamlSettings
#endif
#if !MIN_VERSION_yaml(0,8,17)
, loadYamlSettingsArgs
#endif
) where ) where
import ClassyPrelude.Yesod as Import import ClassyPrelude.Yesod as Import
@ -16,13 +9,3 @@ import Settings.StaticFiles as Import
import Yesod.Auth as Import import Yesod.Auth as Import
import Yesod.Core.Types as Import (loggerSet) import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import import Yesod.Default.Config2 as Import
#if !MIN_VERSION_yaml(0,8,16)
loadYamlSettings :: FromJSON settings => [String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings = loadAppSettings
#endif
#if !MIN_VERSION_yaml(0,8,17)
loadYamlSettingsArgs :: FromJSON settings => [Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs = loadAppSettingsArgs
#endif

View File

@ -1,20 +0,0 @@
Copyright (c) 2015 Felipe Lessa
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

View File

@ -1,6 +1,3 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Model where module Model where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod

View File

@ -6,7 +6,7 @@
module Settings where module Settings where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Control.Exception as E import Control.Exception (throw)
import Data.Aeson (Result (..), fromJSON, withObject, (.!=), import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
(.:?)) (.:?))
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
@ -108,7 +108,7 @@ configSettingsYmlBS = $(embedFile configSettingsYml)
-- | @config/settings.yml@, parsed to a @Value@. -- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value configSettingsYmlValue :: Value
configSettingsYmlValue = either E.throw id $ decodeEither' configSettingsYmlBS configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS
-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
compileTimeAppSettings :: AppSettings compileTimeAppSettings :: AppSettings

View File

@ -1,7 +0,0 @@
#!/usr/bin/env runhaskell
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMain

View File

@ -1,8 +1,5 @@
name: serversession-example-yesod-persistent name: serversession-example-yesod-persistent
version: 0.0.0 version: 0.0.0
license: MIT
license-file: LICENSE
description: Example yesod/persistent app using serversession
cabal-version: >= 1.8 cabal-version: >= 1.8
build-type: Simple build-type: Simple
@ -28,9 +25,9 @@ library
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT
ghc-options: -Wall -fwarn-tabs ghc-options: -Wall -fwarn-tabs -O0
else else
ghc-options: -Wall -fwarn-tabs ghc-options: -Wall -fwarn-tabs -O
extensions: TemplateHaskell extensions: TemplateHaskell
QuasiQuotes QuasiQuotes
@ -49,35 +46,35 @@ library
TupleSections TupleSections
RecordWildCards RecordWildCards
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 1.4.1 , yesod >= 1.4.1 && < 1.5
, yesod-core >= 1.4.6 , yesod-core >= 1.4.6 && < 1.5
, yesod-auth >= 1.4.0 , yesod-auth >= 1.4.0 && < 1.5
, yesod-static >= 1.4.0.3 , yesod-static >= 1.4.0.3 && < 1.5
, yesod-form >= 1.4.0 , yesod-form >= 1.4.0 && < 1.5
, classy-prelude >= 0.10.2 , classy-prelude >= 0.10.2
, classy-prelude-conduit >= 0.10.2 , classy-prelude-conduit >= 0.10.2
, classy-prelude-yesod >= 0.10.2 , classy-prelude-yesod >= 0.10.2
, bytestring >= 0.9 , bytestring >= 0.9 && < 0.11
, text >= 0.11 , text >= 0.11 && < 2.0
, persistent >= 2.0 , persistent >= 2.0 && < 2.2
, persistent-sqlite >= 2.1.1 , persistent-sqlite >= 2.1.1 && < 2.2
, persistent-template >= 2.0 , persistent-template >= 2.0 && < 2.2
, template-haskell , template-haskell
, shakespeare >= 2.0 , shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 , hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 , monad-control >= 0.3 && < 1.1
, wai-extra >= 3.0 , wai-extra >= 3.0 && < 3.1
, yaml >= 0.8 , yaml >= 0.8 && < 0.9
, http-conduit >= 2.1 , http-conduit >= 2.1 && < 2.2
, directory >= 1.1 , directory >= 1.1 && < 1.3
, warp >= 3.0 , warp >= 3.0 && < 3.1
, data-default , data-default
, aeson >= 0.6 , aeson >= 0.6 && < 0.9
, conduit >= 1.0 , conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 , monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.2 , fast-logger >= 2.2 && < 2.4
, wai-logger >= 2.2 , wai-logger >= 2.2 && < 2.3
, file-embed , file-embed
, safe , safe
, unordered-containers , unordered-containers
@ -98,17 +95,13 @@ executable serversession-example-yesod-persistent
hs-source-dirs: app hs-source-dirs: app
build-depends: base, serversession-example-yesod-persistent build-depends: base, serversession-example-yesod-persistent
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -O -rtsopts -with-rtsopts=-N
test-suite test test-suite test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Spec.hs main-is: Spec.hs
hs-source-dirs: test hs-source-dirs: test
ghc-options: -Wall ghc-options: -Wall
other-modules:
Handler.CommonSpec
Handler.HomeSpec
TestImport
extensions: TemplateHaskell extensions: TemplateHaskell
QuasiQuotes QuasiQuotes
@ -128,7 +121,7 @@ test-suite test
build-depends: base build-depends: base
, serversession-example-yesod-persistent , serversession-example-yesod-persistent
, yesod-test >= 1.4.3 , yesod-test >= 1.4.3 && < 1.5
, yesod-core , yesod-core
, yesod , yesod
, persistent , persistent

View File

@ -3,15 +3,15 @@ module Handler.CommonSpec (spec) where
import TestImport import TestImport
spec :: Spec spec :: Spec
spec = yesodSpecWithSiteGenerator mkApp $ do spec = withApp $ do
ydescribe "robots.txt" $ do describe "robots.txt" $ do
yit "gives a 200" $ do it "gives a 200" $ do
get RobotsR get RobotsR
statusIs 200 statusIs 200
yit "has correct User-agent" $ do it "has correct User-agent" $ do
get RobotsR get RobotsR
bodyContains "User-agent: *" bodyContains "User-agent: *"
ydescribe "favicon.ico" $ do describe "favicon.ico" $ do
yit "gives a 200" $ do it "gives a 200" $ do
get FaviconR get FaviconR
statusIs 200 statusIs 200

View File

@ -3,9 +3,7 @@ module Handler.HomeSpec (spec) where
import TestImport import TestImport
spec :: Spec spec :: Spec
spec = yesodSpecWithSiteGenerator mkApp $ do spec = withApp $ do
return ()
{-
it "loads the index and checks it looks right" $ do it "loads the index and checks it looks right" $ do
get HomeR get HomeR
statusIs 200 statusIs 200
@ -32,4 +30,3 @@ spec = yesodSpecWithSiteGenerator mkApp $ do
statusIs 200 statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) [] users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ length users assertEqual "user table empty" 0 $ length users
-}

View File

@ -5,13 +5,13 @@ module TestImport
import Application (makeFoundation) import Application (makeFoundation)
import ClassyPrelude as X import ClassyPrelude as X
import Database.Persist as X hiding (delete, deleteBy, get) import Database.Persist as X hiding (get)
import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
import Foundation as X hiding (Handler) import Foundation as X
import Import.NoFoundation (loadYamlSettings)
import Model as X import Model as X
import Test.Hspec as X import Test.Hspec as X
import Yesod.Default.Config2 (ignoreEnv) import Text.Shakespeare.Text (st)
import Yesod.Default.Config2 (ignoreEnv, loadAppSettings)
import Yesod.Test as X import Yesod.Test as X
-- Wiping the database -- Wiping the database
@ -26,9 +26,9 @@ runDB query = do
pool <- fmap appConnPool getTestYesod pool <- fmap appConnPool getTestYesod
liftIO $ runSqlPersistMPool query pool liftIO $ runSqlPersistMPool query pool
mkApp :: IO App withApp :: SpecWith App -> Spec
mkApp = do withApp = before $ do
settings <- loadYamlSettings settings <- loadAppSettings
["config/test-settings.yml", "config/settings.yml"] ["config/test-settings.yml", "config/settings.yml"]
[] []
ignoreEnv ignoreEnv
@ -49,8 +49,8 @@ wipeDB app = do
-- Aside: SQLite by default *does not enable foreign key checks* -- Aside: SQLite by default *does not enable foreign key checks*
-- (disabling foreign keys is only necessary for those who specifically enable them). -- (disabling foreign keys is only necessary for those who specifically enable them).
let settings = appSettings app let settings = appSettings app
sqliteConn <- rawConnection (sqlDatabase $ appDatabaseConf settings) sqliteConn <- rawConnection (sqlDatabase $ appDatabaseConf settings)
disableForeignKeys sqliteConn disableForeignKeys sqliteConn
let logFunc = messageLoggerSource app (appLogger app) let logFunc = messageLoggerSource app (appLogger app)

View File

@ -1,3 +0,0 @@
# 1.0.4
* bump acid-state to 0.16

View File

@ -1,39 +1,33 @@
cabal-version: >= 1.10
name: serversession-backend-acid-state name: serversession-backend-acid-state
version: 1.0.4 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Storage backend for serversession using acid-state. synopsis: Storage backend for serversession using acid-state.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-acid-state> description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-acid-state>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
, acid-state >= 0.16 , acid-state == 0.12.*
, containers , containers
, mtl , mtl
, safecopy >= 0.8 , safecopy == 0.8.*
, unordered-containers , unordered-containers
, serversession == 1.0.* , serversession == 1.0.*
exposed-modules: exposed-modules:
Web.ServerSession.Backend.Acid Web.ServerSession.Backend.Acid
Web.ServerSession.Backend.Acid.Internal Web.ServerSession.Backend.Acid.Internal
default-extensions: extensions:
ConstraintKinds ConstraintKinds
DeriveDataTypeable DeriveDataTypeable
FlexibleContexts FlexibleContexts
@ -41,14 +35,9 @@ library
TypeFamilies TypeFamilies
UndecidableInstances UndecidableInstances
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
if impl(ghc >= 8.0.0)
ghc-options: -Wno-redundant-constraints
test-suite tests test-suite tests
default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: tests hs-source-dirs: tests
build-depends: build-depends:
@ -59,11 +48,9 @@ test-suite tests
, serversession , serversession
, serversession-backend-acid-state , serversession-backend-acid-state
main-is: Main.hs main-is: Main.hs
default-extensions: extensions:
CPP CPP
ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head

View File

@ -1,4 +1,3 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Internal module exposing the guts of the package. Use at -- | Internal module exposing the guts of the package. Use at
-- your own risk. No API stability guarantees apply. -- your own risk. No API stability guarantees apply.
module Web.ServerSession.Backend.Acid.Internal module Web.ServerSession.Backend.Acid.Internal
@ -24,9 +23,9 @@ module Web.ServerSession.Backend.Acid.Internal
, AcidStorage(..) , AcidStorage(..)
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>), (<*>))
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.State (get, modify, put) import Control.Monad.State (get, modify', put)
import Data.Acid import Data.Acid
import Data.Acid.Advanced import Data.Acid.Advanced
import Data.SafeCopy import Data.SafeCopy
@ -104,19 +103,19 @@ insertSessionForAuthId sid = maybe id (flip (HM.insertWith S.union) (S.singleton
-- @safeCopy@ doesn't contain instances for @HashMap@ as of now. -- @safeCopy@ doesn't contain instances for @HashMap@ as of now.
instance SafeCopy SS.SessionMap where instance SafeCopy SS.SessionMap where
putCopy = contain . safePut . HM.toList . SS.unSessionMap putCopy = contain . safePut . HM.toList . SS.unSessionMap
getCopy = contain $ SS.SessionMap . HM.fromList A.<$> safeGet getCopy = contain $ SS.SessionMap . HM.fromList <$> safeGet
-- | We can't @deriveSafeCopy 0 'base ''SS.SessionId@ as -- | We can't @deriveSafeCopy 0 'base ''SS.SessionId@ as
-- otherwise we'd require an unneeded @SafeCopy sess@. -- otherwise we'd require an unneeded @SafeCopy sess@.
instance Typeable sess => SafeCopy (SS.SessionId sess) where instance SafeCopy (SS.SessionId sess) where
putCopy = contain . safePut . SSI.unS putCopy = contain . safePut . SSI.unS
getCopy = contain $ SSI.S <$> safeGet getCopy = contain $ SSI.S <$> safeGet
-- | We can't @deriveSafeCopy 0 'base ''SS.Session@ due to the -- | We can't @deriveSafeCopy 0 'base ''SS.Session@ due to the
-- required context. -- required context.
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (SS.Session sess) where instance SafeCopy (SS.Decomposed sess) => SafeCopy (SS.Session sess) where
putCopy (SS.Session key authId data_ createdAt accessedAt) = contain $ do putCopy (SS.Session key authId data_ createdAt accessedAt) = contain $ do
put_t <- getSafePut put_t <- getSafePut
safePut key safePut key
@ -136,7 +135,7 @@ instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (SS.Session
-- | We can't @deriveSafeCopy 0 'base ''ServerSessionAcidState@ due -- | We can't @deriveSafeCopy 0 'base ''ServerSessionAcidState@ due
-- to the required context. -- to the required context.
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (ServerSessionAcidState sess) where instance SafeCopy (SS.Decomposed sess) => SafeCopy (ServerSessionAcidState sess) where
putCopy (ServerSessionAcidState sits aits) = contain $ do putCopy (ServerSessionAcidState sits aits) = contain $ do
safePut (HM.toList sits) safePut (HM.toList sits)
safePut (HM.toList aits) safePut (HM.toList aits)
@ -163,7 +162,7 @@ deleteSession
=> SS.SessionId sess => SS.SessionId sess
-> Update (ServerSessionAcidState sess) () -> Update (ServerSessionAcidState sess) ()
deleteSession sid = deleteSession sid =
modify $ \state -> modify' $ \state ->
let oldSession = HM.lookup sid (sessionIdToSession state) let oldSession = HM.lookup sid (sessionIdToSession state)
newSessionIdToSession = HM.delete sid (sessionIdToSession state) newSessionIdToSession = HM.delete sid (sessionIdToSession state)
newAuthIdToSessionId = removeSessionFromAuthId sid mauthId $ authIdToSessionId state newAuthIdToSessionId = removeSessionFromAuthId sid mauthId $ authIdToSessionId state
@ -177,7 +176,7 @@ deleteAllSessionsOfAuthId
=> SS.AuthId => SS.AuthId
-> Update (ServerSessionAcidState sess) () -> Update (ServerSessionAcidState sess) ()
deleteAllSessionsOfAuthId authId = deleteAllSessionsOfAuthId authId =
modify $ \state -> modify' $ \state ->
let sessionIds = HM.lookup authId (authIdToSessionId state) let sessionIds = HM.lookup authId (authIdToSessionId state)
newAuthIdToSessionId = HM.delete authId (authIdToSessionId state) newAuthIdToSessionId = HM.delete authId (authIdToSessionId state)
newSessionIdToSession = maybe id removeSession sessionIds $ sessionIdToSession state newSessionIdToSession = maybe id removeSession sessionIds $ sessionIdToSession state
@ -197,7 +196,7 @@ insertSession session = do
Just old -> throwAS $ SS.SessionAlreadyExists old session Just old -> throwAS $ SS.SessionAlreadyExists old session
insertAuth = insertSessionForAuthId sid (SS.sessionAuthId session) insertAuth = insertSessionForAuthId sid (SS.sessionAuthId session)
sid = SS.sessionKey session sid = SS.sessionKey session
modify $ \state -> modify' $ \state ->
ServerSessionAcidState ServerSessionAcidState
(insertSess $ sessionIdToSession state) (insertSess $ sessionIdToSession state)
(insertAuth $ authIdToSessionId state) (insertAuth $ authIdToSessionId state)
@ -273,23 +272,23 @@ data DeleteAllSessionsOfAuthId sess = DeleteAllSessionsOfAuthId SS.AuthId derivi
data InsertSession sess = InsertSession (SS.Session sess) deriving (Typeable) data InsertSession sess = InsertSession (SS.Session sess) deriving (Typeable)
data ReplaceSession sess = ReplaceSession (SS.Session sess) deriving (Typeable) data ReplaceSession sess = ReplaceSession (SS.Session sess) deriving (Typeable)
instance Typeable sess => SafeCopy (GetSession sess) where instance SafeCopy (GetSession sess) where
putCopy (GetSession v) = contain $ safePut v putCopy (GetSession v) = contain $ safePut v
getCopy = contain $ GetSession <$> safeGet getCopy = contain $ GetSession <$> safeGet
instance Typeable sess => SafeCopy (DeleteSession sess) where instance SafeCopy (DeleteSession sess) where
putCopy (DeleteSession v) = contain $ safePut v putCopy (DeleteSession v) = contain $ safePut v
getCopy = contain $ DeleteSession <$> safeGet getCopy = contain $ DeleteSession <$> safeGet
instance Typeable sess => SafeCopy (DeleteAllSessionsOfAuthId sess) where instance SafeCopy (DeleteAllSessionsOfAuthId sess) where
putCopy (DeleteAllSessionsOfAuthId v) = contain $ safePut v putCopy (DeleteAllSessionsOfAuthId v) = contain $ safePut v
getCopy = contain $ DeleteAllSessionsOfAuthId <$> safeGet getCopy = contain $ DeleteAllSessionsOfAuthId <$> safeGet
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (InsertSession sess) where instance SafeCopy (SS.Decomposed sess) => SafeCopy (InsertSession sess) where
putCopy (InsertSession v) = contain $ safePut v putCopy (InsertSession v) = contain $ safePut v
getCopy = contain $ InsertSession <$> safeGet getCopy = contain $ InsertSession <$> safeGet
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (ReplaceSession sess) where instance SafeCopy (SS.Decomposed sess) => SafeCopy (ReplaceSession sess) where
putCopy (ReplaceSession v) = contain $ safePut v putCopy (ReplaceSession v) = contain $ safePut v
getCopy = contain $ ReplaceSession <$> safeGet getCopy = contain $ ReplaceSession <$> safeGet
@ -322,8 +321,8 @@ instance AcidContext sess => Method (ReplaceSession sess) where
instance AcidContext sess => IsAcidic (ServerSessionAcidState sess) where instance AcidContext sess => IsAcidic (ServerSessionAcidState sess) where
acidEvents = acidEvents =
[ QueryEvent (\(GetSession sid) -> getSession sid) safeCopyMethodSerialiser [ QueryEvent $ \(GetSession sid) -> getSession sid
, UpdateEvent (\(DeleteSession sid) -> deleteSession sid) safeCopyMethodSerialiser , UpdateEvent $ \(DeleteSession sid) -> deleteSession sid
, UpdateEvent (\(DeleteAllSessionsOfAuthId authId) -> deleteAllSessionsOfAuthId authId) safeCopyMethodSerialiser , UpdateEvent $ \(DeleteAllSessionsOfAuthId authId) -> deleteAllSessionsOfAuthId authId
, UpdateEvent (\(InsertSession session) -> insertSession session) safeCopyMethodSerialiser , UpdateEvent $ \(InsertSession session) -> insertSession session
, UpdateEvent (\(ReplaceSession session) -> replaceSession session) safeCopyMethodSerialiser ] , UpdateEvent $ \(ReplaceSession session) -> replaceSession session ]

View File

@ -1,6 +1,6 @@
module Main (main) where module Main (main) where
import Control.Applicative as A import Control.Applicative ((<$>))
import Data.Acid.Local (openLocalState, createCheckpointAndClose) import Data.Acid.Local (openLocalState, createCheckpointAndClose)
import Data.Acid.Memory (openMemoryState) import Data.Acid.Memory (openMemoryState)
import Test.Hspec import Test.Hspec
@ -15,7 +15,7 @@ main =
(AcidStorage <$> openLocalState emptyState) (AcidStorage <$> openLocalState emptyState)
(createCheckpointAndClose . acidState) $ (createCheckpointAndClose . acidState) $
\acidLocal -> hspec $ do \acidLocal -> hspec $ do
acidMem <- runIO $ AcidStorage A.<$> openMemoryState emptyState acidMem <- runIO $ AcidStorage <$> openMemoryState emptyState
describe "AcidStorage on memory only" $ describe "AcidStorage on memory only" $
allStorageTests acidMem it runIO parallel shouldBe shouldReturn shouldThrow allStorageTests acidMem it runIO parallel shouldBe shouldReturn shouldThrow
describe "AcidStorage on local storage" $ describe "AcidStorage on local storage" $

View File

@ -1,7 +0,0 @@
1.0.5
* bump persistent to 2.10
1.0.4
* Default auth id to NULL to fix a MySQL bug.
1.0.3
* Get building on ghc-8
* Limit column size for session key

View File

@ -1,25 +1,19 @@
cabal-version: >= 1.10
name: serversession-backend-persistent name: serversession-backend-persistent
version: 1.0.5 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Storage backend for serversession using persistent and an RDBMS. synopsis: Storage backend for serversession using persistent and an RDBMS.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-persistent> description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-persistent>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
@ -28,8 +22,8 @@ library
, bytestring , bytestring
, cereal >= 0.4 , cereal >= 0.4
, path-pieces , path-pieces
, persistent >= 2.10 , persistent == 2.1.*
, tagged >= 0.7 , tagged >= 0.8
, text , text
, time , time
, transformers , transformers
@ -40,7 +34,7 @@ library
Web.ServerSession.Backend.Persistent Web.ServerSession.Backend.Persistent
Web.ServerSession.Backend.Persistent.Internal.Impl Web.ServerSession.Backend.Persistent.Internal.Impl
Web.ServerSession.Backend.Persistent.Internal.Types Web.ServerSession.Backend.Persistent.Internal.Types
default-extensions: extensions:
DeriveDataTypeable DeriveDataTypeable
EmptyDataDecls EmptyDataDecls
FlexibleContexts FlexibleContexts
@ -57,13 +51,9 @@ library
TypeFamilies TypeFamilies
UndecidableInstances UndecidableInstances
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
test-suite tests test-suite tests
default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: tests hs-source-dirs: tests
build-depends: build-depends:
@ -74,21 +64,18 @@ test-suite tests
, hspec >= 2.1 && < 3 , hspec >= 2.1 && < 3
, monad-logger , monad-logger
, persistent-sqlite >= 2.1 , persistent-sqlite == 2.1.*
, persistent-postgresql >= 2.1 , persistent-postgresql == 2.1.*
, resource-pool , resource-pool
, QuickCheck , QuickCheck
, serversession , serversession
, serversession-backend-persistent , serversession-backend-persistent
default-extensions: extensions:
OverloadedStrings OverloadedStrings
TemplateHaskell TemplateHaskell
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M2G -c" -rtsopts ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head

View File

@ -12,10 +12,10 @@ module Web.ServerSession.Backend.Persistent.Internal.Impl
, throwSS , throwSS
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>), (<*>))
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Monoid as M import Data.Monoid (mempty)
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy(..))
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -94,9 +94,8 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
[] []
[] []
["Eq", "Ord", "Show", "Typeable"] ["Eq", "Ord", "Show", "Typeable"]
M.mempty mempty
False False
Nothing
where where
pfd :: P.EntityField (PersistentSession sess) typ -> P.FieldDef pfd :: P.EntityField (PersistentSession sess) typ -> P.FieldDef
pfd = P.persistFieldDef pfd = P.persistFieldDef
@ -110,7 +109,7 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
fromPersistValues [a, b, c, d, e] = fromPersistValues [a, b, c, d, e] =
PersistentSession PersistentSession
A.<$> err "key" (P.fromPersistValue a) <$> err "key" (P.fromPersistValue a)
<*> err "authId" (P.fromPersistValue b) <*> err "authId" (P.fromPersistValue b)
<*> err "session" (P.fromPersistValue c) <*> err "session" (P.fromPersistValue c)
<*> err "createdAt" (P.fromPersistValue d) <*> err "createdAt" (P.fromPersistValue d)
@ -143,30 +142,26 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
(P.SqlOther "SqlType unset for key") (P.SqlOther "SqlType unset for key")
[] []
True True
P.NoReference P.NoReference]
Nothing]
[])) []))
Nothing
persistFieldDef PersistentSessionKey persistFieldDef PersistentSessionKey
= P.FieldDef = P.FieldDef
(P.HaskellName "key") (P.HaskellName "key")
(P.DBName "key") (P.DBName "key")
(P.FTTypeCon Nothing "SessionId sess") (P.FTTypeCon Nothing "SessionId sess")
(P.sqlType (Proxy :: Proxy (SessionId sess))) (P.sqlType (Proxy :: Proxy (SessionId sess)))
["maxlen=30"] []
True True
P.NoReference P.NoReference
Nothing
persistFieldDef PersistentSessionAuthId persistFieldDef PersistentSessionAuthId
= P.FieldDef = P.FieldDef
(P.HaskellName "authId") (P.HaskellName "authId")
(P.DBName "auth_id") (P.DBName "auth_id")
(P.FTTypeCon Nothing "ByteStringJ") (P.FTTypeCon Nothing "ByteStringJ")
(P.sqlType (Proxy :: Proxy ByteStringJ)) (P.sqlType (Proxy :: Proxy ByteStringJ))
["Maybe", "default=NULL"] ["Maybe"]
True True
P.NoReference P.NoReference
Nothing
persistFieldDef PersistentSessionSession persistFieldDef PersistentSessionSession
= P.FieldDef = P.FieldDef
(P.HaskellName "session") (P.HaskellName "session")
@ -176,7 +171,6 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
[] []
True True
P.NoReference P.NoReference
Nothing
persistFieldDef PersistentSessionCreatedAt persistFieldDef PersistentSessionCreatedAt
= P.FieldDef = P.FieldDef
(P.HaskellName "createdAt") (P.HaskellName "createdAt")
@ -186,7 +180,6 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
[] []
True True
P.NoReference P.NoReference
Nothing
persistFieldDef PersistentSessionAccessedAt persistFieldDef PersistentSessionAccessedAt
= P.FieldDef = P.FieldDef
(P.HaskellName "accessedAt") (P.HaskellName "accessedAt")
@ -196,7 +189,6 @@ instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (Pe
[] []
True True
P.NoReference P.NoReference
Nothing
persistIdField = PersistentSessionId persistIdField = PersistentSessionId

View File

@ -12,7 +12,7 @@ module Web.ServerSession.Backend.Persistent.Internal.Types
-- $orphanSessionMap -- $orphanSessionMap
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>))
import Control.Arrow (first) import Control.Arrow (first)
import Control.Monad ((>=>), mzero) import Control.Monad ((>=>), mzero)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -103,7 +103,7 @@ instance PersistFieldSql SessionMap where
instance S.Serialize SessionMap where instance S.Serialize SessionMap where
put = S.put . map (first TE.encodeUtf8) . HM.toList . unSessionMap put = S.put . map (first TE.encodeUtf8) . HM.toList . unSessionMap
get = SessionMap . HM.fromList . map (first TE.decodeUtf8) A.<$> S.get get = SessionMap . HM.fromList . map (first TE.decodeUtf8) <$> S.get
instance A.FromJSON SessionMap where instance A.FromJSON SessionMap where
parseJSON = fmap fixup . A.parseJSON parseJSON = fmap fixup . A.parseJSON

View File

@ -1,7 +0,0 @@
1.0.4
* bump hedis to 0.13
1.0.3
* Allow hedis-0.10
1.0.2
* Get building on GHC 8
* Auto-expire expired keys in redis to avoid storage bloat over time.

View File

@ -1,51 +1,36 @@
cabal-version: >= 1.10
name: serversession-backend-redis name: serversession-backend-redis
version: 1.0.4 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Storage backend for serversession using Redis. synopsis: Storage backend for serversession using Redis.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-redis> description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-redis>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag old-locale
description: Use time-1.4 and old-locale (GHC 7.8).
default: False
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
, bytestring , bytestring
, hedis < 0.13 , hedis == 0.6.*
, path-pieces , path-pieces
, tagged >= 0.7 , tagged >= 0.8
, text , text
, time >= 1.4 , time >= 1.5
, transformers , transformers
, unordered-containers , unordered-containers
, serversession == 1.0.* , serversession == 1.0.*
if flag(old-locale)
build-depends: time == 1.4.*, old-locale
else
build-depends: time >= 1.5
exposed-modules: exposed-modules:
Web.ServerSession.Backend.Redis Web.ServerSession.Backend.Redis
Web.ServerSession.Backend.Redis.Internal Web.ServerSession.Backend.Redis.Internal
default-extensions: extensions:
CPP
DeriveDataTypeable DeriveDataTypeable
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
@ -53,15 +38,9 @@ library
ScopedTypeVariables ScopedTypeVariables
TypeFamilies TypeFamilies
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
if impl(ghc >= 8.0.0)
ghc-options: -Wno-redundant-constraints
test-suite tests test-suite tests
default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: tests hs-source-dirs: tests
build-depends: build-depends:
@ -74,9 +53,6 @@ test-suite tests
, serversession-backend-redis , serversession-backend-redis
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head

View File

@ -26,13 +26,13 @@ module Web.ServerSession.Backend.Redis.Internal
, throwRS , throwRS
) where ) where
import Control.Applicative as A import Control.Applicative ((<$), (<$>))
import Control.Arrow (first) import Control.Arrow (first)
import Control.Monad (void, when) import Control.Monad (void, when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.List (partition) import Data.List (partition)
import Data.Maybe (fromMaybe, catMaybes) import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Web.PathPieces (toPathPiece) import Web.PathPieces (toPathPiece)
@ -45,27 +45,17 @@ import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Data.Time.Clock as TI import qualified Data.Time.Clock as TI
import qualified Data.Time.Clock.POSIX as TP
import qualified Data.Time.Format as TI import qualified Data.Time.Format as TI
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | Session storage backend using Redis via the @hedis@ package. -- | Session storage backend using Redis via the @hedis@ package.
data RedisStorage sess = newtype RedisStorage sess =
RedisStorage RedisStorage
{ connPool :: R.Connection { connPool :: R.Connection
-- ^ Connection pool to the Redis server. -- ^ Connection pool to the Redis server.
, idleTimeout :: Maybe TI.NominalDiffTime
-- ^ How long should a session live after last access
, absoluteTimeout :: Maybe TI.NominalDiffTime
-- ^ How long should a session live after creation
} deriving (Typeable) } deriving (Typeable)
@ -78,8 +68,8 @@ instance RedisSession sess => Storage (RedisStorage sess) where
getSession _ = getSessionImpl getSession _ = getSessionImpl
deleteSession _ = deleteSessionImpl deleteSession _ = deleteSessionImpl
deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl
insertSession = insertSessionImpl insertSession _ = insertSessionImpl
replaceSession = replaceSessionImpl replaceSession _ = replaceSessionImpl
-- | An exception thrown by the @serversession-backend-redis@ -- | An exception thrown by the @serversession-backend-redis@
@ -194,19 +184,13 @@ printSession Session {..} =
-- | Parse 'UTCTime' from a 'ByteString' stored on Redis. Uses -- | Parse 'UTCTime' from a 'ByteString' stored on Redis. Uses
-- 'error' on parse error. -- 'error' on parse error.
parseUTCTime :: ByteString -> TI.UTCTime parseUTCTime :: ByteString -> TI.UTCTime
#if MIN_VERSION_time(1,5,0) parseUTCTime = TI.parseTimeOrError True TI.defaultTimeLocale timeFormat . B8.unpack
parseUTCTime = TI.parseTimeOrError True defaultTimeLocale timeFormat . B8.unpack
#else
parseUTCTime =
fromMaybe (error "Web.ServerSession.Backend.Redis.Internal.parseUTCTime") .
TI.parseTime defaultTimeLocale timeFormat . B8.unpack
#endif
-- | Convert a 'UTCTime' into a 'ByteString' to be stored on -- | Convert a 'UTCTime' into a 'ByteString' to be stored on
-- Redis. -- Redis.
printUTCTime :: TI.UTCTime -> ByteString printUTCTime :: TI.UTCTime -> ByteString
printUTCTime = B8.pack . TI.formatTime defaultTimeLocale timeFormat printUTCTime = B8.pack . TI.formatTime TI.defaultTimeLocale timeFormat
-- | Time format used when storing 'UTCTime'. -- | Time format used when storing 'UTCTime'.
@ -230,7 +214,7 @@ batched f xs =
-- | Get the session for the given session ID. -- | Get the session for the given session ID.
getSessionImpl :: RedisSession sess => SessionId sess -> R.Redis (Maybe (Session sess)) getSessionImpl :: RedisSession sess => SessionId sess -> R.Redis (Maybe (Session sess))
getSessionImpl sid = parseSession sid A.<$> unwrap (R.hgetall $ rSessionKey sid) getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid)
-- | Delete the session with given session ID. -- | Delete the session with given session ID.
@ -276,8 +260,8 @@ deleteAllSessionsOfAuthIdImpl authId = do
-- | Insert a new session. -- | Insert a new session.
insertSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis () insertSessionImpl :: RedisSession sess => Session sess -> R.Redis ()
insertSessionImpl sto session = do insertSessionImpl session = do
-- Check that no old session exists. -- Check that no old session exists.
let sid = sessionKey session let sid = sessionKey session
moldSession <- getSessionImpl sid moldSession <- getSessionImpl sid
@ -287,14 +271,14 @@ insertSessionImpl sto session = do
transaction $ do transaction $ do
let sk = rSessionKey sid let sk = rSessionKey sid
r <- batched (R.hmset sk) (printSession session) r <- batched (R.hmset sk) (printSession session)
expireSession session sto -- TODO: R.expireat
insertSessionForAuthId (sessionKey session) (sessionAuthId session) insertSessionForAuthId (sessionKey session) (sessionAuthId session)
return (() <$ r) return (() <$ r)
-- | Replace the contents of a session. -- | Replace the contents of a session.
replaceSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis () replaceSessionImpl :: RedisSession sess => Session sess -> R.Redis ()
replaceSessionImpl sto session = do replaceSessionImpl session = do
-- Check that the old session exists. -- Check that the old session exists.
let sid = sessionKey session let sid = sessionKey session
moldSession <- getSessionImpl sid moldSession <- getSessionImpl sid
@ -306,7 +290,6 @@ replaceSessionImpl sto session = do
let sk = rSessionKey sid let sk = rSessionKey sid
_ <- R.del [sk] _ <- R.del [sk]
r <- batched (R.hmset sk) (printSession session) r <- batched (R.hmset sk) (printSession session)
expireSession session sto
-- Remove the old auth ID from the map if it has changed. -- Remove the old auth ID from the map if it has changed.
let oldAuthId = sessionAuthId oldSession let oldAuthId = sessionAuthId oldSession
@ -324,21 +307,3 @@ throwRS
=> StorageException (RedisStorage sess) => StorageException (RedisStorage sess)
-> R.Redis a -> R.Redis a
throwRS = liftIO . E.throwIO throwRS = liftIO . E.throwIO
-- | Given a session, finds the next time the session will time out,
-- either by idle or absolute timeout and schedule the key in redis to
-- expire at that time. This is meant to be used on every write to a
-- session so that it is constantly setting the appropriate timeout.
expireSession :: Session sess -> RedisStorage sess -> R.RedisTx ()
expireSession Session {..} RedisStorage {..} =
case minimum' (catMaybes [viaIdle, viaAbsolute]) of
Nothing -> return ()
Just t -> let ts = round (TP.utcTimeToPOSIXSeconds t)
in void (R.expireat sk ts)
where
sk = rSessionKey sessionKey
minimum' [] = Nothing
minimum' xs = Just (minimum xs)
viaIdle = flip TI.addUTCTime sessionAccessedAt <$> idleTimeout
viaAbsolute = flip TI.addUTCTime sessionCreatedAt <$> absoluteTimeout

View File

@ -9,4 +9,4 @@ main :: IO ()
main = do main = do
conn <- connect defaultConnectInfo conn <- connect defaultConnectInfo
hspec $ describe "RedisStorage" $ hspec $ describe "RedisStorage" $
allStorageTests (RedisStorage conn (Just 999999) (Just 999999)) it runIO parallel shouldBe shouldReturn shouldThrow allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow

View File

@ -1,2 +0,0 @@
1.0.1
* Get building on GHC-8

View File

@ -1,34 +1,27 @@
cabal-version: >= 1.10
name: serversession-frontend-snap name: serversession-frontend-snap
version: 1.0.1 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Snap bindings for serversession. synopsis: Snap bindings for serversession.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-snap> description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-snap>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
, bytestring , bytestring
, nonce , nonce
, path-pieces , path-pieces
, snap >= 0.14 , snap == 0.14.*
, snap-core >= 0.9 , snap-core == 0.9.*
, text , text
, time , time
, transformers , transformers
@ -38,16 +31,13 @@ library
exposed-modules: exposed-modules:
Web.ServerSession.Frontend.Snap Web.ServerSession.Frontend.Snap
Web.ServerSession.Frontend.Snap.Internal Web.ServerSession.Frontend.Snap.Internal
default-extensions: extensions:
DeriveDataTypeable DeriveDataTypeable
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
TypeFamilies TypeFamilies
UndecidableInstances UndecidableInstances
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head
type: git type: git

View File

@ -12,7 +12,7 @@ module Web.ServerSession.Frontend.Snap.Internal
, forceInvalidate , forceInvalidate
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>))
import Control.Arrow (first, second) import Control.Arrow (first, second)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -137,7 +137,7 @@ instance ( Storage sto
mcookie <- S.getCookie (cookieName ssm) mcookie <- S.getCookie (cookieName ssm)
-- Load session from storage backend. -- Load session from storage backend.
(data1, saveSessionToken) <- (data1, saveSessionToken) <-
liftIO $ loadSession (state ssm) (S.cookieValue A.<$> mcookie) liftIO $ loadSession (state ssm) (S.cookieValue <$> mcookie)
-- Add CSRF token if needed. -- Add CSRF token if needed.
data2 <- data2 <-
maybe maybe

View File

@ -1,25 +1,19 @@
cabal-version: >= 1.10
name: serversession-frontend-wai name: serversession-frontend-wai
version: 1.0 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: wai-session bindings for serversession. synopsis: wai-session bindings for serversession.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-wai> description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-wai>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base >= 4.6 && < 5 base >= 4.6 && < 5
@ -39,15 +33,11 @@ library
exposed-modules: exposed-modules:
Web.ServerSession.Frontend.Wai Web.ServerSession.Frontend.Wai
Web.ServerSession.Frontend.Wai.Internal Web.ServerSession.Frontend.Wai.Internal
default-extensions: extensions:
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
TypeFamilies TypeFamilies
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
if impl(ghc >= 8.0.0)
ghc-options: -Wno-redundant-constraints
source-repository head source-repository head
type: git type: git

View File

@ -6,7 +6,7 @@
-- @Max-age@ field is not supported by all browsers: some -- @Max-age@ field is not supported by all browsers: some
-- browsers will treat them as non-persistent cookies. -- browsers will treat them as non-persistent cookies.
-- --
-- * Also, the @Max-age@ is fixed and does not take a given -- * Also, the @Max-age@ is fixed and does not take a given a
-- session into consideration. -- session into consideration.
module Web.ServerSession.Frontend.Wai module Web.ServerSession.Frontend.Wai
( -- * Simple interface ( -- * Simple interface

View File

@ -10,7 +10,7 @@ module Web.ServerSession.Frontend.Wai.Internal
, forceInvalidate , forceInvalidate
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>))
import Control.Monad (guard) import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -80,7 +80,7 @@ mkSession sessionRef =
-- We need to use atomicModifyIORef instead of readIORef -- We need to use atomicModifyIORef instead of readIORef
-- because latter may be reordered (cf. "Memory Model" on -- because latter may be reordered (cf. "Memory Model" on
-- Data.IORef's documentation). -- Data.IORef's documentation).
( \k -> kvLookup k A.<$> liftIO (I.atomicModifyIORef' sessionRef $ \a -> (a, a)) ( \k -> kvLookup k <$> liftIO (I.atomicModifyIORef' sessionRef $ \a -> (a, a))
, \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . kvInsert k v) , \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . kvInsert k v)
) )

View File

@ -1,25 +1,19 @@
cabal-version: >= 1.10
name: serversession-frontend-yesod name: serversession-frontend-yesod
version: 1.0 version: 1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Yesod bindings for serversession. synopsis: Yesod bindings for serversession.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-yesod> description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-yesod>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
@ -33,19 +27,17 @@ library
, transformers , transformers
, unordered-containers , unordered-containers
, wai , wai
, yesod-core >= 1.6 , yesod-core == 1.4.*
, serversession == 1.0.* , serversession == 1.0.*
exposed-modules: exposed-modules:
Web.ServerSession.Frontend.Yesod Web.ServerSession.Frontend.Yesod
Web.ServerSession.Frontend.Yesod.Internal Web.ServerSession.Frontend.Yesod.Internal
default-extensions: extensions:
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
TypeFamilies TypeFamilies
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head
type: git type: git

View File

@ -1,2 +0,0 @@
# 1.0.2
* add persistent-test to deps

View File

@ -1,36 +1,29 @@
cabal-version: >= 1.10
name: serversession name: serversession
version: 1.0.2 version: 1.0.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Michael Xavier <michael@michaelxavier.net> maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Secure, modular server-side sessions. synopsis: Secure, modular server-side sessions.
category: Web category: Web
stability: Stable stability: Stable
cabal-version: >= 1.8
build-type: Simple build-type: Simple
homepage: https://github.com/yesodweb/serversession homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession> description: API docs and the README are available at <http://www.stackage.org/package/serversession>
extra-source-files: README.md extra-source-files: README.md
changelog.md
flag lib-Werror
default: False
manual: True
library library
default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
base == 4.* base == 4.*
, aeson , aeson
, base64-bytestring >= 1.0 && < 1.3 , base64-bytestring == 1.0.*
, bytestring , bytestring
, data-default , data-default
, hashable , hashable
, nonce == 1.0.* , nonce == 1.0.*
, path-pieces , path-pieces
, persistent-test
, text , text
, time , time
, transformers , transformers
@ -39,7 +32,7 @@ library
Web.ServerSession.Core Web.ServerSession.Core
Web.ServerSession.Core.Internal Web.ServerSession.Core.Internal
Web.ServerSession.Core.StorageTests Web.ServerSession.Core.StorageTests
default-extensions: extensions:
DeriveDataTypeable DeriveDataTypeable
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
@ -49,13 +42,9 @@ library
TypeFamilies TypeFamilies
UndecidableInstances UndecidableInstances
ghc-options: -Wall ghc-options: -Wall
if flag(lib-Werror)
ghc-options: -Werror
test-suite tests test-suite tests
default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: tests hs-source-dirs: tests
build-depends: build-depends:
@ -67,7 +56,7 @@ test-suite tests
, hspec >= 2.1 && < 3 , hspec >= 2.1 && < 3
, QuickCheck , QuickCheck
, serversession , serversession
default-extensions: extensions:
DeriveDataTypeable DeriveDataTypeable
FlexibleContexts FlexibleContexts
OverloadedStrings OverloadedStrings
@ -77,9 +66,6 @@ test-suite tests
UndecidableInstances UndecidableInstances
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts
if flag(lib-Werror)
ghc-options: -Werror
source-repository head source-repository head

View File

@ -45,7 +45,7 @@ module Web.ServerSession.Core.Internal
, ForceInvalidate(..) , ForceInvalidate(..)
) where ) where
import Control.Applicative as A import Control.Applicative ((<$>), (<*>))
import Control.Monad (guard, when) import Control.Monad (guard, when)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -730,7 +730,7 @@ saveSessionOnDb state now maybeInput DecomposedSession {..} = do
(saveToDb, key, createdAt) <- (saveToDb, key, createdAt) <-
case maybeInput of case maybeInput of
Nothing -> liftIO $ Nothing -> liftIO $
(,,) A.<$> return (insertSession $ storage state) (,,) <$> return (insertSession $ storage state)
<*> generateSessionId (generator state) <*> generateSessionId (generator state)
<*> return now <*> return now
Just Session {..} -> Just Session {..} ->

View File

@ -7,10 +7,9 @@ module Web.ServerSession.Core.StorageTests
( allStorageTests ( allStorageTests
) where ) where
import Control.Applicative as A import Control.Applicative ((<$), (<$>), (<*>))
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad import Control.Monad
import DataTypeTest (roundUTCTime)
import Web.ServerSession.Core.Internal import Web.ServerSession.Core.Internal
import qualified Crypto.Nonce as N import qualified Crypto.Nonce as N
@ -96,7 +95,7 @@ allStorageTests storage it runIO parallel _shouldBe shouldReturn shouldThrow = d
master <- generateSession gen HasAuthId master <- generateSession gen HasAuthId
let Just authId = sessionAuthId master let Just authId = sessionAuthId master
preslaves <- preslaves <-
(++) A.<$> replicateM 100 (generateSession gen HasAuthId) (++) <$> replicateM 100 (generateSession gen HasAuthId)
<*> replicateM 100 (generateSession gen NoAuthId) <*> replicateM 100 (generateSession gen NoAuthId)
let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves
others <- others <-
@ -174,8 +173,8 @@ allStorageTests storage it runIO parallel _shouldBe shouldReturn shouldThrow = d
{ sessionKey = sid { sessionKey = sid
, sessionAuthId = Nothing , sessionAuthId = Nothing
, sessionData = SessionMap $ HM.fromList vals , sessionData = SessionMap $ HM.fromList vals
, sessionCreatedAt = roundUTCTime now , sessionCreatedAt = now
, sessionAccessedAt = roundUTCTime now , sessionAccessedAt = now
} }
ver2 = session { sessionData = SessionMap HM.empty } ver2 = session { sessionData = SessionMap HM.empty }
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
@ -224,8 +223,8 @@ generateSession gen hasAuthId = do
{ sessionKey = sid { sessionKey = sid
, sessionAuthId = authId , sessionAuthId = authId
, sessionData = SessionMap data_ , sessionData = SessionMap data_
, sessionCreatedAt = roundUTCTime $ TI.addUTCTime (-1000) now , sessionCreatedAt = TI.addUTCTime (-1000) now
, sessionAccessedAt = roundUTCTime $ now , sessionAccessedAt = now
} }
data HasAuthId = HasAuthId | NoAuthId data HasAuthId = HasAuthId | NoAuthId

View File

@ -1,6 +1,6 @@
module Main (main) where module Main (main) where
import Control.Applicative as A import Control.Applicative ((<$), (<$>), (<*>))
import Control.Arrow import Control.Arrow
import Control.Monad import Control.Monad
import Data.Maybe import Data.Maybe
@ -49,7 +49,7 @@ main = hspec $ parallel $ do
-- The probability of a given character not appearing on -- The probability of a given character not appearing on
-- this test is (63/64)^(24*reps), so it's extremely -- this test is (63/64)^(24*reps), so it's extremely
-- unlikely for this test to fail on correct code. -- unlikely for this test to fail on correct code.
let observed = S.fromList $ concat $ T.unpack . unS A.<$> sids let observed = S.fromList $ concat $ T.unpack . unS <$> sids
expected = S.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_" expected = S.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_"
observed `shouldBe` expected observed `shouldBe` expected
@ -93,13 +93,9 @@ main = hspec $ parallel $ do
let checkEmptySession (sessionMap, SaveSessionToken msession time) = do let checkEmptySession (sessionMap, SaveSessionToken msession time) = do
-- Saved time is close to now, session map is empty, -- Saved time is close to now, session map is empty,
-- there's no reference to an existing session. -- there's no reference to an existing session.
-- let point1 = 0.1 {- second -} :: Double
-- We used to use 0.1 seconds, but Travis
-- intermittently had troubles with it, e.g.:
-- <https://travis-ci.org/yesodweb/serversession/jobs/67062266>
let closeEnough = 2 {- seconds -} :: Double
now <- TI.getCurrentTime now <- TI.getCurrentTime
abs (realToFrac $ TI.diffUTCTime now time) `shouldSatisfy` (< closeEnough) abs (realToFrac $ TI.diffUTCTime now time) `shouldSatisfy` (< point1)
sessionMap `shouldBe` TNTSessionData sessionMap `shouldBe` TNTSessionData
msession `shouldSatisfy` isNothing msession `shouldSatisfy` isNothing

View File

@ -1,18 +1,4 @@
flags: resolver: nightly-2015-06-09
serversession-backend-acid-state:
lib-Werror: true
serversession-frontend-wai:
lib-Werror: true
serversession-backend-persistent:
lib-Werror: true
serversession:
lib-Werror: true
serversession-backend-redis:
lib-Werror: true
serversession-frontend-yesod:
lib-Werror: true
serversession-frontend-snap:
lib-Werror: true
packages: packages:
- serversession - serversession
- serversession-backend-acid-state - serversession-backend-acid-state
@ -21,12 +7,7 @@ packages:
- serversession-frontend-snap - serversession-frontend-snap
- serversession-frontend-wai - serversession-frontend-wai
- serversession-frontend-yesod - serversession-frontend-yesod
- examples/serversession-example-yesod-persistent
extra-deps: extra-deps:
- snap-1.1.3.0@sha256:0c0814d2ab1c3d5f22cef4615b2913ded18e87710ea6febdbe6e3ab8d9838735,8872 - acid-state-0.12.4
- acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190 - nonce-1.0.2
- heist-1.1.0.1@sha256:7355cf8c1a7ef84c0c800c0539f7b99e7e540cace697238009a2dea1f05231f1,9311 - wai-session-0.3.1
- map-syntax-0.3@sha256:ca8b449615fa57419c16a5e98844624a6ac758692b87b3cfae8c74c87c56f1b2,2420
- pwstore-fast-2.4.4@sha256:9b6a37510d8b9f37f409a8ab3babac9181afcaaa3fce8ba1c131a7ed3de30698,1351
- xmlhtml-0.2.5.2@sha256:3f0990f725551985d777e8edb5563fe99aee998f1fde6a7633f720f76df54701,46997
resolver: lts-15.8

View File

@ -1,54 +0,0 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages:
- completed:
hackage: snap-1.1.3.0@sha256:0c0814d2ab1c3d5f22cef4615b2913ded18e87710ea6febdbe6e3ab8d9838735,8872
pantry-tree:
size: 5743
sha256: 804f55a8cab81e720547308e799243e81f43e089b860c0d3160a938cad86ed0d
original:
hackage: snap-1.1.3.0@sha256:0c0814d2ab1c3d5f22cef4615b2913ded18e87710ea6febdbe6e3ab8d9838735,8872
- completed:
hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
pantry-tree:
size: 13678
sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
original:
hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
- completed:
hackage: heist-1.1.0.1@sha256:7355cf8c1a7ef84c0c800c0539f7b99e7e540cace697238009a2dea1f05231f1,9311
pantry-tree:
size: 7354
sha256: a2635ed49de6debaf8b98189989f83ab58dcc125c6ae8e57f6fe0903bc7fa8ff
original:
hackage: heist-1.1.0.1@sha256:7355cf8c1a7ef84c0c800c0539f7b99e7e540cace697238009a2dea1f05231f1,9311
- completed:
hackage: map-syntax-0.3@sha256:ca8b449615fa57419c16a5e98844624a6ac758692b87b3cfae8c74c87c56f1b2,2420
pantry-tree:
size: 558
sha256: c196bee0433f9540e4251ebd1be06d802ff7cc4931e6f0aedc38babd28683a3c
original:
hackage: map-syntax-0.3@sha256:ca8b449615fa57419c16a5e98844624a6ac758692b87b3cfae8c74c87c56f1b2,2420
- completed:
hackage: pwstore-fast-2.4.4@sha256:9b6a37510d8b9f37f409a8ab3babac9181afcaaa3fce8ba1c131a7ed3de30698,1351
pantry-tree:
size: 270
sha256: ff4a44ede62515efe5cd366a5803f7183c811c4a0cf56eea88da94181c4844c0
original:
hackage: pwstore-fast-2.4.4@sha256:9b6a37510d8b9f37f409a8ab3babac9181afcaaa3fce8ba1c131a7ed3de30698,1351
- completed:
hackage: xmlhtml-0.2.5.2@sha256:3f0990f725551985d777e8edb5563fe99aee998f1fde6a7633f720f76df54701,46997
pantry-tree:
size: 61835
sha256: bb1bd95db3738e18d112bbc9724510ee64a51b7eda61494507f4957c5e2281f6
original:
hackage: xmlhtml-0.2.5.2@sha256:3f0990f725551985d777e8edb5563fe99aee998f1fde6a7633f720f76df54701,46997
snapshots:
- completed:
size: 492015
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/8.yaml
sha256: 926bc3d70249dd0ba05277ff00943c0addb35b627cb641752669e7cf771310d0
original: lts-15.8