summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorparsonsmatt <>2019-03-14 21:50:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-03-14 21:50:00 (GMT)
commitf87e1be87353417f0fafb8b4cea476b0fe33a330 (patch)
tree03e9e519933a96d27b37f059f6193cbcc6b0e381
version 0.0.1.00.0.1.0
-rw-r--r--CHANGELOG.md7
-rw-r--r--LICENSE30
-rwxr-xr-xREADME.md272
-rw-r--r--Setup.hs2
-rw-r--r--persistent-typed-db.cabal82
-rw-r--r--src/Database/Persist/Typed.hs927
-rw-r--r--test/EsqueletoSpec.hs69
-rw-r--r--test/Spec.hs1
8 files changed, 1390 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..5368eaa
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,7 @@
+# CHANGELOG
+
+# Upcoming
+
+# v0.0.1.0
+
+- Initial Release
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..6a042c2
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file
diff --git a/README.md b/README.md
new file mode 100755
index 0000000..5b3ceb9
--- /dev/null
+++ b/README.md
@@ -0,0 +1,272 @@
+# `persistent-typed-db`
+
+[![Build Status](https://travis-ci.org/parsonsmatt/persistent-typed-db.svg?branch=master)](https://travis-ci.org/parsonsmatt/persistent-typed-db)
+
+This library defines an alternate `SqlBackend` type for the Haskell [persistent](https://hackage.haskell.org/package/persistent) database library.
+The type has a phantom type parameter which allows you to write queries against multiple databases safely.
+
+# The Problem
+
+The `persistent` library uses a "handle pattern" with the `SqlBackend` type.
+The `SqlBackend` (or `Pool SqlBackend`) is used to provide access to "The Database."
+To access the database, you generally use a function like:
+
+```haskell
+runDB :: SqlPersistT m a -> App a
+```
+
+However, you may have two (or more!) databases.
+You might have multiple database "runner" functions, like this:
+
+```haskell
+runMainDB
+ :: SqlPersistT m a -> App a
+runAuxDB
+ :: SqlPersistT m a -> App a
+```
+
+Unfortunately, this isn't safe.
+The schemas differ, and there's nothing preventing you from using the wrong runner for the query at hand.
+
+This library allows you to differentiate between database schemata.
+To demonstrate usage, we'll start with a pair of ordinary `persistent` quasiquoter blocks:
+
+```haskell
+share [ mkPersist sqlSettings, mkMigrate "migrateAll" ] [persistLowerCase|
+
+User
+ name Text
+ age Int
+
+ deriving Show Eq
+|]
+
+share [ mkPersist sqlSettings, mkMigrate "migrateAll" ] [persistLowerCase|
+
+AuxRecord
+ createdAt UTCTime
+ reason Text
+
+ deriving Show Eq
+|]
+```
+
+These two definitions correspond to different databases.
+The `persistent` library uses the `SqlPersistT m` monad transformer for queries.
+This type is a synonym for `ReaderT SqlBackend m`.
+Many of the functions defined in `persistent` have a signature like this:
+
+```haskell
+get :: (MonadIO m, PersistEntityBackend record ~ backend)
+ => Key record
+ -> ReaderT backend m (Maybe record)
+```
+
+It requires that the entity is compatible with the query monad.
+We're going to substitute `User` for the type variable `record`.
+In the initial schema definition, the `PersistEntityBackend User` is defined as `SqlBackend`.
+So the type of `get`, in the original definition, is this:
+
+```haskell
+get :: (MonadIO m, PersistEntityBackend User ~ SqlBackend)
+ => Key record
+ -> ReaderT SqlBackend m (Maybe User)
+```
+
+If we look at the type of `get` specialized to `AuxRecord`, we see this:
+
+```haskell
+get :: (MonadIO m, PersistEntityBackend AuxRecord ~ SqlBackend)
+ => Key record
+ -> ReaderT SqlBackend m (Maybe AuxRecord)
+```
+
+This means that we might be able to write a query like this:
+
+```haskell
+impossibleQuery
+ :: MonadIO m
+ => SqlPersistT m (Maybe User, Maybe AuxRecord)
+impossibleQuery = do
+ muser <- get (UserKey 1)
+ maux <- get (AuxRecordKey 1)
+ pure (muser, maux)
+```
+
+This query will fail at runtime, since the entities exist on different schemata.
+Likewise, there's nothing in the types to stop you from running a query against
+the wrong backend:
+
+```haskell
+app = do
+ runMainDB $ get (AuxRecordKey 3)
+ runAuxDb $ get (UserKey 3)
+```
+
+# The Solution
+
+Let's solve this problem.
+
+## Declaring the Schema
+
+We are going to create an empty datatype tag for each schema, and then we're going to use `mkSqlSettingsFor` instead of `sqlSettings`.
+
+```haskell
+data MainDb
+data AuxDb
+
+share [ mkPersist (mkSqlSettingsFor ''MainDb), mkMigrate "migrateAll" ] [persistLowerCase|
+
+User
+ name Text
+ age Int
+
+ deriving Show Eq
+|]
+
+share [ mkPersist (mkSqlSettingsFor ''AuxDb), mkMigrate "migrateAll" ] [persistLowerCase|
+
+AuxRecord
+ createdAt UTCTime
+ reason Text
+
+ deriving Show Eq
+|]
+```
+
+This changes the type of the `PersistEntityBackend record` for each entity defined in the QuasiQuoter.
+The previous type of `PersistEntityBackend User` was `SqlBackend`, but with this change, it is now `SqlBackendFor MainDb`.
+Likewise, the type of `PersistEntityBackend AuxRecord` has become `SqlBackendFor AuxDb`.
+
+## Using the Schema
+
+Let's look at the new type of `get` for these two records:
+
+```haskell
+get :: (MonadIO m, PersistEntityBackend User ~ SqlBackendFor MainDb)
+ => Key record
+ -> ReaderT (SqlBackendFor MainDb) m (Maybe User)
+
+get :: (MonadIO m, PersistEntityBackend AuxRecord ~ SqlBackendFor AuxDb)
+ => Key record
+ -> ReaderT (SqlBackendFor AuxDb) m (Maybe AuxRecord)
+```
+
+Now that the monad type is different, we can't use them in the same query.
+Our previous `impossibleQuery` now fails with a type error.
+
+The `persistent-typed-db` library defines a type synonym for `ReaderT`.
+It is similar to the `SqlPersistT` synonym:
+
+```haskell
+type SqlPersistT = ReaderT SqlBackend
+type SqlPersistTFor db = ReaderT (SqlBackendFor db)
+```
+
+When using this library, it is a good idea to define a type snynonym for your databases as well.
+So we might also write:
+
+```haskell
+type MainDbT = SqlPersistTFor MainDb
+type AuxDbT = SqlPersistTFor AuxDb
+```
+
+The type of our runner functions has changed, as well.
+Before, we accepted a `SqlPersistT`, but now, we'll accept the right query type for the database:
+
+```haskell
+runMainDb :: MainDbT m a -> App a
+
+runAuxDb :: AuxDbT m a -> App a
+```
+
+We'll cover how to define these runner functions soon.
+
+## Defining the Runner Function
+
+`persistent` defines a function `runSqlPool` that is useful for running a SQL action.
+The type is essentially this:
+
+```haskell
+runSqlPool
+ :: (MonadUnliftIO m, IsSqlBackend backend)
+ => ReaderT backend m a
+ -> Pool backend
+ -> m a
+```
+
+`persistent-typed-db` defines a function that is a drop in replacement for this, called `runSqlPoolFor`.
+
+```haskell
+runSqlPoolFor
+ :: (MonadUnliftIO m)
+ => SqlPersistTFor db m a
+ -> ConnectionPoolFor db
+ -> m a
+```
+
+It is defined by generalizing the input query and pool, and delegating to `runSqlPool`.
+
+```haskell
+runSqlPoolFor query conn =
+ runSqlPool (generalizeQuery query) (generalizePool conn)
+```
+
+Sometimes, you'll have some function that is in `SqlPersistT` that you want to use on a specialized database.
+This can occur with raw queries, like `rawSql` and friends, or other queries/actions that are not tied to a `PersistEntityBackend` type.
+In this case, you'll want to use `specializeQuery`.
+You will likely want to define type-specified helpers that are aliases for `specializeQuery`:
+
+```haskell
+toMainQuery :: SqlPersistT m a -> MainDbT m a
+toMainQuery = specializeQuery
+
+toAuxQuery :: SqlPersistT m a -> AuxDbT m a
+toAuxQuery = specializeQuery
+```
+
+## Constructing the Pools
+
+`persistent` (and the relevant database-specific libraries) define many functions for creating connections.
+We'll use [`createPostgresqlPool`](https://hackage.haskell.org/package/persistent-postgresql-2.9.0/docs/Database-Persist-Postgresql.html#v:createPostgresqlPool) as an example.
+This is one place where you do need to be careful, as you are tagging the database pool with the database type.
+
+To create a specific database pool, we'll map `specializePool` over the result
+of `createPostgresqlPool`:
+
+```haskell
+createPostgresqlPoolFor
+ :: ConnectionString
+ -> Int
+ -> IO (ConnectionPoolFor db)
+createPostgresqlPoolFor connStr i =
+ specializePool <$> createPostgresqlPool connStr i
+```
+
+It is a good idea to make specialized variants of this function to improve type
+inference and errors:
+
+```haskell
+createMainPool :: ConnectionString -> Int -> IO (ConnectionPoolFor MainDb)
+createMainPool = createPostgresqlPoolFor
+
+createAuxPool :: ConnectionString -> Int -> IO (ConnectionPoolFor AuxDb)
+createAuxPool = createPostgresqlPoolFor
+```
+
+It is common to use `with`-style functions with these, as well.
+These functions automate closure of the database resources.
+We can specialize these functions similarly:
+
+```haskell
+withPoolFor
+ :: forall db m a
+ . (MonadLogger m, MonadUnliftIO m)
+ => ConnectionString
+ -> Int
+ -> (ConnectionPoolFor db -> m a)
+ -> m a
+withPoolFor connStr conns action =
+ withPostgresqlPool connStr conns $ \genericPool ->
+ action (specializePool genericPool)
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/persistent-typed-db.cabal b/persistent-typed-db.cabal
new file mode 100644
index 0000000..42fc4e0
--- /dev/null
+++ b/persistent-typed-db.cabal
@@ -0,0 +1,82 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.1.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 9ca3677808b2b77f7610f921cfb79cefbfe8d610360376b7b23b481af479b127
+
+name: persistent-typed-db
+version: 0.0.1.0
+synopsis: Type safe access to multiple database schemata.
+description: See README.md for more details, examples, and fun.
+category: Web
+homepage: https://github.com/parsonsmatt/persistent-typed-db#readme
+bug-reports: https://github.com/parsonsmatt/persistent-typed-db/issues
+author: Matt Parsons
+maintainer: parsonsmatt@gmail.com
+copyright: 2017 Matt Parsons
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ CHANGELOG.md
+
+source-repository head
+ type: git
+ location: https://github.com/parsonsmatt/persistent-typed-db
+
+library
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wcompat -Wincomplete-uni-patterns
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , bytestring
+ , conduit >=1.3.0
+ , http-api-data
+ , monad-logger
+ , path-pieces
+ , persistent >=2.8.0
+ , persistent-template
+ , resource-pool
+ , resourcet >=1.2.0
+ , template-haskell
+ , text
+ , transformers
+ exposed-modules:
+ Database.Persist.Typed
+ other-modules:
+ Paths_persistent_typed_db
+ default-language: Haskell2010
+
+test-suite specs
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs:
+ test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , bytestring
+ , conduit >=1.3.0
+ , esqueleto
+ , hspec
+ , http-api-data
+ , monad-logger
+ , path-pieces
+ , persistent >=2.8.0
+ , persistent-template
+ , persistent-typed-db
+ , resource-pool
+ , resourcet >=1.2.0
+ , template-haskell
+ , text
+ , transformers
+ other-modules:
+ EsqueletoSpec
+ Paths_persistent_typed_db
+ default-language: Haskell2010
diff --git a/src/Database/Persist/Typed.hs b/src/Database/Persist/Typed.hs
new file mode 100644
index 0000000..2dd84f9
--- /dev/null
+++ b/src/Database/Persist/Typed.hs
@@ -0,0 +1,927 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# 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.
+module Database.Persist.Typed
+ ( -- * Schema Definition
+ mkSqlSettingsFor
+ , SqlFor(..)
+ -- * Specialized aliases
+ , SqlPersistTFor
+ , ConnectionPoolFor
+ , SqlPersistMFor
+ -- * Running specialized queries
+ , runSqlPoolFor
+ , runSqlConnFor
+ -- * Specializing and generalizing
+ , generalizePool
+ , specializePool
+ , generalizeQuery
+ , specializeQuery
+ , generalizeSqlBackend
+ , specializeSqlBackend
+ -- * Key functions
+ , toSqlKeyFor
+ , 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 Data.Int (Int64)
+import Data.List (find, inits, transpose)
+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 (dbColumns, dbIdColumns,
+ entityColumnNames,
+ isIdField,
+ keyAndEntityColumnNames,
+ parseEntityValues)
+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.
+--
+-- @since 0.0.1.0
+newtype SqlFor db = SqlFor { unSqlFor :: SqlBackend }
+
+instance BackendCompatible SqlBackend (SqlFor db) where
+ projectBackend = unSqlFor
+
+-- | This type signature represents a database query for a specific database.
+-- You will likely want to specialize this to your own application for
+-- readability:
+--
+-- @
+-- data MainDb
+--
+-- type MainQueryT = 'SqlPersistTFor' MainDb
+--
+-- getStuff :: 'MonadIO' m => StuffId -> MainQueryT m (Maybe Stuff)
+-- @
+--
+-- @since 0.0.1.0
+type SqlPersistTFor db = ReaderT (SqlFor db)
+
+-- | A 'Pool' of database connections that are specialized to a specific
+-- database.
+--
+-- @since 0.0.1.0
+type ConnectionPoolFor db = Pool (SqlFor db)
+--
+-- | A specialization of 'SqlPersistM' that uses the underlying @db@ database
+-- type.
+--
+-- @since 0.0.1.0
+type SqlPersistMFor db = ReaderT (SqlFor db) (NoLoggingT (ResourceT IO))
+
+-- | Specialize a query to a specific database. You should define aliases for
+-- this function for each database you use.
+--
+-- @
+-- data MainDb
+--
+-- data AccountDb
+--
+-- mainQuery :: 'ReaderT' 'SqlBackend' m a -> 'ReaderT' ('SqlFor' MainDb) m a
+-- mainQuery = 'specializeQuery'
+--
+-- accountQuery :: 'ReaderT' 'SqlBackend' m a -> 'ReaderT' ('SqlFor' AccountDb) m a
+-- accountQuery = 'specializeQuery'
+-- @
+--
+-- @since 0.0.1.0
+specializeQuery :: forall db m a. SqlPersistT m a -> SqlPersistTFor db m a
+specializeQuery = withReaderT unSqlFor
+
+-- | Generalizes a query from a specific database to one that is database
+-- agnostic.
+--
+-- @since 0.0.1.0
+generalizeQuery :: forall db m a. SqlPersistTFor db m a -> SqlPersistT m a
+generalizeQuery = withReaderT SqlFor
+
+-- | Use the 'SqlFor' type for the database connection backend. Use this instead
+-- of 'sqlSettings' and provide a quoted type name.
+--
+-- @
+-- data MainDb
+--
+-- share [ mkPersist (mkSqlSettingsFor ''MainDb), mkMigrate "migrateAll" ] [persistLowerCase|
+--
+-- User
+-- name Text
+-- age Int
+--
+-- deriving Show Eq
+-- |]
+-- @
+--
+-- The entities generated will have the 'PersistEntityBackend' defined to be
+-- @'SqlFor' MainDb@ instead of 'SqlBackend'. This is what provides the type
+-- safety.
+--
+-- @since 0.0.1.0
+mkSqlSettingsFor :: Name -> MkPersistSettings
+mkSqlSettingsFor n = mkPersistSettings (AppT (ConT ''SqlFor) (ConT n))
+
+-- | Persistent's @toSqlKey@ and @fromSqlKey@ hardcode the 'SqlBackend', so we
+-- have to reimplement them here.
+--
+-- @since 0.0.1.0
+toSqlKeyFor :: (ToBackendKey (SqlFor a) record) => Int64 -> Key record
+toSqlKeyFor = fromBackendKey . SqlForKey . SqlBackendKey
+
+-- | Persistent's @toSqlKey@ and @fromSqlKey@ hardcode the 'SqlBackend', so we
+-- have to reimplement them here.
+--
+-- @since 0.0.1.0
+fromSqlKeyFor :: ToBackendKey (SqlFor a) record => Key record -> Int64
+fromSqlKeyFor = unSqlBackendKey . unSqlForKey . toBackendKey
+
+-- | Specialize a 'ConnectionPool' to a @'Pool' ('SqlFor' db)@. You should apply
+-- this whenever you create or initialize the database connection pooling to
+-- avoid potentially mixing the database pools up.
+--
+-- @since 0.0.1.0
+specializePool :: ConnectionPool -> ConnectionPoolFor db
+specializePool = coerce
+
+-- | Generalize a @'Pool' ('SqlFor' db)@ to an ordinary 'ConnectionPool'. This
+-- renders the pool unusable for model-specific code that relies on the type
+-- safety, but allows you to use it for general-purpose SQL queries.
+--
+-- @since 0.0.1.0
+generalizePool :: ConnectionPoolFor db -> ConnectionPool
+generalizePool = coerce
+
+-- | Specializes a 'SqlBackend' for a specific database.
+--
+-- @since 0.0.1.0
+specializeSqlBackend :: SqlBackend -> SqlFor db
+specializeSqlBackend = SqlFor
+
+-- | Generalizes a 'SqlFor' backend to be database agnostic.
+--
+-- @since 0.0.1.0
+generalizeSqlBackend :: SqlFor db -> SqlBackend
+generalizeSqlBackend = unSqlFor
+
+-- | Run a 'SqlPersistTFor' action on an appropriate database.
+--
+-- @since 0.0.1.0
+runSqlPoolFor
+ :: MonadUnliftIO m
+ => SqlPersistTFor db m a
+ -> ConnectionPoolFor db
+ -> m a
+runSqlPoolFor query conn =
+ runSqlPool (generalizeQuery query) (generalizePool conn)
+
+-- | Run a 'SqlPersistTFor' action on the appropriate database connection.
+--
+-- @since 0.0.1.0
+runSqlConnFor
+ :: MonadUnliftIO m
+ => SqlPersistTFor db m a
+ -> SqlFor db
+ -> m a
+runSqlConnFor query conn =
+ runSqlConn (generalizeQuery query) (generalizeSqlBackend conn)
+
+-- The following instances are almost entirely copy-pasted from the Persistent
+-- library for SqlBackend.
+instance HasPersistBackend (SqlFor a) where
+ type BaseBackend (SqlFor a) = SqlFor a
+ persistBackend = id
+
+instance IsPersistBackend (SqlFor a) where
+ mkPersistBackend = id
+
+instance PersistCore (SqlFor a) where
+ newtype BackendKey (SqlFor a) =
+ SqlForKey { unSqlForKey :: BackendKey SqlBackend }
+ deriving ( Show, Read, Eq, Ord, Num, Integral, PersistField
+ , PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData
+ , Real, Enum, Bounded, A.ToJSON, A.FromJSON
+ )
+
+instance PersistStoreRead (SqlFor a) where
+ get k = do
+ conn <- asks unSqlFor
+ let t = entityDef $ dummyFromKey k
+ let cols = Text.intercalate ","
+ $ map (connEscapeName conn . fieldDB) $ entityFields t
+ noColumns :: Bool
+ noColumns = null $ entityFields t
+ let wher = whereStmtForKey conn k
+ let sql = Text.concat
+ [ "SELECT "
+ , if noColumns then "*" else cols
+ , " FROM "
+ , connEscapeName conn $ entityDB t
+ , " WHERE "
+ , wher
+ ]
+ flip runReaderT conn $ withRawQuery sql (keyToValues k) $ do
+ res <- CL.head
+ case res of
+ Nothing -> return Nothing
+ Just vals ->
+ case fromPersistValues $ if noColumns then [] else vals of
+ Left e -> error $ "get " ++ show k ++ ": " ++ Text.unpack e
+ Right v -> return $ Just v
+
+instance PersistStoreWrite (SqlFor a) where
+ update _ [] = return ()
+ update k upds = specializeQuery $ do
+ conn <- ask
+ let go'' n Assign = n <> "=?"
+ go'' n Add = Text.concat [n, "=", n, "+?"]
+ go'' n Subtract = Text.concat [n, "=", n, "-?"]
+ go'' n Multiply = Text.concat [n, "=", n, "*?"]
+ go'' n Divide = Text.concat [n, "=", n, "/?"]
+ go'' _ (BackendSpecificUpdate up) = error $ Text.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported"
+ let go' (x, pu) = go'' (connEscapeName conn x) pu
+ let wher = whereStmtForKey conn k
+ let sql = Text.concat
+ [ "UPDATE "
+ , connEscapeName conn $ tableDBName $ recordTypeFromKey k
+ , " SET "
+ , Text.intercalate "," $ map (go' . go) upds
+ , " WHERE "
+ , wher
+ ]
+ rawExecute sql $
+ map updatePersistValue upds `mappend` keyToValues k
+ where
+ go x = (fieldDB $ updateFieldDef x, updateUpdate x)
+
+ insert val = specializeQuery $ do
+ conn <- ask
+ case connInsertSql conn t vals of
+ ISRSingle sql -> withRawQuery sql vals $ do
+ x <- CL.head
+ case x of
+ Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of
+ Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` Text.unpack err
+ Right k -> return k
+ Nothing -> error "SQL insert did not return a result giving the generated ID"
+ Just vals' -> case keyFromValues vals' of
+ Left _ -> error $ "Invalid result from a SQL insert, got: " ++ show vals'
+ Right k -> return k
+
+ ISRInsertGet sql1 sql2 -> do
+ rawExecute sql1 vals
+ withRawQuery sql2 [] $ do
+ mm <- CL.head
+ let m = maybe
+ (Left $ "No results from ISRInsertGet: " `mappend` tshow (sql1, sql2))
+ Right mm
+
+ -- TODO: figure out something better for MySQL
+ let convert x =
+ case x of
+ [PersistByteString i] -> case readInteger i of -- mssql
+ Just (ret,"") -> [PersistInt64 $ fromIntegral ret]
+ _ -> x
+ _ -> x
+ -- Yes, it's just <|>. Older bases don't have the
+ -- instance for Either.
+ onLeft Left{} x = x
+ onLeft x _ = x
+
+ case m >>= (\x -> keyFromValues x `onLeft` keyFromValues (convert x)) of
+ Right k -> return k
+ Left err -> throw $ "ISRInsertGet: keyFromValues failed: " `mappend` err
+ ISRManyKeys sql fs -> do
+ rawExecute sql vals
+ 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
+ in case keyFromValues keyvals of
+ Right k -> return k
+ Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` Text.unpack e
+ where
+ tshow :: Show a => a -> Text
+ tshow = Text.pack . show
+ throw = liftIO . throwIO . userError . Text.unpack
+ t = entityDef $ Just val
+ vals = map toPersistValue $ toPersistFields val
+
+ insertMany [] = return []
+ insertMany vals = specializeQuery $ do
+ conn <- ask
+
+ case connInsertManySql conn of
+ Nothing -> withReaderT SqlFor $ mapM insert vals
+ Just insertManyFn ->
+ case insertManyFn ent valss of
+ ISRSingle sql -> rawSql sql (concat valss)
+ _ -> error "ISRSingle is expected from the connInsertManySql function"
+ where
+ ent = entityDef vals
+ valss = map (map toPersistValue . toPersistFields) vals
+
+
+
+ insertMany_ [] = return ()
+ insertMany_ vals0 = specializeQuery $ do
+ conn <- ask
+ case connMaxParams conn of
+ Nothing -> insertMany_' vals0
+ Just maxParams -> do
+ let chunkSize = maxParams `div` length (entityFields t)
+ mapM_ insertMany_' (chunksOf chunkSize vals0)
+ where
+ insertMany_' vals = do
+ conn <- ask
+ let valss = map (map toPersistValue . toPersistFields) vals
+ let sql = Text.concat
+ [ "INSERT INTO "
+ , connEscapeName conn (entityDB t)
+ , "("
+ , Text.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t
+ , ") VALUES ("
+ , Text.intercalate "),(" $ replicate (length valss) $ Text.intercalate "," $ map (const "?") (entityFields t)
+ , ")"
+ ]
+ rawExecute sql (concat valss)
+
+ t = entityDef vals0
+ -- Implement this here to avoid depending on the split package
+ chunksOf _ [] = []
+ chunksOf size xs = let (chunk, rest) = splitAt size xs in chunk : chunksOf size rest
+
+ replace k val = do
+ conn <- asks unSqlFor
+ let t = entityDef $ Just val
+ let wher = whereStmtForKey conn k
+ let sql = Text.concat
+ [ "UPDATE "
+ , connEscapeName conn (entityDB t)
+ , " SET "
+ , Text.intercalate "," (map (go conn . fieldDB) $ entityFields t)
+ , " WHERE "
+ , wher
+ ]
+ vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k
+ specializeQuery $ rawExecute sql vals
+ where
+ go conn x = connEscapeName conn x `Text.append` "=?"
+
+ insertKey k = specializeQuery . insrepHelper "INSERT" k
+
+ repsert key value = do
+ mExisting <- get key
+ case mExisting of
+ Nothing -> insertKey key value
+ Just _ -> replace key value
+
+ delete k = do
+ conn <- asks unSqlFor
+ specializeQuery $ rawExecute (sql conn) (keyToValues k)
+ where
+ wher conn = whereStmtForKey conn k
+ sql conn = Text.concat
+ [ "DELETE FROM "
+ , connEscapeName conn $ tableDBName $ recordTypeFromKey k
+ , " WHERE "
+ , wher conn
+ ]
+
+-- orphaned instance for convenience of modularity
+instance PersistQueryRead (SqlFor a) where
+ count filts = specializeQuery $ do
+ conn <- ask
+ let wher = if null filts
+ then ""
+ else filterClause False (SqlFor conn) filts
+ let sql = mconcat
+ [ "SELECT COUNT(*) FROM "
+ , connEscapeName conn $ entityDB t
+ , wher
+ ]
+ withRawQuery sql (getFiltsValues (SqlFor conn) filts) $ do
+ mm <- CL.head
+ case mm of
+ Just [PersistInt64 i] -> return $ fromIntegral i
+ Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle
+ Just [PersistByteString i] -> case readInteger i of -- gb mssql
+ Just (ret,"") -> return $ fromIntegral ret
+ xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"
+ Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]"
+ Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]"
+ where
+ t = entityDef $ dummyFromFilts filts
+
+ selectSourceRes filts opts = specializeQuery $ do
+ conn <- ask
+ srcRes <- rawQueryRes (sql conn) (getFiltsValues (SqlFor conn) filts)
+ return $ fmap (.| CL.mapM parse) srcRes
+ where
+ (limit, offset, orders) = limitOffsetOrder opts
+
+ parse vals = case parseEntityValues t vals of
+ Left s -> liftIO $ throwIO $ PersistMarshalError s
+ Right row -> return row
+ t = entityDef $ dummyFromFilts filts
+ wher conn = if null filts
+ then ""
+ else filterClause False (SqlFor 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
+ [ "SELECT "
+ , cols conn
+ , " FROM "
+ , connEscapeName conn $ entityDB t
+ , wher conn
+ , ord (SqlFor conn)
+ ]
+
+ selectKeysRes filts opts = specializeQuery $ do
+ conn <- ask
+ srcRes <- rawQueryRes (sql conn) (getFiltsValues (SqlFor conn) filts)
+ return $ fmap (.| CL.mapM parse) srcRes
+ where
+ t = entityDef $ dummyFromFilts filts
+ cols conn = Text.intercalate "," $ 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
+ [ "SELECT "
+ , cols conn
+ , " FROM "
+ , connEscapeName conn $ entityDB t
+ , wher conn
+ , ord conn
+ ]
+
+ (limit, offset, orders) = limitOffsetOrder opts
+
+ ord conn =
+ case map (orderClause False (SqlFor conn)) orders of
+ [] -> ""
+ ords -> " ORDER BY " <> Text.intercalate "," ords
+
+ parse xs = do
+ keyvals <- case entityPrimary t of
+ Nothing ->
+ case xs of
+ [PersistInt64 x] -> return [PersistInt64 x]
+ [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
+ in return keyvals
+ case keyFromValues keyvals of
+ Right k -> return k
+ Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err
+
+instance PersistUniqueWrite (SqlFor db) where
+ upsert record updates = specializeQuery $ do
+ conn <- ask
+ uniqueKey <- withReaderT SqlFor $ onlyUnique record
+ case connUpsertSql conn of
+ Just upsertSql -> case updates of
+ [] -> withReaderT SqlFor $ defaultUpsert record updates
+ _:_ -> do
+ let upds = Text.intercalate "," $ map (go' . go) updates
+ sql = upsertSql t upds
+ vals = map toPersistValue (toPersistFields record)
+ ++ map updatePersistValue updates
+ ++ unqs uniqueKey
+
+ go'' n Assign = n <> "=?"
+ go'' n Add = Text.concat [n, "=", escape (entityDB t) <> ".", n, "+?"]
+ go'' n Subtract = Text.concat [n, "=", escape (entityDB t) <> ".", n, "-?"]
+ go'' n Multiply = Text.concat [n, "=", escape (entityDB t) <> ".", n, "*?"]
+ go'' n Divide = Text.concat [n, "=", escape (entityDB t) <> ".", n, "/?"]
+ go'' _ (BackendSpecificUpdate up) = error $ Text.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported"
+
+ go' (x, pu) = go'' (connEscapeName conn x) pu
+ go x = (fieldDB $ updateFieldDef x, updateUpdate x)
+
+ x <- rawSql sql vals
+ return $ head x
+ Nothing -> withReaderT SqlFor $ defaultUpsert record updates
+ where
+ t = entityDef $ Just record
+ unqs uniqueKey = concatMap persistUniqueToValues [uniqueKey]
+
+ deleteBy uniq = specializeQuery $ do
+ conn <- ask
+ let sql' = sql conn
+ vals = persistUniqueToValues uniq
+ rawExecute sql' vals
+ where
+ t = entityDef $ dummyFromUnique uniq
+ go = map snd . persistUniqueToFieldNames
+ go' conn x = connEscapeName conn x `mappend` "=?"
+ sql conn =
+ Text.concat
+ [ "DELETE FROM "
+ , connEscapeName conn $ entityDB t
+ , " WHERE "
+ , Text.intercalate " AND " $ map (go' conn) $ go uniq]
+
+
+instance PersistUniqueRead (SqlFor a) where
+ getBy uniq = specializeQuery $ do
+ conn <- ask
+ let sql =
+ Text.concat
+ [ "SELECT "
+ , Text.intercalate "," $ dbColumns conn t
+ , " FROM "
+ , connEscapeName conn $ entityDB t
+ , " WHERE "
+ , sqlClause conn]
+ uvals = persistUniqueToValues uniq
+ withRawQuery sql uvals $
+ do row <- CL.head
+ case row of
+ Nothing -> return Nothing
+ Just [] -> error "getBy: empty row"
+ Just vals ->
+ case parseEntityValues t vals of
+ Left err ->
+ liftIO $ throwIO $ PersistMarshalError err
+ Right r -> return $ Just r
+ where
+ sqlClause conn =
+ Text.intercalate " AND " $ map (go conn) $ toFieldNames' uniq
+ go conn x = connEscapeName conn x `mappend` "=?"
+ t = entityDef $ dummyFromUnique uniq
+ toFieldNames' = map snd . persistUniqueToFieldNames
+
+instance PersistQueryWrite (SqlFor db) where
+ deleteWhere filts = do
+ _ <- deleteWhereCount filts
+ return ()
+ updateWhere filts upds = do
+ _ <- updateWhereCount filts upds
+ return ()
+ --
+-- Here be dragons! These are functions, types, and helpers that were vendored
+-- from Persistent.
+
+-- | Same as 'deleteWhere', but returns the number of rows affected.
+--
+--
+deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlFor db)
+ => [Filter val]
+ -> ReaderT (SqlFor db) m Int64
+deleteWhereCount filts = withReaderT unSqlFor $ do
+ conn <- ask
+ let t = entityDef $ dummyFromFilts filts
+ let wher = if null filts
+ then ""
+ else filterClause False (SqlFor conn) filts
+ sql = mconcat
+ [ "DELETE FROM "
+ , connEscapeName conn $ entityDB t
+ , wher
+ ]
+ rawExecuteCount sql $ getFiltsValues (SqlFor conn) filts
+
+-- | Same as 'updateWhere', but returns the number of rows affected.
+--
+-- @since 1.1.5
+updateWhereCount :: (PersistEntity val, MonadIO m, SqlFor db ~ PersistEntityBackend val)
+ => [Filter val]
+ -> [Update val]
+ -> ReaderT (SqlFor db) m Int64
+updateWhereCount _ [] = return 0
+updateWhereCount filts upds = withReaderT unSqlFor $ do
+ conn <- ask
+ let wher = if null filts
+ then ""
+ else filterClause False (SqlFor conn) filts
+ let sql = mconcat
+ [ "UPDATE "
+ , connEscapeName conn $ entityDB t
+ , " SET "
+ , Text.intercalate "," $ map (go' conn . go) upds
+ , wher
+ ]
+ let dat = map updatePersistValue upds `Data.Monoid.mappend`
+ getFiltsValues (SqlFor conn) filts
+ rawExecuteCount sql dat
+ where
+ t = entityDef $ dummyFromFilts filts
+ go'' n Assign = n <> "=?"
+ go'' n Add = mconcat [n, "=", n, "+?"]
+ go'' n Subtract = mconcat [n, "=", n, "-?"]
+ go'' n Multiply = mconcat [n, "=", n, "*?"]
+ go'' n Divide = mconcat [n, "=", n, "/?"]
+ go'' _ (BackendSpecificUpdate up) = error $ Text.unpack $ "BackendSpecificUpdate" `mappend` up `mappend` "not supported"
+ go' conn (x, pu) = go'' (connEscapeName conn x) pu
+ go x = (updateField' x, updateUpdate x)
+
+ updateField' (Update f _ _) = fieldName f
+ updateField' _ = error "BackendUpdate not implemented"
+
+dummyFromKey :: Key record -> Maybe record
+dummyFromKey = Just . recordTypeFromKey
+
+recordTypeFromKey :: Key record -> record
+recordTypeFromKey _ = error "dummyFromKey"
+
+whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text
+whereStmtForKey conn k =
+ Text.intercalate " AND "
+ $ map (<> "=? ")
+ $ dbIdColumns conn entDef
+ where
+ entDef = entityDef $ dummyFromKey k
+
+
+insrepHelper :: (MonadIO m, PersistEntity val)
+ => Text
+ -> Key val
+ -> val
+ -> ReaderT SqlBackend m ()
+insrepHelper command k record = do
+ conn <- ask
+ let columnNames = keyAndEntityColumnNames entDef conn
+ rawExecute (sql conn columnNames) vals
+ where
+ entDef = entityDef $ Just record
+ sql conn columnNames = Text.concat
+ [ command
+ , " INTO "
+ , connEscapeName conn (entityDB entDef)
+ , "("
+ , Text.intercalate "," columnNames
+ , ") VALUES("
+ , Text.intercalate "," (map (const "?") columnNames)
+ , ")"
+ ]
+ vals = entityValues (Entity k record)
+
+updateFieldDef :: PersistEntity v => Update v -> FieldDef
+updateFieldDef (Update f _ _) =
+ persistFieldDef f
+updateFieldDef BackendUpdate {} =
+ error "updateFieldDef did not expect BackendUpdate"
+
+
+updatePersistValue :: Update v -> PersistValue
+updatePersistValue (Update _ v _) =
+ toPersistValue v
+updatePersistValue BackendUpdate {} =
+ error "updatePersistValue did not expect BackendUpdate"
+
+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?
+ -> SqlFor a
+ -> OrNull
+ -> [Filter val]
+ -> (Text, [PersistValue])
+filterClauseHelper includeTable includeWhere (SqlFor conn) orNull filters =
+ (if not (Text.null sql) && includeWhere
+ then " WHERE " <> sql
+ else sql, vals)
+ where
+ (sql, vals) = combineAND filters
+ combineAND = combine " AND "
+
+ combine s fs =
+ (Text.intercalate s $ map wrapP a, mconcat b)
+ where
+ (a, b) = unzip $ map go fs
+ wrapP x = Text.concat ["(", x, ")"]
+
+ go (BackendFilter _) = error "BackendFilter not expected"
+ go (FilterAnd []) = ("1=1", [])
+ go (FilterAnd fs) = combineAND fs
+ go (FilterOr []) = ("1=0", [])
+ go (FilterOr fs) = combine " OR " fs
+ go (Filter field value pfilter) =
+ let t = entityDef $ dummyFromFilts [Filter field value pfilter]
+ in case (isIdField field, entityPrimary t, allVals) of
+ (True, Just pdef, PersistList ys:_) ->
+ if length (compositeFields pdef) /= length ys
+ then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals
+ else
+ case (allVals, pfilter, isCompFilter pfilter) of
+ ([PersistList xs], Eq, _) ->
+ let sqlcl=Text.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef))
+ in (wrapSql sqlcl,xs)
+ ([PersistList xs], Ne, _) ->
+ let sqlcl=Text.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef))
+ in (wrapSql sqlcl,xs)
+ (_, In, _) ->
+ let xxs = transpose (map fromPersistList allVals)
+ sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
+ in (wrapSql (Text.intercalate " and " (map wrapSql sqls)), concat xxs)
+ (_, NotIn, _) ->
+ let xxs = transpose (map fromPersistList allVals)
+ sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> Text.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
+ in (wrapSql (Text.intercalate " or " (map wrapSql sqls)), concat xxs)
+ ([PersistList xs], _, True) ->
+ let zs = tail (inits (compositeFields pdef))
+ sql1 = map (\b -> wrapSql (Text.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs
+ sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "
+ sqlcl = Text.intercalate " or " sql1
+ in (wrapSql sqlcl, concat (tail (inits xs)))
+ (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"
+ _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals
+ (True, Just pdef, []) ->
+ error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
+ (True, Just pdef, _) ->
+ error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
+
+ _ -> case (isNull, pfilter, length notNullVals) of
+ (True, Eq, _) -> (name <> " IS NULL", [])
+ (True, Ne, _) -> (name <> " IS NOT NULL", [])
+ (False, Ne, _) -> (Text.concat
+ [ "("
+ , name
+ , " IS NULL OR "
+ , name
+ , " <> "
+ , qmarks
+ , ")"
+ ], notNullVals)
+ -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since
+ -- not all databases support those words directly.
+ (_, In, 0) -> ("1=2" <> orNullSuffix, [])
+ (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)
+ (True, In, _) -> (Text.concat
+ [ "("
+ , name
+ , " IS NULL OR "
+ , name
+ , " IN "
+ , qmarks
+ , ")"
+ ], notNullVals)
+ (False, NotIn, 0) -> ("1=1", [])
+ (True, NotIn, 0) -> (name <> " IS NOT NULL", [])
+ (False, NotIn, _) -> (Text.concat
+ [ "("
+ , name
+ , " IS NULL OR "
+ , name
+ , " NOT IN "
+ , qmarks
+ , ")"
+ ], notNullVals)
+ (True, NotIn, _) -> (Text.concat
+ [ "("
+ , name
+ , " IS NOT NULL AND "
+ , name
+ , " NOT IN "
+ , qmarks
+ , ")"
+ ], notNullVals)
+ _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)
+
+ where
+ isCompFilter Lt = True
+ isCompFilter Le = True
+ isCompFilter Gt = True
+ isCompFilter Ge = True
+ isCompFilter _ = False
+
+ wrapSql sqlcl = "(" <> sqlcl <> ")"
+ fromPersistList (PersistList xs) = xs
+ fromPersistList other = error $ "expected PersistList but found " ++ show other
+
+ filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]
+ filterValueToPersistValues v = map toPersistValue $ either return id v
+
+ orNullSuffix =
+ case orNull of
+ OrNullYes -> mconcat [" OR ", name, " IS NULL"]
+ OrNullNo -> ""
+
+ isNull = PersistNull `elem` allVals
+ notNullVals = filter (/= PersistNull) allVals
+ allVals = filterValueToPersistValues value
+ tn = connEscapeName conn $ entityDB
+ $ entityDef $ dummyFromFilts [Filter field value pfilter]
+ name =
+ (if includeTable
+ then ((tn <> ".") <>)
+ else id)
+ $ connEscapeName conn $ fieldName field
+ qmarks = case value of
+ Left _ -> "?"
+ Right x ->
+ let x' = filter (/= PersistNull) $ map toPersistValue x
+ in "(" <> Text.intercalate "," (map (const "?") x') <> ")"
+ showSqlFilter Eq = "="
+ showSqlFilter Ne = "<>"
+ showSqlFilter Gt = ">"
+ showSqlFilter Lt = "<"
+ showSqlFilter Ge = ">="
+ showSqlFilter Le = "<="
+ showSqlFilter In = " IN "
+ showSqlFilter NotIn = " NOT IN "
+ showSqlFilter (BackendSpecificFilter s) = s
+
+dummyFromFilts :: [Filter v] -> Maybe v
+dummyFromFilts _ = Nothing
+
+fieldName :: forall record typ a. (PersistEntity record, PersistEntityBackend record ~ SqlFor a) => EntityField record typ -> DBName
+fieldName f = fieldDB $ persistFieldDef f
+
+
+getFiltsValues :: forall val a. (PersistEntity val, PersistEntityBackend val ~ SqlFor a)
+ => SqlFor a -> [Filter val] -> [PersistValue]
+getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo
+
+orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlFor a)
+ => Bool -- ^ include the table name
+ -> SqlFor a
+ -> SelectOpt val
+ -> Text
+orderClause includeTable (SqlFor conn) o =
+ case o of
+ Asc x -> name x
+ Desc x -> name x <> " DESC"
+ _ -> error "orderClause: expected Asc or Desc, not limit or offset"
+ where
+ dummyFromOrder :: SelectOpt a -> Maybe a
+ dummyFromOrder _ = Nothing
+
+ tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o
+
+ name :: (PersistEntityBackend record ~ SqlFor a, PersistEntity record)
+ => EntityField record typ -> Text
+ name x =
+ (if includeTable
+ then ((tn <> ".") <>)
+ else id)
+ $ connEscapeName conn $ fieldName x
+
+defaultUpsert
+ :: (MonadIO m
+ ,PersistEntity record
+ ,PersistUniqueWrite backend
+ ,PersistEntityBackend record ~ BaseBackend backend)
+ => record -> [Update record] -> ReaderT backend m (Entity record)
+defaultUpsert record updates = do
+ uniqueKey <- onlyUnique record
+ upsertBy uniqueKey record updates
+
+dummyFromUnique :: Unique v -> Maybe v
+dummyFromUnique _ = Nothing
+
+escape :: DBName -> Text.Text
+escape (DBName s) = Text.pack $ '"' : escapeQuote (Text.unpack s) ++ "\""
+ where
+ escapeQuote "" = ""
+ escapeQuote ('"':xs) = "\"\"" ++ escapeQuote xs
+ escapeQuote (x:xs) = x : escapeQuote xs
diff --git a/test/EsqueletoSpec.hs b/test/EsqueletoSpec.hs
new file mode 100644
index 0000000..0ca76e8
--- /dev/null
+++ b/test/EsqueletoSpec.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module EsqueletoSpec where
+
+import Database.Persist.Typed
+import Database.Esqueleto
+import Database.Persist.TH
+import Test.Hspec
+
+data TestDb
+
+share [mkPersist (mkSqlSettingsFor ''TestDb)] [persistLowerCase|
+
+Person
+ name String
+ age Int
+ deriving Show Eq
+
+Dog
+ name String
+ owner PersonId
+ deriving Show Eq
+
+Foo
+ Id sql=other_id
+ other_id Int
+ |]
+
+spec :: Spec
+spec = do
+ let typeChecks = True `shouldBe` True
+ describe "select" $
+ it "type checks" $ do
+ let q :: SqlPersistMFor TestDb [(Entity Person, Entity Dog)]
+ q = select $
+ from $ \(p `InnerJoin` d) -> do
+ on (p ^. PersonId ==. d ^. DogOwner)
+ pure (p, d)
+ typeChecks
+
+ describe "update" $
+ it "type checks" $ do
+ let q :: SqlPersistMFor TestDb ()
+ q = update $ \p -> do
+ set p [ PersonName =. val "world" ]
+ where_ (p ^. PersonName ==. val "hello")
+ typeChecks
+
+ describe "delete" $
+ it "type checks" $ do
+ let q :: SqlPersistMFor TestDb ()
+ q = delete $ from $ \p -> where_ (p ^. PersonName ==. val "world")
+ typeChecks
+
+ describe "issue #2" $ do
+ it "type checks" $ do
+ let k = toSqlKeyFor 3 :: Key Foo
+ typeChecks
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}