diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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. diff --git a/README.md b/README.md new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}