serversession-backend-persistent 1.0.5 → 2.0.0
raw patch · 5 files changed
+121/−93 lines, 5 filesdep ~base64-bytestringdep ~persistentnew-uploader
Dependency ranges changed: base64-bytestring, persistent
Files
- changelog.md +16/−3
- serversession-backend-persistent.cabal +4/−3
- src/Web/ServerSession/Backend/Persistent.hs +8/−6
- src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs +87/−67
- tests/Main.hs +6/−14
changelog.md view
@@ -1,7 +1,20 @@-1.0.5+# 2.0.0++## bump persistent to 2.13++I had no choice but to delete `serverSessionDefs` to match persistent updates.+If you are using it as Example, please use `serverSessionDefsBySessionMap`.+If you are customizing in detail, please use `mkServerSessionDefs` as hard as you can.++# 1.0.5+ * bump persistent to 2.10-1.0.4++# 1.0.4+ * Default auth id to NULL to fix a MySQL bug.-1.0.3++# 1.0.3+ * Get building on ghc-8 * Limit column size for session key
serversession-backend-persistent.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: serversession-backend-persistent-version: 1.0.5+version: 2.0.0 license: MIT license-file: LICENSE author: Felipe Lessa <felipe.lessa@gmail.com>@@ -24,11 +24,11 @@ build-depends: base == 4.* , aeson- , base64-bytestring == 1.0.*+ , base64-bytestring == 1.2.* , bytestring , cereal >= 0.4 , path-pieces- , persistent >= 2.10+ , persistent >= 2.13 , tagged >= 0.7 , text , time@@ -50,6 +50,7 @@ OverloadedStrings PatternGuards QuasiQuotes+ RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
src/Web/ServerSession/Backend/Persistent.hs view
@@ -22,11 +22,9 @@ -- share [mkPersist sqlSettings, mkSave \"entityDefs\"] -- -- -- On Application.hs--- import qualified Data.Proxy as P -- tagged package, or base from GHC 7.10 onwards--- import qualified Web.ServerSession.Core as SS--- import qualified Web.ServerSession.Backend.Persistent as SS+-- import Web.ServerSession.Backend.Persistent ----- mkMigrate \"migrateAll\" (SS.serverSessionDefs (P.Proxy :: P.Proxy SS.SessionMap) ++ entityDefs)+-- mkMigrate \"migrateAll\" (entityDefs \`embedEntityDefs\` serverSessionDefsBySessionMap) -- -- makeFoundation = -- ...@@ -34,14 +32,18 @@ -- ... -- @ ----- If you're not using @SessionMap@, just change @Proxy@ type above.+-- If you're not using @SessionMap@, just use 'mkServerSessionDefs' and change @Proxy@ type above. -- -- If you forget to setup the migration above, this session -- storage backend will fail at runtime as the required table -- will not exist. module Web.ServerSession.Backend.Persistent ( SqlStorage(..)- , serverSessionDefs+ , PersistentSession(..)+ , PersistentSessionId+ , serverSessionDefsBySessionMap+ , PersistentSessionBySessionMap+ , mkServerSessionDefs ) where import Web.ServerSession.Backend.Persistent.Internal.Impl
src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs view
@@ -4,7 +4,9 @@ ( PersistentSession(..) , PersistentSessionId , EntityField(..)- , serverSessionDefs+ , serverSessionDefsBySessionMap+ , PersistentSessionBySessionMap+ , mkServerSessionDefs , psKey , toPersistentSession , fromPersistentSession@@ -15,7 +17,6 @@ import Control.Applicative as A import Control.Monad (void) import Control.Monad.IO.Class (liftIO)-import Data.Monoid as M import Data.Proxy (Proxy(..)) import Data.Time (UTCTime) import Data.Typeable (Typeable)@@ -27,11 +28,12 @@ import qualified Data.Aeson as A import qualified Data.Text as T import qualified Database.Persist as P+import qualified Database.Persist.EntityDef.Internal as P (EntityDef(..)) -- I need EntityDef constructor.+import qualified Database.Persist.Quasi.Internal as P (UnboundEntityDef, unbindEntityDef) import qualified Database.Persist.Sql as P import Web.ServerSession.Backend.Persistent.Internal.Types - -- We can't use the Template Haskell since we want to generalize -- some fields. --@@ -68,8 +70,8 @@ deriving ( Eq, Ord, Show, Read, PathPiece , P.PersistField, P.PersistFieldSql, A.ToJSON, A.FromJSON ) - data EntityField (PersistentSession sess) typ =- typ ~ PersistentSessionId sess => PersistentSessionId+ data EntityField (PersistentSession sess) typ+ = typ ~ PersistentSessionId sess => PersistentSessionId | typ ~ SessionId sess => PersistentSessionKey | typ ~ Maybe ByteStringJ => PersistentSessionAuthId | typ ~ Decomposed sess => PersistentSessionSession@@ -82,24 +84,26 @@ entityDef _ = P.EntityDef- (P.HaskellName "PersistentSession")- (P.DBName "persistent_session")- (pfd PersistentSessionId)- ["json"]- [ pfd PersistentSessionKey- , pfd PersistentSessionAuthId- , pfd PersistentSessionSession- , pfd PersistentSessionCreatedAt- , pfd PersistentSessionAccessedAt ]- []- []- ["Eq", "Ord", "Show", "Typeable"]- M.mempty- False- Nothing- where- pfd :: P.EntityField (PersistentSession sess) typ -> P.FieldDef- pfd = P.persistFieldDef+ { entityHaskell = P.EntityNameHS "PersistentSession" -- it's dummy.+ , entityDB = P.EntityNameDB "persistent_session"+ -- Since backend is not only persistent, we use the natural key here.+ , entityId = P.EntityIdNaturalKey $ P.CompositeDef (pure $ pfd PersistentSessionKey) []+ , entityAttrs = ["json"]+ , entityFields =+ [ pfd PersistentSessionKey+ , pfd PersistentSessionAuthId+ , pfd PersistentSessionSession+ , pfd PersistentSessionCreatedAt+ , pfd PersistentSessionAccessedAt ]+ , entityUniques = []+ , entityForeigns = []+ , entityDerives = ["Eq", "Ord", "Show", "Typeable"]+ , entityExtra = mempty+ , entitySum = False+ , entityComments = Nothing+ }+ where pfd :: P.EntityField (PersistentSession sess) typ -> P.FieldDef+ pfd = P.persistFieldDef toPersistFields (PersistentSession a b c d e) = [ P.SomePersistField a@@ -126,77 +130,61 @@ persistUniqueKeys _ = [] persistFieldDef PersistentSessionId- = P.FieldDef- (P.HaskellName "Id")- (P.DBName "id")- (P.FTTypeCon- Nothing "PersistentSessionId")- (P.SqlOther "Composite Reference")- []- True- (P.CompositeRef- (P.CompositeDef- [P.FieldDef- (P.HaskellName "key")- (P.DBName "key")- (P.FTTypeCon Nothing "SessionId")- (P.SqlOther "SqlType unset for key")- []- True- P.NoReference- Nothing]- []))- Nothing+ = persistFieldDefPersistentSessionKey persistFieldDef PersistentSessionKey- = P.FieldDef- (P.HaskellName "key")- (P.DBName "key")- (P.FTTypeCon Nothing "SessionId sess")- (P.sqlType (Proxy :: Proxy (SessionId sess)))- ["maxlen=30"]- True- P.NoReference- Nothing+ = persistFieldDefPersistentSessionKey persistFieldDef PersistentSessionAuthId = P.FieldDef- (P.HaskellName "authId")- (P.DBName "auth_id")+ (P.FieldNameHS "authId")+ (P.FieldNameDB "auth_id") (P.FTTypeCon Nothing "ByteStringJ") (P.sqlType (Proxy :: Proxy ByteStringJ))- ["Maybe", "default=NULL"]+ [P.FieldAttrMaybe, P.FieldAttrDefault "NULL"] True P.NoReference+ (P.FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}) Nothing+ Nothing+ False persistFieldDef PersistentSessionSession = P.FieldDef- (P.HaskellName "session")- (P.DBName "session")+ (P.FieldNameHS "session")+ (P.FieldNameDB "session") (P.FTTypeCon Nothing "Decomposed sess") (P.sqlType (Proxy :: Proxy (Decomposed sess))) -- Important! [] True P.NoReference+ (P.FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}) Nothing+ Nothing+ False persistFieldDef PersistentSessionCreatedAt = P.FieldDef- (P.HaskellName "createdAt")- (P.DBName "created_at")+ (P.FieldNameHS "createdAt")+ (P.FieldNameDB "created_at") (P.FTTypeCon Nothing "UTCTime") (P.sqlType (Proxy :: Proxy UTCTime)) [] True P.NoReference+ (P.FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}) Nothing+ Nothing+ False persistFieldDef PersistentSessionAccessedAt = P.FieldDef- (P.HaskellName "accessedAt")- (P.DBName "accessed_at")+ (P.FieldNameHS "accessedAt")+ (P.FieldNameDB "accessed_at") (P.FTTypeCon Nothing "UTCTime") (P.sqlType (Proxy :: Proxy UTCTime)) [] True P.NoReference+ (P.FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}) Nothing+ Nothing+ False persistIdField = PersistentSessionId @@ -219,6 +207,21 @@ (persistentSessionAccessedAt . P.entityVal) (\(P.Entity k v) x -> P.Entity k (v {persistentSessionAccessedAt = x})) +-- | To avoid type argument mismatch, the definition is spit out and finalized.+persistFieldDefPersistentSessionKey :: P.FieldDef+persistFieldDefPersistentSessionKey =+ P.FieldDef+ (P.FieldNameHS "key")+ (P.FieldNameDB "key")+ (P.FTTypeCon Nothing "SessionId sess")+ (P.sqlType (Proxy :: Proxy (SessionId sess)))+ [P.FieldAttrMaxlen 30]+ True+ P.NoReference+ (P.FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing})+ Nothing+ Nothing+ False -- | Copy-paste from @Database.Persist.TH@. Who needs lens anyway... lensPTH :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t@@ -254,16 +257,33 @@ ) => A.FromJSON (P.Entity (PersistentSession sess)) where parseJSON = P.entityIdFromJSON +type PersistentSessionBySessionMap = PersistentSession SessionMap --- | Entity definitions needed to generate the SQL schema for--- 'SqlStorage'. Example using 'SessionMap':+-- | Simple version.+-- Entity definitions needed to generate the SQL schema for 'SqlStorage'.+-- Example: -- -- @--- serverSessionDefs (Proxy :: Proxy SessionMap)+-- mkMigrate \"migrateAll\" serverSessionDefsBySessionMap -- @-serverSessionDefs :: forall sess. PersistEntity (PersistentSession sess) => Proxy sess -> [P.EntityDef]-serverSessionDefs _ = [entityDef (Proxy :: Proxy (PersistentSession sess))]+--+-- Note: Also import `PersistentSessionBySessionMap` in the same module.+serverSessionDefsBySessionMap :: [P.UnboundEntityDef]+serverSessionDefsBySessionMap = mkServerSessionDefs (Proxy :: Proxy PersistentSessionBySessionMap) "PersistentSessionBySessionMap" +-- | Entity definitions needed to generate the SQL schema for 'SqlStorage'.+-- Generate schema by specifying Haskell name in Text.+--+-- Example using 'SessionMap':+--+-- @+-- type PersistentSessionBySessionMap = PersistentSession SessionMap+-- mkMigrate \"migrateAll\" (mkServerSessionDefs (Proxy :: Proxy PersistentSessionBySessionMap) \"PersistentSessionBySessionMap\")+-- @+mkServerSessionDefs :: forall sess. PersistEntity sess => Proxy sess -> T.Text -> [P.UnboundEntityDef]+mkServerSessionDefs _ name =+ -- The name of a variable of type sess is no longer taken into account, so it is now necessary to pass it by Text.+ [P.unbindEntityDef $ (entityDef (Proxy :: Proxy sess)) { P.entityHaskell = P.EntityNameHS name }] -- | Generate a key to the entity from the session ID. psKey :: SessionId sess -> Key (PersistentSession sess)
tests/Main.hs view
@@ -3,35 +3,27 @@ import Control.Monad (forM_) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) import Data.Pool (destroyAllResources)-import Data.Proxy (Proxy(..)) import Database.Persist.Postgresql (createPostgresqlPool) import Database.Persist.Sqlite (createSqlitePool) import Test.Hspec import Web.ServerSession.Backend.Persistent-import Web.ServerSession.Core (SessionMap) import Web.ServerSession.Core.StorageTests -import qualified Control.Exception as E import qualified Database.Persist.TH as P import qualified Database.Persist.Sql as P -P.mkMigrate "migrateAll" (serverSessionDefs (Proxy :: Proxy SessionMap))+P.mkMigrate "migrateAll" serverSessionDefsBySessionMap main :: IO () main = hspec $- forM_ [ ("PostgreSQL", createPostgresqlPool "user=test dbname=test password=test" 20)+ forM_ [ ("PostgreSQL", createPostgresqlPool "host=localhost port=5432 user=test dbname=test password=test" 20) , ("SQLite", createSqlitePool "test.db" 1) ] $ \(rdbms, createPool) -> describe ("SqlStorage on " ++ rdbms) $ do- epool <-- runIO $ E.try $ do+ pool <-+ runIO $ do pool <- runNoLoggingT createPool runStderrLoggingT $ P.runSqlPool (P.runMigration migrateAll) pool return pool- case epool of- Left (E.SomeException exc) ->- it "failed to create connection or migrate database" $- pendingWith (show exc)- Right pool ->- afterAll_ (destroyAllResources pool) $- allStorageTests (SqlStorage pool) it runIO parallel shouldBe shouldReturn shouldThrow+ afterAll_ (destroyAllResources pool) $+ allStorageTests (SqlStorage pool) it runIO parallel shouldBe shouldReturn shouldThrow