diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,14 @@ # Revision history for Selda +## 0.1.10.0 -- 2017-08-01 + +* Async exception safety. +* Allow MonadSelda instances not built on SeldaT. +* Chunk very large insertions on backends that request it (i.e. SQLite). +* GHC 8.2 support. + + ## 0.1.9.0 -- 2017-06-16 * Properly document semantics of order. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -395,7 +395,7 @@ allPeople = do (people_name :*: _ :*: _) <- select people (addresses_name :*: city) <- select addresses - restrict (people_name == addresses_name) + restrict (people_name .== addresses_name) return (people_name :*: city) ``` @@ -418,7 +418,7 @@ `addresses` table), you would have to use a join: ``` -allPeople' :: Query s (Col s Text :*: Col s Maybe Text) +allPeople' :: Query s (Col s Text :*: Col s (Maybe Text)) allPeople' = do (name :*: _ :*: _) <- select people (_ :*: city) <- leftJoin (\(name' :*: _) -> name .== name') @@ -478,7 +478,7 @@ (owner :*: homes) <- aggregate $ do (owner :*: city) <- select addresses owner' <- groupBy owner - return (count city :*: owner') + return (owner' :*: count city) restrict (owner .== name) order homes descending return (owner :*: homes) @@ -674,6 +674,43 @@ when *calling* `preparedGrownupsIn`, we instead pass in a value of type `Text`; for convenience, `prepared` automatically converts all arguments to prepared functions into their equivalent column types. + + +Foreign keys +------------ + +To add a foreign key constraint on a column, use the `fk` function. +This function takes two parameters: a column of the table being defined, and +a tuple of the `(table, column)` the foreign key refers to. +The table identifier is simply a value of type `Table t`, while the column +is specified using a selector of type `Selector t a`. + +The following example creates a table to store users, and one to store blog +posts. The `users` table stores a name, a password, and a unique identifier +for each user. +The `posts` table stores, for each post, the post body, a unique +post identifier, and the identifier of the user who wrote the post. +The column storing a post's author has a foreign key constraint on the `userid` +column of the `users` table, to ensure that each post has a valid author. + +``` +users :: Table (RowID :*: Text) +users = table "users" + $ primary "userid" + :*: required "username" + :*: required "password" +(userId :*: userName :*: userPass) = selectors users + +posts :: Table (RowID :*: RowID :*: Text) +posts = table "posts" + $ primary "postid" + :*: required "authorid" `fk` (users, userId) + :*: required "post_body" +``` + +Note that a foreign key can *only* refer to a column which is either +a primary key or has a unique constraint. This is not specific to Selda, but +a restriction of SQL. And with that, we conclude this tutorial. Hopefully it has been enough to get you comfortably started using Selda. diff --git a/selda.cabal b/selda.cabal --- a/selda.cabal +++ b/selda.cabal @@ -1,5 +1,5 @@ name: selda -version: 0.1.9.0 +version: 0.1.10.0 synopsis: Type-safe, high-level EDSL for interacting with relational databases. description: This package provides an EDSL for writing portable, type-safe, high-level database code. Its feature set includes querying and modifying databases, @@ -20,7 +20,7 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 -tested-with: GHC == 7.10.3, GHC == 8.0.2 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: README.md @@ -93,6 +93,9 @@ if impl(ghc < 7.11) build-depends: transformers >=0.4 && <0.6 + if impl(ghc >= 8.2) + build-depends: + hashable >= 1.2.6.1 if !flag(haste) && flag(localcache) build-depends: psqueues >=0.2 && <0.3 diff --git a/src/Database/Selda.hs b/src/Database/Selda.hs --- a/src/Database/Selda.hs +++ b/src/Database/Selda.hs @@ -250,7 +250,7 @@ -- Useful for creating expressions over optional columns: -- -- > people :: Table (Text :*: Int :*: Maybe Text) --- > people = table "people" $ required "name" ¤ required "age" ¤ optional "pet" +-- > people = table "people" $ required "name" :*: required "age" :*: optional "pet" -- > -- > peopleWithCats = do -- > name :*: _ :*: pet <- select people diff --git a/src/Database/Selda/Backend.hs b/src/Database/Selda/Backend.hs --- a/src/Database/Selda/Backend.hs +++ b/src/Database/Selda/Backend.hs @@ -12,6 +12,7 @@ ) where import Database.Selda.Backend.Internal import Control.Monad +import Control.Monad.Catch import Control.Monad.IO.Class import Data.IORef @@ -20,6 +21,6 @@ -- Passing a closed connection to 'runSeldaT' results in a 'SeldaError' -- being thrown. Closing a connection more than once is a no-op. seldaClose :: MonadIO m => SeldaConnection -> m () -seldaClose c = liftIO $ do +seldaClose c = liftIO $ mask_ $ do closed <- atomicModifyIORef' (connClosed c) $ \closed -> (True, closed) unless closed $ closeConnection (connBackend c) c diff --git a/src/Database/Selda/Backend/Internal.hs b/src/Database/Selda/Backend/Internal.hs --- a/src/Database/Selda/Backend/Internal.hs +++ b/src/Database/Selda/Backend/Internal.hs @@ -10,6 +10,7 @@ , PPConfig (..), defPPConfig , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat , freshStmtId + , invalidate , newConnection, allStmts , runSeldaT, seldaBackend ) where @@ -20,6 +21,7 @@ import Database.Selda.SQL.Print.Config import Database.Selda.Types (TableName) import Control.Concurrent +import Control.Exception (throw) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.State @@ -162,17 +164,26 @@ -- Invalidate the table immediately if no transaction is ongoing. invalidateTable :: Table a -> m () - -- | Indicates the start of a new transaction. - -- Starts bookkeeping to invalidate all tables modified during - -- the transaction at the next call to 'endTransaction'. - beginTransaction :: m () - - -- | Indicates the end of the current transaction. - -- Invalidates all tables that were modified since the last call to - -- 'beginTransaction', unless the transaction was rolled back. - endTransaction :: Bool -- ^ @True@ if the transaction was committed, - -- @False@ if it was rolled back. - -> m () + -- | Safely wrap a transaction. To ensure consistency of the in-process cache, + -- it is important that any cached tables modified during a transaction are + -- invalidated ONLY if that transaction succeeds, AFTER the changes become + -- visible in the database. + -- + -- In order to be thread-safe in the presence of asynchronous exceptions, + -- instances should: + -- + -- 1. Mask async exceptions. + -- 2. Start bookkeeping of tables invalidated during the transaction. + -- 3. Perform the transaction, with async exceptions restored. + -- 4. Commit transaction, invalidate tables, and disable bookkeeping; OR + -- 5. If an exception was raised, rollback transaction and + -- disable bookkeeping. + -- + -- See the instance for 'SeldaT' for an example of how to do this safely. + wrapTransaction :: m () -- ^ Signal transaction commit to SQL backend. + -> m () -- ^ Signal transaction rollback to SQL backend. + -> m a -- ^ Transaction to perform. + -> m a -- | Get the backend in use by the computation. seldaBackend :: MonadSelda m => m SeldaBackend @@ -184,7 +195,7 @@ , MonadThrow, MonadCatch, MonadMask, MonadTrans ) -instance MonadIO m => MonadSelda (SeldaT m) where +instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT m) where seldaConnection = S $ fmap stConnection get invalidateTable tbl = S $ do @@ -193,18 +204,17 @@ Nothing -> liftIO $ invalidate [tableName tbl] Just ts -> put $ st {stTouchedTables = Just (tableName tbl : ts)} - beginTransaction = S $ do - st <- get - case stTouchedTables st of - Nothing -> put $ st {stTouchedTables = Just []} - Just _ -> liftIO $ throwM $ SqlError "attempted to nest transactions" - - endTransaction committed = S $ do - st <- get - case stTouchedTables st of - Just ts | committed -> liftIO $ invalidate ts - _ -> return () - put $ st {stTouchedTables = Nothing} + wrapTransaction commit rollback m = mask $ \restore -> do + S $ modify' $ \st -> + case stTouchedTables st of + Nothing -> st {stTouchedTables = Just []} + Just _ -> throw $ SqlError "attempted to nest transactions" + x <- restore m `onException` rollback + commit + st <- S get + maybe (return ()) (liftIO . invalidate) (stTouchedTables st) + S $ put $ st {stTouchedTables = Nothing} + return x -- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'. type SeldaM = SeldaT IO @@ -212,9 +222,10 @@ -- | Run a Selda transformer. Backends should use this to implement their -- @withX@ functions. runSeldaT :: (MonadIO m, MonadMask m) => SeldaT m a -> SeldaConnection -> m a -runSeldaT m c = do - liftIO $ takeMVar (connLock c) - go `finally` liftIO (putMVar (connLock c) ()) +runSeldaT m c = + bracket (liftIO $ takeMVar (connLock c)) + (const $ liftIO $ putMVar (connLock c) ()) + (const go) where go = do closed <- liftIO $ readIORef (connClosed c) diff --git a/src/Database/Selda/Caching.hs b/src/Database/Selda/Caching.hs --- a/src/Database/Selda/Caching.hs +++ b/src/Database/Selda/Caching.hs @@ -121,7 +121,8 @@ updatePrio (Just (_, v)) = (Just v, Just (nextPrio rc, v)) updatePrio _ = (Nothing, Nothing) --- | Invalidate all items in cache that depend on the given table. +-- | Invalidate all items in the per-process cache that depend on +-- the given table. invalidate :: [TableName] -> IO () invalidate tns = atomicModifyIORef' theCache $ \c -> (foldl' (flip invalidate') c tns, ()) diff --git a/src/Database/Selda/Compile.hs b/src/Database/Selda/Compile.hs --- a/src/Database/Selda/Compile.hs +++ b/src/Database/Selda/Compile.hs @@ -44,9 +44,21 @@ -- | Compile an @INSERT@ query, given the keyword representing default values -- in the target SQL dialect, a table and a list of items corresponding -- to the table. -compileInsert :: Insert a => PPConfig -> Table a -> [a] -> (Text, [Param]) -compileInsert _ _ [] = (empty, []) -compileInsert cfg tbl rows = compInsert cfg tbl (map params rows) +compileInsert :: Insert a => PPConfig -> Table a -> [a] -> [(Text, [Param])] +compileInsert _ _ [] = + [(empty, [])] +compileInsert cfg tbl rows = + case ppMaxInsertParams cfg of + Nothing -> [compInsert cfg tbl rows'] + Just n -> map (compInsert cfg tbl) (chunk (n `div` rowlen) rows') + where + rows' = map params rows + rowlen = length (head rows') + chunk chunksize xs = + case splitAt chunksize xs of + ([], []) -> [] + (x, []) -> [x] + (x, xs') -> x : chunk chunksize xs' -- | Compile an @UPDATE@ query. compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a)) diff --git a/src/Database/Selda/Frontend.hs b/src/Database/Selda/Frontend.hs --- a/src/Database/Selda/Frontend.hs +++ b/src/Database/Selda/Frontend.hs @@ -44,10 +44,10 @@ -- -- > people :: Table (Int :*: Text :*: Int :*: Maybe Text) -- > people = table "ppl" --- > $ autoPrimary "id" --- > ¤ required "name" --- > ¤ required "age" --- > ¤ optional "pet" +-- > $ autoPrimary "id" +-- > :*: required "name" +-- > :*: required "age" +-- > :*: optional "pet" -- > -- > main = withSQLite "my_database.sqlite" $ do -- > insert_ people @@ -63,9 +63,9 @@ return 0 insert t cs = do cfg <- ppConfig <$> seldaBackend - res <- uncurry exec $ compileInsert cfg t cs + res <- mapM (uncurry exec) $ compileInsert cfg t cs invalidateTable t - return res + return (sum res) -- | Attempt to insert a list of rows into a table, but don't raise an error -- if the insertion fails. Returns @True@ if the insertion succeeded, otherwise @@ -159,9 +159,9 @@ if tableHasAutoPK t then do res <- liftIO $ do - uncurry (runStmtWithPK b) $ compileInsert (ppConfig b) t cs + mapM (uncurry (runStmtWithPK b)) $ compileInsert (ppConfig b) t cs invalidateTable t - return $ unsafeRowId res + return $ unsafeRowId (last res) else do insert_ t cs return invalidRowId @@ -225,20 +225,10 @@ -- | Perform the given computation atomically. -- If an exception is raised during its execution, the enture transaction -- will be rolled back, and the exception re-thrown. -transaction :: (MonadSelda m, MonadThrow m, MonadCatch m) => m a -> m a -transaction m = do - beginTransaction - void $ exec "BEGIN TRANSACTION" [] - res <- try m - case res of - Left (SomeException e) -> do - void $ exec "ROLLBACK" [] - endTransaction False - throwM e - Right x -> do - void $ exec "COMMIT" [] - endTransaction True - return x +transaction :: (MonadSelda m, MonadCatch m) => m a -> m a +transaction m = + wrapTransaction (void $ exec "COMMIT" []) (void $ exec "ROLLBACK" []) $ do + exec "BEGIN TRANSACTION" [] *> m -- | Set the maximum local cache size to @n@. A cache size of zero disables -- local cache altogether. Changing the cache size will also flush all diff --git a/src/Database/Selda/Generic.hs b/src/Database/Selda/Generic.hs --- a/src/Database/Selda/Generic.hs +++ b/src/Database/Selda/Generic.hs @@ -29,7 +29,9 @@ ) where import Control.Monad.State import Data.Dynamic +import Data.Proxy import Data.Text (pack) +import Data.Typeable import GHC.Generics hiding (R, (:*:), Selector) import qualified GHC.Generics as G ((:*:)(..), Selector) import Unsafe.Coerce @@ -155,7 +157,7 @@ -- > demoPerson = fromRel ("Miyu" :*: 10) -- > -- > adhoc :: Table (Text :*: Int) --- > adhoc = table "adhoc" $ required "name" ¤ required "age" +-- > adhoc = table "adhoc" $ required "name" :*: required "age" -- > -- > getPersons1 :: MonadSelda m => m [SimplePerson] -- > getPersons1 = map fromRel <$> query (select adhoc) @@ -234,13 +236,6 @@ identify :: Dummy a -> (a -> b) -> Int identify (Dummy d) f = unsafeCoerce $ f d -class Traits a where - isMaybeType :: Proxy a -> Bool - isMaybeType _ = False -instance Traits (Maybe a) where - isMaybeType _ = True -instance {-# OVERLAPPABLE #-} Traits a - -- | The relation corresponding to the given type. type family Rel (rep :: * -> *) where Rel (M1 t c a) = Rel a @@ -281,13 +276,15 @@ } gMkDummy = M1 <$> gMkDummy -instance (Traits a, SqlType a) => GRelation (K1 i a) where +instance (Typeable a, SqlType a) => GRelation (K1 i a) where gToRel (K1 x) = x gTblCols _ = [ColInfo "" (sqlType (Proxy :: Proxy a)) optReq []] where + -- workaround for GHC 8.2 not resolving overlapping instances properly + maybeTyCon = typeRepTyCon (typeRep (Proxy :: Proxy (Maybe ()))) optReq - | isMaybeType (Proxy :: Proxy a) = [Optional] - | otherwise = [Required] + | typeRepTyCon (typeRep (Proxy :: Proxy a)) == maybeTyCon = [Optional] + | otherwise = [Required] gMkDummy = do n <- get put (n+1) diff --git a/src/Database/Selda/Prepared.hs b/src/Database/Selda/Prepared.hs --- a/src/Database/Selda/Prepared.hs +++ b/src/Database/Selda/Prepared.hs @@ -60,6 +60,10 @@ instance (MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) => Prepare q (m [a]) where + -- This function uses read/writeIORef instead of atomicModifyIORef. + -- For once, this is actually safe: the IORef points to a single compiled + -- statement, so the only consequence of a race between the read and the write + -- is that the statement gets compiled (note: NOT prepared) twice. mkFun ref sid qry arguments = do conn <- seldaConnection let backend = connBackend conn @@ -68,8 +72,7 @@ case M.lookup sid stmts of Just stm -> do -- Statement already prepared for this connection; just execute it. - liftIO $ do - runQuery conn stm args + liftIO $ runQuery conn stm args _ -> do -- Statement wasn't prepared for this connection; check if it was at -- least previously compiled for this backend. @@ -83,7 +86,7 @@ return comp -- Prepare and execute - liftIO $ do + liftIO $ mask $ \restore -> do hdl <- prepareStmt backend sid reps q let stm = SeldaStmt { stmtHandle = hdl @@ -92,7 +95,7 @@ , stmtText = q } atomicModifyIORef' (connStmts conn) $ \m -> (M.insert sid stm m, ()) - runQuery conn stm args + restore $ runQuery conn stm args where runQuery conn stm args = do let backend = connBackend conn diff --git a/src/Database/Selda/SQL/Print/Config.hs b/src/Database/Selda/SQL/Print/Config.hs --- a/src/Database/Selda/SQL/Print/Config.hs +++ b/src/Database/Selda/SQL/Print/Config.hs @@ -19,6 +19,14 @@ -- | The value used for the next value for an auto-incrementing column. -- For instance, @DEFAULT@ for PostgreSQL, and @NULL@ for SQLite. , ppAutoIncInsert :: Text + + -- | Insert queries may have at most this many parameters; if an insertion + -- has more parameters than this, it will be chunked. + -- + -- Note that only insertions of multiple rows are chunked. If your table + -- has more than this many columns, you should really rethink + -- your database design. + , ppMaxInsertParams :: Maybe Int } -- | Default settings for pretty-printing. @@ -29,6 +37,7 @@ , ppPlaceholder = T.cons '$' . T.pack . show , ppColAttrs = T.unwords . map defColAttr , ppAutoIncInsert = "NULL" + , ppMaxInsertParams = Nothing } -- | Default compilation for SQL types. diff --git a/src/Database/Selda/Selectors.hs b/src/Database/Selda/Selectors.hs --- a/src/Database/Selda/Selectors.hs +++ b/src/Database/Selda/Selectors.hs @@ -7,6 +7,7 @@ import Database.Selda.Column import Data.Dynamic import Data.List (foldl') +import Data.Proxy import Unsafe.Coerce -- | Get the value at the given index from the given inductive tuple. diff --git a/src/Database/Selda/Table.hs b/src/Database/Selda/Table.hs --- a/src/Database/Selda/Table.hs +++ b/src/Database/Selda/Table.hs @@ -9,6 +9,7 @@ import Data.Dynamic import Data.List (sort, group) import Data.Monoid +import Data.Proxy import Data.Text (unpack, intercalate, any) -- | An error occurred when validating a database table. @@ -187,7 +188,7 @@ pkDupes = ["multiple primary keys" | (Primary:_:_) <- soup $ concatMap colAttrs cis] nonPkFks = - [ "column is used as a foreign key, but is not a primary key of its table: " + [ "column is used as a foreign key, but is not primary or unique: " <> fromTableName ftn <> "." <> fromColName fcn | ci <- cis , (Table ftn fcs _, fcn) <- colFKs ci