diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # CHANGELOG +# 0.1.0.4 + +- Support `persistent-2.13` + # 0.1.0.3 - Support `persistent-2.12` diff --git a/persistent-typed-db.cabal b/persistent-typed-db.cabal --- a/persistent-typed-db.cabal +++ b/persistent-typed-db.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: persistent-typed-db -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Type safe access to multiple database schemata. description: See README.md for more details, examples, and fun. category: Web @@ -36,7 +36,7 @@ , http-api-data , monad-logger , path-pieces - , persistent >=2.12.0 && < 2.13 + , persistent >=2.13.0 && < 2.14 , resource-pool , resourcet >=1.2.0 , template-haskell @@ -63,12 +63,13 @@ , http-api-data , monad-logger , path-pieces - , persistent >=2.8.0 - , persistent-template + , persistent >= 2.13 , persistent-typed-db , resource-pool , resourcet >=1.2.0 , template-haskell , text , transformers + build-tool-depends: + hspec-discover:hspec-discover default-language: Haskell2010 diff --git a/src/Database/Persist/Typed.hs b/src/Database/Persist/Typed.hs --- a/src/Database/Persist/Typed.hs +++ b/src/Database/Persist/Typed.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -- | This module defines types and helpers for type-safe access to multiple -- database schema. @@ -14,6 +14,7 @@ ( -- * Schema Definition mkSqlSettingsFor , SqlFor(..) + , BackendKey(..) -- * Specialized aliases , SqlPersistTFor , ConnectionPoolFor @@ -33,36 +34,34 @@ , fromSqlKeyFor ) where -import Control.Exception hiding (throw) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Trans.Reader (ReaderT (..), ask, asks, - withReaderT) -import Control.Monad.Trans.Resource (MonadUnliftIO, ResourceT) -import Data.Aeson as A -import Data.ByteString.Char8 (readInteger) -import Data.Coerce (coerce) -import Data.Conduit ((.|)) -import qualified Data.Conduit.List as CL -import qualified Data.Foldable as Foldable -import Data.Int (Int64) -import Data.List (find, inits, transpose) -import qualified Data.List.NonEmpty as NEL -import Data.Maybe (isJust) -import Data.Monoid (mappend, (<>)) -import Data.Pool (Pool) -import Data.Text (Text) -import qualified Data.Text as Text -import Database.Persist.Sql hiding (deleteWhereCount, - updateWhereCount) -import Database.Persist.Sql.Types.Internal (IsPersistBackend (..)) -import Database.Persist.Sql.Util -import Database.Persist.TH (MkPersistSettings, - mkPersistSettings) -import Language.Haskell.TH (Name, Type (..)) -import Web.HttpApiData (FromHttpApiData, - ToHttpApiData) -import Web.PathPieces (PathPiece) +import Control.Exception hiding (throw) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger (NoLoggingT) +import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, withReaderT) +import Control.Monad.Trans.Resource (MonadUnliftIO, ResourceT) +import Data.Aeson as A +import Data.ByteString.Char8 (readInteger) +import Data.Coerce (coerce) +import Data.Conduit ((.|)) +import qualified Data.Conduit.List as CL +import qualified Data.Foldable as Foldable +import Data.Foldable (toList) +import Data.Int (Int64) +import Data.List (find, inits, transpose) +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (isJust) +import Data.Monoid (mappend, (<>)) +import Data.Pool (Pool) +import Data.Text (Text) +import qualified Data.Text as Text +import Database.Persist.Sql hiding (deleteWhereCount, updateWhereCount) +import Database.Persist.Sql.Types.Internal (IsPersistBackend(..)) +import Database.Persist.Sql.Util +import Database.Persist.SqlBackend.Internal +import Database.Persist.TH (MkPersistSettings, mkPersistSettings) +import Language.Haskell.TH (Name, Type(..)) +import Web.HttpApiData (FromHttpApiData, ToHttpApiData) +import Web.PathPieces (PathPiece) -- | A wrapper around 'SqlBackend' type. To specialize this to a specific -- database, fill in the type parameter. @@ -236,15 +235,15 @@ conn <- asks unSqlFor let t = entityDef $ dummyFromKey k let cols = Text.intercalate "," - $ map (connEscapeRawName conn . unFieldNameDB . fieldDB) $ entityFields t + $ map (connEscapeRawName conn . unFieldNameDB . fieldDB) $ getEntityFieldsDatabase t noColumns :: Bool - noColumns = null $ entityFields t + noColumns = null $ getEntityFieldsDatabase t let wher = whereStmtForKey conn k let sql = Text.concat [ "SELECT " , if noColumns then "*" else cols , " FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , " WHERE " , wher ] @@ -324,8 +323,8 @@ case entityPrimary t of Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql Just pdef -> - let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs + let pks = map fieldHaskell $ toList $ compositeFields pdef + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFieldsDatabase t) fs in case keyFromValues keyvals of Right k -> return k Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` Text.unpack e @@ -365,7 +364,7 @@ case connMaxParams conn of Nothing -> insertMany_' vals0 Just maxParams -> do - let chunkSize = maxParams `div` length (entityFields t) + let chunkSize = maxParams `div` length (getEntityFieldsDatabase t) mapM_ insertMany_' (chunksOf chunkSize vals0) where insertMany_' vals = do @@ -373,11 +372,11 @@ let valss = map (map toPersistValue . toPersistFields) vals let sql = Text.concat [ "INSERT INTO " - , connEscapeRawName conn (unEntityNameDB $ entityDB t) + , connEscapeRawName conn (unEntityNameDB $ getEntityDBName t) , "(" - , Text.intercalate "," $ map (connEscapeRawName conn . unFieldNameDB . fieldDB) $ entityFields t + , Text.intercalate "," $ map (connEscapeRawName conn . unFieldNameDB . fieldDB) $ getEntityFieldsDatabase t , ") VALUES (" - , Text.intercalate "),(" $ replicate (length valss) $ Text.intercalate "," $ map (const "?") (entityFields t) + , Text.intercalate "),(" $ replicate (length valss) $ Text.intercalate "," $ map (const "?") (getEntityFieldsDatabase t) , ")" ] rawExecute sql (concat valss) @@ -390,9 +389,9 @@ let wher = whereStmtForKey conn k let sql = Text.concat [ "UPDATE " - , connEscapeRawName conn (unEntityNameDB $ entityDB t) + , connEscapeRawName conn (unEntityNameDB $ getEntityDBName t) , " SET " - , Text.intercalate "," (map (go conn . unFieldNameDB . fieldDB) $ entityFields t) + , Text.intercalate "," (map (go conn . unFieldNameDB . fieldDB) $ getEntityFieldsDatabase t) , " WHERE " , wher ] @@ -429,10 +428,10 @@ conn <- ask let wher = if null filts then "" - else filterClause False (SqlFor conn) filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , wher ] withRawQuery sql (getFiltsValues (SqlFor conn) filts) $ do @@ -461,17 +460,17 @@ t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" - else filterClause False (SqlFor conn) filts + else filterClause Nothing conn filts ord conn = case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> Text.intercalate "," ords - cols = Text.intercalate ", " . entityColumnNames t - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat + cols = Text.intercalate ", " . toList . keyAndEntityColumnNames t + sql conn = connLimitOffset conn (limit,offset) $ mconcat [ "SELECT " , cols conn , " FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , wher conn , ord (SqlFor conn) ] @@ -482,17 +481,17 @@ return $ fmap (.| CL.mapM parse) srcRes where t = entityDef $ dummyFromFilts filts - cols conn = Text.intercalate "," $ dbIdColumns conn t + cols conn = Text.intercalate "," $ toList $ dbIdColumns conn t wher conn = if null filts then "" - else filterClause False (SqlFor conn) filts - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat + else filterClause Nothing conn filts + sql conn = connLimitOffset conn (limit,offset) $ mconcat [ "SELECT " , cols conn , " FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , wher conn , ord conn ] @@ -512,8 +511,8 @@ [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> return xs Just pdef -> - let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs + let pks = map fieldHaskell $ toList $ compositeFields pdef + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFieldsDatabase t) xs in return keyvals case keyFromValues keyvals of Right k -> return k @@ -523,14 +522,14 @@ upsertBy uniqueKey record updates = specializeQuery $ do conn <- ask let escape = connEscapeRawName conn - let refCol n = Text.concat [escape (unEntityNameDB $ entityDB t), ".", n] + let refCol n = Text.concat [escape (unEntityNameDB $ getEntityDBName t), ".", n] let mkUpdateText = mkUpdateText' (escape . unFieldNameDB) refCol case connUpsertSql conn of Just upsertSql -> case updates of [] -> generalizeQuery $ defaultUpsertBy uniqueKey record updates _:_ -> do let upds = Text.intercalate "," $ map mkUpdateText updates - sql = upsertSql t (NEL.fromList $ persistUniqueToFieldNames uniqueKey) upds + sql = upsertSql t (persistUniqueToFieldNames uniqueKey) upds vals = map toPersistValue (toPersistFields record) ++ map updatePersistValue updates ++ unqs uniqueKey @@ -549,12 +548,12 @@ rawExecute sql' vals where t = entityDef $ dummyFromUnique uniq - go = map snd . persistUniqueToFieldNames + go = map snd . toList . persistUniqueToFieldNames go' conn x = connEscapeRawName conn (unFieldNameDB x) `mappend` "=?" sql conn = Text.concat [ "DELETE FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , " WHERE " , Text.intercalate " AND " $ map (go' conn) $ go uniq] @@ -564,9 +563,9 @@ let sql = Text.concat [ "SELECT " - , Text.intercalate "," $ dbColumns conn t + , Text.intercalate "," $ toList $ dbColumns conn t , " FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , " WHERE " , sqlClause conn] uvals = persistUniqueToValues uniq @@ -585,7 +584,7 @@ Text.intercalate " AND " $ map (go conn . unFieldNameDB) $ toFieldNames' uniq go conn x = connEscapeRawName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq - toFieldNames' = map snd . persistUniqueToFieldNames + toFieldNames' = map snd . toList . persistUniqueToFieldNames instance PersistQueryWrite (SqlFor db) where deleteWhere filts = do @@ -609,10 +608,10 @@ let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" - else filterClause False (SqlFor conn) filts + else filterClause Nothing conn filts sql = mconcat [ "DELETE FROM " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , wher ] rawExecuteCount sql $ getFiltsValues (SqlFor conn) filts @@ -629,10 +628,10 @@ conn <- ask let wher = if null filts then "" - else filterClause False (SqlFor conn) filts + else filterClause Nothing conn filts let sql = mconcat [ "UPDATE " - , connEscapeRawName conn $ unEntityNameDB $ entityDB t + , connEscapeRawName conn $ unEntityNameDB $ getEntityDBName t , " SET " , Text.intercalate "," $ map (go' conn . go) upds , wher @@ -664,7 +663,7 @@ whereStmtForKey conn k = Text.intercalate " AND " $ map (<> "=? ") - $ dbIdColumns conn entDef + $ toList $ dbIdColumns conn entDef where entDef = entityDef $ dummyFromKey k @@ -676,14 +675,14 @@ insrepHelper _ [] = return () insrepHelper command es = do conn <- ask - let columnNames = keyAndEntityColumnNames entDef conn + let columnNames = toList $ keyAndEntityColumnNames entDef conn rawExecute (sql conn columnNames) vals where entDef = entityDef $ map entityVal es sql conn columnNames = Text.concat [ command , " INTO " - , connEscapeRawName conn (unEntityNameDB $ entityDB entDef) + , connEscapeRawName conn (unEntityNameDB $ getEntityDBName entDef) , "(" , Text.intercalate "," columnNames , ") VALUES (" @@ -694,13 +693,6 @@ data OrNull = OrNullYes | OrNullNo -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlFor a) - => Bool -- ^ include table name? - -> SqlFor a - -> [Filter val] - -> Text -filterClause b c = fst . filterClauseHelper b True c OrNullNo - filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlFor a) => Bool -- ^ include table name? -> Bool -- ^ include WHERE? @@ -736,21 +728,21 @@ else case (allVals, pfilter, isCompFilter pfilter) of ([PersistList xs], Eq, _) -> - let sqlcl=Text.intercalate " and " (map (\a -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) + let sqlcl=Text.intercalate " and " (map (\a -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "? ") (toList $ compositeFields pdef)) in (wrapSql sqlcl,xs) ([PersistList xs], Ne, _) -> - let sqlcl=Text.intercalate " or " (map (\a -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) + let sqlcl=Text.intercalate " or " (map (\a -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "? ") (toList $ compositeFields pdef)) in (wrapSql sqlcl,xs) (_, In, _) -> let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) + sqls=map (\(a,xs) -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (toList $ compositeFields pdef) xxs) in (wrapSql (Text.intercalate " and " (map wrapSql sqls)), concat xxs) (_, NotIn, _) -> let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) + sqls=map (\(a,xs) -> connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (toList $ compositeFields pdef) xxs) in (wrapSql (Text.intercalate " or " (map wrapSql sqls)), concat xxs) ([PersistList xs], _, True) -> - let zs = tail (inits (compositeFields pdef)) + let zs = tail (inits (toList $ compositeFields pdef)) sql1 = map (\b -> wrapSql (Text.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs sql2 islast a = connEscapeRawName conn (unFieldNameDB $ fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " sqlcl = Text.intercalate " or " sql1 @@ -834,7 +826,7 @@ isNull = PersistNull `elem` allVals notNullVals = filter (/= PersistNull) allVals allVals = filterValueToPersistValues value - tn = connEscapeRawName conn $ unEntityNameDB $ entityDB + tn = connEscapeRawName conn $ unEntityNameDB $ getEntityDBName $ entityDef $ dummyFromFilts [Filter field value pfilter] name = (if includeTable @@ -881,7 +873,7 @@ dummyFromOrder :: SelectOpt a -> Maybe a dummyFromOrder _ = Nothing - tn = connEscapeRawName conn $ unEntityNameDB $ entityDB $ entityDef $ dummyFromOrder o + tn = connEscapeRawName conn $ unEntityNameDB $ getEntityDBName $ entityDef $ dummyFromOrder o name :: (PersistEntityBackend record ~ SqlFor a, PersistEntity record) => EntityField record typ -> Text diff --git a/test/EsqueletoSpec.hs b/test/EsqueletoSpec.hs --- a/test/EsqueletoSpec.hs +++ b/test/EsqueletoSpec.hs @@ -40,6 +40,12 @@ other_id Int |] +instance ToBackendKey (SqlFor TestDb) Foo where + toBackendKey = + unFooKey + fromBackendKey = + FooKey + spec :: Spec spec = do let typeChecks = True `shouldBe` True