persistent-typed-db 0.1.0.3 → 0.1.0.4
raw patch · 4 files changed
+96/−93 lines, 4 filesdep −persistent-templatedep ~persistentPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: persistent-template
Dependency ranges changed: persistent
API changes (from Hackage documentation)
- Database.Persist.Typed: instance Database.Persist.Class.PersistStore.BackendCompatible Database.Persist.Sql.Types.Internal.SqlBackend (Database.Persist.Typed.SqlFor db)
+ Database.Persist.Typed: data family BackendKey backend
+ Database.Persist.Typed: instance Database.Persist.Class.PersistStore.BackendCompatible Database.Persist.SqlBackend.Internal.SqlBackend (Database.Persist.Typed.SqlFor db)
Files
- CHANGELOG.md +4/−0
- persistent-typed-db.cabal +5/−4
- src/Database/Persist/Typed.hs +81/−89
- test/EsqueletoSpec.hs +6/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # CHANGELOG +# 0.1.0.4++- Support `persistent-2.13`+ # 0.1.0.3 - Support `persistent-2.12`
persistent-typed-db.cabal view
@@ -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
src/Database/Persist/Typed.hs view
@@ -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
test/EsqueletoSpec.hs view
@@ -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