persistent-typed-db (empty) → 0.0.1.0
raw patch · 8 files changed
+1390/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, conduit, esqueleto, hspec, http-api-data, monad-logger, path-pieces, persistent, persistent-template, persistent-typed-db, resource-pool, resourcet, template-haskell, text, transformers
Files
- CHANGELOG.md +7/−0
- LICENSE +30/−0
- README.md +272/−0
- Setup.hs +2/−0
- persistent-typed-db.cabal +82/−0
- src/Database/Persist/Typed.hs +927/−0
- test/EsqueletoSpec.hs +69/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# CHANGELOG++# Upcoming++# v0.0.1.0++- Initial Release
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,272 @@+# `persistent-typed-db`++[](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)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ persistent-typed-db.cabal view
@@ -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
+ src/Database/Persist/Typed.hs view
@@ -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
+ test/EsqueletoSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}