diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# serversession-backend-persistent + +This is the storage backend for `serversession` using +`persistent` and an RDBMS. Please +[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md) +for general information about the serversession packages. + +Unfortunately it is not easy to support all `persistent` backends +on a single package, and this is why we currently support the SQL +backend only (which is more commonly used). diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/serversession-backend-persistent.cabal b/serversession-backend-persistent.cabal new file mode 100644 --- /dev/null +++ b/serversession-backend-persistent.cabal @@ -0,0 +1,83 @@ +name: serversession-backend-persistent +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Storage backend for serversession using persistent and an RDBMS. +category: Web +stability: Stable +cabal-version: >= 1.8 +build-type: Simple +homepage: https://github.com/yesodweb/serversession +description: API docs and the README are available at +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: + base == 4.* + , aeson + , base64-bytestring == 1.0.* + , bytestring + , cereal >= 0.4 + , path-pieces + , persistent == 2.1.* + , tagged >= 0.8 + , text + , time + , transformers + , unordered-containers + + , serversession == 1.0.* + exposed-modules: + Web.ServerSession.Backend.Persistent + Web.ServerSession.Backend.Persistent.Internal.Impl + Web.ServerSession.Backend.Persistent.Internal.Types + extensions: + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + OverloadedStrings + PatternGuards + QuasiQuotes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TypeFamilies + UndecidableInstances + ghc-options: -Wall + + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + build-depends: + + base, aeson, base64-bytestring, bytestring, cereal, + path-pieces, persistent, persistent-template, text, time, + transformers, unordered-containers + + , hspec >= 2.1 && < 3 + , monad-logger + , persistent-sqlite == 2.1.* + , persistent-postgresql == 2.1.* + , resource-pool + , QuickCheck + + , serversession + , serversession-backend-persistent + extensions: + OverloadedStrings + TemplateHaskell + main-is: Main.hs + ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts + + +source-repository head + type: git + location: https://github.com/yesodweb/serversession diff --git a/src/Web/ServerSession/Backend/Persistent.hs b/src/Web/ServerSession/Backend/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Backend/Persistent.hs @@ -0,0 +1,47 @@ +-- | Storage backend for @serversession@ using persistent. +-- +-- In order to use this backend, you have to include +-- 'serverSessionDefs' on your migration code. For example, +-- the Yesod scaffold usually includes the following code: +-- +-- @ +-- -- On Model.hs +-- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] +-- +-- -- On Application.hs +-- makeFoundation = +-- ... +-- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc +-- ... +-- @ +-- +-- You should changed those lines to: +-- +-- @ +-- -- On Model.hs +-- 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 +-- +-- mkMigrate \"migrateAll\" (SS.serverSessionDefs (P.Proxy :: P.Proxy SS.SessionMap) ++ entityDefs) +-- +-- makeFoundation = +-- ... +-- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc +-- ... +-- @ +-- +-- If you're not using @SessionMap@, just 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 + ) where + +import Web.ServerSession.Backend.Persistent.Internal.Impl diff --git a/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs b/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs @@ -0,0 +1,332 @@ +-- | Internal module exposing the guts of the package. Use at +-- your own risk. No API stability guarantees apply. +module Web.ServerSession.Backend.Persistent.Internal.Impl + ( PersistentSession(..) + , PersistentSessionId + , EntityField(..) + , serverSessionDefs + , psKey + , toPersistentSession + , fromPersistentSession + , SqlStorage(..) + , throwSS + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Monoid (mempty) +import Data.Proxy (Proxy(..)) +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import Database.Persist (PersistEntity(..)) +import Web.PathPieces (PathPiece) +import Web.ServerSession.Core + +import qualified Control.Exception as E +import qualified Data.Aeson as A +import qualified Data.Text as T +import qualified Database.Persist as P +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. +-- +-- This is going to be a pain to upgrade when the next major +-- persistent version comes :(. + +-- | Entity corresponding to a 'Session'. +-- +-- We're bending @persistent@ in ways it wasn't expected to. In +-- particular, this entity is parametrized over the session type. +data PersistentSession sess = + PersistentSession + { persistentSessionKey :: !(SessionId sess) -- ^ Session ID, primary key. + , persistentSessionAuthId :: !(Maybe ByteStringJ) -- ^ Value of "_ID" session key. + , persistentSessionSession :: !(Decomposed sess) -- ^ Rest of the session data. + , persistentSessionCreatedAt :: !UTCTime -- ^ When this session was created. + , persistentSessionAccessedAt :: !UTCTime -- ^ When this session was last accessed. + } deriving (Typeable) + +deriving instance Eq (Decomposed sess) => Eq (PersistentSession sess) +deriving instance Ord (Decomposed sess) => Ord (PersistentSession sess) +deriving instance Show (Decomposed sess) => Show (PersistentSession sess) + + +type PersistentSessionId sess = Key (PersistentSession sess) + +instance forall sess. P.PersistFieldSql (Decomposed sess) => P.PersistEntity (PersistentSession sess) where + type PersistEntityBackend (PersistentSession sess) = P.SqlBackend + + data Unique (PersistentSession sess) + + newtype Key (PersistentSession sess) = + PersistentSessionKey' {unPersistentSessionKey :: SessionId sess} + deriving ( Eq, Ord, Show, Read, PathPiece + , P.PersistField, P.PersistFieldSql, A.ToJSON, A.FromJSON ) + + data EntityField (PersistentSession sess) typ = + typ ~ PersistentSessionId sess => PersistentSessionId + | typ ~ SessionId sess => PersistentSessionKey + | typ ~ Maybe ByteStringJ => PersistentSessionAuthId + | typ ~ Decomposed sess => PersistentSessionSession + | typ ~ UTCTime => PersistentSessionCreatedAt + | typ ~ UTCTime => PersistentSessionAccessedAt + + keyToValues = (:[]) . P.toPersistValue . unPersistentSessionKey + keyFromValues [x] | Right v <- P.fromPersistValue x = Right $ PersistentSessionKey' v + keyFromValues xs = Left $ T.pack $ "PersistentSession/keyFromValues: " ++ show xs + + 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"] + mempty + False + where + pfd :: P.EntityField (PersistentSession sess) typ -> P.FieldDef + pfd = P.persistFieldDef + + toPersistFields (PersistentSession a b c d e) = + [ P.SomePersistField a + , P.SomePersistField b + , P.SomePersistField c + , P.SomePersistField d + , P.SomePersistField e ] + + fromPersistValues [a, b, c, d, e] = + PersistentSession + <$> err "key" (P.fromPersistValue a) + <*> err "authId" (P.fromPersistValue b) + <*> err "session" (P.fromPersistValue c) + <*> err "createdAt" (P.fromPersistValue d) + <*> err "accessedAt" (P.fromPersistValue e) + where + err :: T.Text -> Either T.Text a -> Either T.Text a + err s (Left r) = Left $ T.concat ["PersistentSession/fromPersistValues/", s, ": ", r] + err _ (Right v) = Right v + fromPersistValues x = Left $ T.pack $ "PersistentSession/fromPersistValues: " ++ show x + + persistUniqueToFieldNames _ = error "Degenerate case, should never happen" + persistUniqueToValues _ = error "Degenerate case, should never happen" + 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] + [])) + persistFieldDef PersistentSessionKey + = P.FieldDef + (P.HaskellName "key") + (P.DBName "key") + (P.FTTypeCon Nothing "SessionId sess") + (P.sqlType (Proxy :: Proxy (SessionId sess))) + [] + True + P.NoReference + persistFieldDef PersistentSessionAuthId + = P.FieldDef + (P.HaskellName "authId") + (P.DBName "auth_id") + (P.FTTypeCon Nothing "ByteStringJ") + (P.sqlType (Proxy :: Proxy ByteStringJ)) + ["Maybe"] + True + P.NoReference + persistFieldDef PersistentSessionSession + = P.FieldDef + (P.HaskellName "session") + (P.DBName "session") + (P.FTTypeCon Nothing "Decomposed sess") + (P.sqlType (Proxy :: Proxy (Decomposed sess))) -- Important! + [] + True + P.NoReference + persistFieldDef PersistentSessionCreatedAt + = P.FieldDef + (P.HaskellName "createdAt") + (P.DBName "created_at") + (P.FTTypeCon Nothing "UTCTime") + (P.sqlType (Proxy :: Proxy UTCTime)) + [] + True + P.NoReference + persistFieldDef PersistentSessionAccessedAt + = P.FieldDef + (P.HaskellName "accessedAt") + (P.DBName "accessed_at") + (P.FTTypeCon Nothing "UTCTime") + (P.sqlType (Proxy :: Proxy UTCTime)) + [] + True + P.NoReference + + persistIdField = PersistentSessionId + + fieldLens PersistentSessionId = lensPTH + P.entityKey + (\(P.Entity _ v) k -> P.Entity k v) + fieldLens PersistentSessionKey = lensPTH + (persistentSessionKey . P.entityVal) + (\(P.Entity k v) x -> P.Entity k (v {persistentSessionKey = x})) + fieldLens PersistentSessionAuthId = lensPTH + (persistentSessionAuthId . P.entityVal) + (\(P.Entity k v) x -> P.Entity k (v {persistentSessionAuthId = x})) + fieldLens PersistentSessionSession = lensPTH + (persistentSessionSession . P.entityVal) + (\(P.Entity k v) x -> P.Entity k (v {persistentSessionSession = x})) + fieldLens PersistentSessionCreatedAt = lensPTH + (persistentSessionCreatedAt . P.entityVal) + (\(P.Entity k v) x -> P.Entity k (v {persistentSessionCreatedAt = x})) + fieldLens PersistentSessionAccessedAt = lensPTH + (persistentSessionAccessedAt . P.entityVal) + (\(P.Entity k v) x -> P.Entity k (v {persistentSessionAccessedAt = x})) + + +-- | Copy-paste from @Database.Persist.TH@. Who needs lens anyway... +lensPTH :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t +lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) + + +instance A.ToJSON (Decomposed sess) => A.ToJSON (PersistentSession sess) where + toJSON (PersistentSession key authId session createdAt accessedAt) = + A.object + [ "key" A..= key + , "authId" A..= authId + , "session" A..= session + , "createdAt" A..= createdAt + , "accessedAt" A..= accessedAt ] + +instance A.FromJSON (Decomposed sess) => A.FromJSON (PersistentSession sess) where + parseJSON (A.Object obj) = + PersistentSession + <$> obj A..: "key" + <*> obj A..: "authId" + <*> obj A..: "session" + <*> obj A..: "createdAt" + <*> obj A..: "accessedAt" + parseJSON _ = mempty + +instance ( A.ToJSON (Decomposed sess) + , P.PersistFieldSql (Decomposed sess) + ) => A.ToJSON (P.Entity (PersistentSession sess)) where + toJSON = P.entityIdToJSON + +instance ( A.FromJSON (Decomposed sess) + , P.PersistFieldSql (Decomposed sess) + ) => A.FromJSON (P.Entity (PersistentSession sess)) where + parseJSON = P.entityIdFromJSON + + +-- | Entity definitions needed to generate the SQL schema for +-- 'SqlStorage'. Example using 'SessionMap': +-- +-- @ +-- serverSessionDefs (Proxy :: Proxy SessionMap) +-- @ +serverSessionDefs :: forall sess. PersistEntity (PersistentSession sess) => Proxy sess -> [P.EntityDef] +serverSessionDefs _ = [entityDef (Proxy :: Proxy (PersistentSession sess))] + + +-- | Generate a key to the entity from the session ID. +psKey :: SessionId sess -> Key (PersistentSession sess) +psKey = PersistentSessionKey' + + +-- | Convert from 'Session' to 'PersistentSession'. +toPersistentSession :: Session sess -> PersistentSession sess +toPersistentSession Session {..} = + PersistentSession + { persistentSessionKey = sessionKey + , persistentSessionAuthId = fmap B sessionAuthId + , persistentSessionSession = sessionData + , persistentSessionCreatedAt = sessionCreatedAt + , persistentSessionAccessedAt = sessionAccessedAt + } + + +-- | Convert from 'PersistentSession' to 'Session'. +fromPersistentSession :: PersistentSession sess -> Session sess +fromPersistentSession PersistentSession {..} = + Session + { sessionKey = persistentSessionKey + , sessionAuthId = fmap unB persistentSessionAuthId + , sessionData = persistentSessionSession + , sessionCreatedAt = persistentSessionCreatedAt + , sessionAccessedAt = persistentSessionAccessedAt + } + + +-- | SQL session storage backend using @persistent@. +newtype SqlStorage sess = + SqlStorage + { connPool :: P.ConnectionPool + -- ^ Pool of DB connections. You may use the same pool as + -- your application. + } deriving (Typeable) + + +instance forall sess. + ( IsSessionData sess + , P.PersistFieldSql (Decomposed sess) + ) => Storage (SqlStorage sess) where + type SessionData (SqlStorage sess) = sess + type TransactionM (SqlStorage sess) = P.SqlPersistT IO + runTransactionM = flip P.runSqlPool . connPool + getSession _ = fmap (fmap fromPersistentSession) . P.get . psKey + deleteSession _ = P.delete . psKey + deleteAllSessionsOfAuthId _ authId = + P.deleteWhere [field P.==. Just (B authId)] + where + field :: EntityField (PersistentSession sess) (Maybe ByteStringJ) + field = PersistentSessionAuthId + insertSession s session = do + mold <- getSession s (sessionKey session) + maybe + (void $ P.insert $ toPersistentSession session) + (\old -> throwSS $ SessionAlreadyExists old session) + mold + replaceSession _ session = do + let key = psKey $ sessionKey session + mold <- P.get key + maybe + (throwSS $ SessionDoesNotExist session) + (\_old -> void $ P.replace key $ toPersistentSession session) + mold + + +-- | Specialization of 'E.throwIO' for 'SqlStorage'. +throwSS + :: Storage (SqlStorage sess) + => StorageException (SqlStorage sess) + -> TransactionM (SqlStorage sess) a +throwSS = liftIO . E.throwIO diff --git a/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs b/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Internal module exposing the guts of the package. Use at +-- your own risk. No API stability guarantees apply. +-- +-- Also exports orphan instances of @PersistField{,Sql} SessionId@. +module Web.ServerSession.Backend.Persistent.Internal.Types + ( ByteStringJ(..) + -- * Orphan instances + -- ** SessionId + -- $orphanSessionId + -- ** SessionMap + -- $orphanSessionMap + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Monad ((>=>), mzero) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Database.Persist (PersistField(..)) +import Database.Persist.Sql (PersistFieldSql(..), SqlType(..)) +import Web.ServerSession.Core +import Web.ServerSession.Core.Internal (SessionId(..)) + +import qualified Data.Aeson as A +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.HashMap.Strict as HM +import qualified Data.Serialize as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + + +---------------------------------------------------------------------- + + +-- $orphanSessionId +-- +-- @ +-- instance 'PersistField' ('SessionId' sess) +-- instance 'PersistFieldSql' ('SessionId' sess) +-- @ +-- +-- Does not do sanity checks (DB is trusted). +instance PersistField (SessionId sess) where + toPersistValue = toPersistValue . unS + fromPersistValue = fmap S . fromPersistValue + +instance PersistFieldSql (SessionId sess) where + sqlType p = sqlType (fmap unS p) + + +---------------------------------------------------------------------- + + +-- | Newtype of a 'ByteString' with JSON support via base64url. +newtype ByteStringJ = B { unB :: ByteString } + deriving (Eq, Ord, Show, Read, Typeable) + +instance PersistField ByteStringJ where + toPersistValue = toPersistValue . unB + fromPersistValue = fmap B . fromPersistValue + +instance PersistFieldSql ByteStringJ where + sqlType p = sqlType (fmap unB p) + +instance A.FromJSON ByteStringJ where + parseJSON (A.String t) = + either (const mzero) (return . B) $ + B64URL.decode $ + TE.encodeUtf8 t + parseJSON _ = mzero + +instance A.ToJSON ByteStringJ where + toJSON = A.String . TE.decodeUtf8 . B64URL.encode . unB + + +---------------------------------------------------------------------- + + +-- $orphanSessionMap +-- +-- @ +-- instance 'PersistField' 'SessionMap' +-- instance 'PersistFieldSql' 'SessionMap' +-- instance 'S.Serialize' 'SessionMap' +-- instance 'A.FromJSON' 'SessionMap' +-- instance 'A.ToJSON' 'SessionMap' +-- @ + +-- 'PersistField' for 'SessionMap' serializes using @cereal@ on +-- the database. We tried to use @aeson@ but @cereal@ is twice +-- faster and uses half the memory for this use case. +-- +-- The JSON instance translates to objects using base64url for +-- the values of 'ByteString' (cf. 'ByteStringJ'). +instance PersistField SessionMap where + toPersistValue = toPersistValue . S.encode + fromPersistValue = fromPersistValue >=> (either (Left . T.pack) Right . S.decode) + +instance PersistFieldSql SessionMap where + sqlType _ = SqlBlob + +instance S.Serialize SessionMap where + put = S.put . map (first TE.encodeUtf8) . HM.toList . unSessionMap + get = SessionMap . HM.fromList . map (first TE.decodeUtf8) <$> S.get + +instance A.FromJSON SessionMap where + parseJSON = fmap fixup . A.parseJSON + where + fixup :: HM.HashMap Text ByteStringJ -> SessionMap + fixup = SessionMap . fmap unB + +instance A.ToJSON SessionMap where + toJSON = A.toJSON . mangle + where + mangle :: SessionMap -> HM.HashMap Text ByteStringJ + mangle = fmap B . unSessionMap diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,37 @@ +module Main (main) where + +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)) + +main :: IO () +main = hspec $ + forM_ [ ("PostgreSQL", createPostgresqlPool "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 <- 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