beam-sqlite 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+255/−104 lines, 5 filesdep +Win32dep +unixdep ~beam-coredep ~beam-migratedep ~free
Dependencies added: Win32, unix
Dependency ranges changed: beam-core, beam-migrate, free
Files
- ChangeLog.md +4/−0
- Database/Beam/Sqlite/Connection.hs +65/−34
- Database/Beam/Sqlite/Migrate.hs +26/−10
- Database/Beam/Sqlite/Syntax.hs +145/−54
- beam-sqlite.cabal +15/−6
ChangeLog.md view
@@ -1,3 +1,7 @@+# 0.3.0.0++* Re-introduce backend parameter to `Database` class+ # 0.2.0.0 First split of sqlite backend from main beam package
Database/Beam/Sqlite/Connection.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -15,7 +16,7 @@ import Database.Beam.Backend.SQL import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import Database.Beam.Backend.URI-import Database.Beam.Query (SqlInsert(..), SqlInsertValues(..), insert)+import Database.Beam.Query (QExpr, SqlInsert(..), SqlInsertValues(..), insert) import Database.Beam.Schema.Tables ( DatabaseEntity(..) , DatabaseEntityDescriptor(..) , TableEntity)@@ -25,15 +26,14 @@ , Query(..), SQLData(..), field , execute, execute_ , withStatement, bind, nextRow- , withTransaction, query_- , withConnection )+ , query_, open, close ) import Database.SQLite.Simple.FromField ( FromField(..), ResultError(..) , returnError, fieldData) import Database.SQLite.Simple.Internal (RowParser(RP), unRP) import Database.SQLite.Simple.Ok (Ok(..)) import Database.SQLite.Simple.Types (Null) -import Control.Exception (bracket)+import Control.Exception (bracket_, onException, mask) import Control.Monad (forM_, replicateM_) import Control.Monad.Free.Church import Control.Monad.IO.Class (MonadIO(..))@@ -57,6 +57,14 @@ import Network.URI +#ifdef UNIX+import System.Posix.Process (getProcessID)+#elif defined(WINDOWS)+import System.Win32.Process (getCurrentProcessId)+#else+#error Need either POSIX or Win32 API for MonadBeamInsertReturning+#endif+ import Text.Read (readMaybe) -- | The SQLite backend. Used to parameterize 'MonadBeam' and 'FromBackendRow'@@ -104,9 +112,6 @@ fromBackendRow = unSqliteScientific <$> fromBackendRow instance FromBackendRow Sqlite SqliteScientific -instance FromField x => FromField (Auto x) where- fromField = fmap (Auto . Just) . fromField- newtype SqliteScientific = SqliteScientific { unSqliteScientific :: Scientific } instance FromField SqliteScientific where fromField f =@@ -166,14 +171,16 @@ unRP (next True) _ -> unRP (next False) --- | URI syntax or use with 'withDbConnection'.+-- | URI syntax for use with 'withDbConnection'. See documentation for+-- 'BeamURIOpeners' for more information. sqliteUriSyntax :: c SqliteCommandSyntax Sqlite Connection SqliteM -> BeamURIOpeners c sqliteUriSyntax = mkUriOpener "sqlite:"- (\uri action -> do- let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri- withConnection sqliteName action)+ (\uri -> do+ let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri+ hdl <- open sqliteName+ pure (hdl, close hdl)) instance MonadBeam SqliteCommandSyntax Sqlite Connection SqliteM where withDatabase = withDatabaseDebug (\_ -> pure ())@@ -236,41 +243,65 @@ -- Beam also offers a backend-agnostic way of using this functionality in the -- 'MonadBeamInsertReturning' extension. This functionality is emulated in -- SQLite using a temporary table and a trigger.-data SqliteInsertReturning (table :: (* -> *) -> *) =- SqliteInsertReturning T.Text SqliteInsertSyntax+data SqliteInsertReturning (table :: (* -> *) -> *)+ = SqliteInsertReturning T.Text SqliteInsertSyntax+ | SqliteInsertReturningNoRows -- | Build a 'SqliteInsertReturning' representing inserting the given values -- into the given table. Use 'runInsertReturningList' insertReturning :: DatabaseEntity be db (TableEntity table)- -> SqlInsertValues SqliteInsertValuesSyntax table+ -> SqlInsertValues SqliteInsertValuesSyntax (table (QExpr SqliteExpressionSyntax s)) -> SqliteInsertReturning table insertReturning tbl@(DatabaseEntity (DatabaseTable tblNm _)) vs =- let SqlInsert s = insert tbl vs- in SqliteInsertReturning tblNm s+ case insert tbl vs of+ SqlInsert s ->+ SqliteInsertReturning tblNm s+ SqlInsertNoRows ->+ SqliteInsertReturningNoRows -- | Runs a 'SqliteInsertReturning' statement and returns a result for each--- inserted row. Unfilled 'Auto' values in the table will have been filled in in--- the output.+-- inserted row. runInsertReturningList :: FromBackendRow Sqlite (table Identity) => SqliteInsertReturning table -> SqliteM [ table Identity ]+runInsertReturningList SqliteInsertReturningNoRows = pure [] runInsertReturningList (SqliteInsertReturning nm insertStmt_) = do (logger, conn) <- SqliteM ask- SqliteM . liftIO $- withTransaction conn $- bracket (createInsertedValuesTable conn) (dropInsertedValuesTable conn) $ \() ->- bracket (createInsertTrigger conn) (dropInsertTrigger conn) $ \() -> do- runSqliteInsert logger conn insertStmt_- fmap (\(BeamSqliteRow r) -> r) <$> query_ conn "SELECT * FROM inserted_values"+ SqliteM . liftIO $ do - where- createInsertedValuesTable conn =- execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values AS SELECT * FROM \"" <> sqliteEscape nm <> "\" LIMIT 0"))- dropInsertedValuesTable conn () =- execute_ conn (Query "DROP TABLE inserted_values")+#ifdef UNIX+ processId <- fromString . show <$> getProcessID+#elif defined(WINDOWS)+ processId <- fromString . show <$> getCurrentProcessId+#else+#error Need either POSIX or Win32 API for MonadBeamInsertReturning+#endif - createInsertTrigger conn =- execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger AFTER INSERT ON \"" <> sqliteEscape nm <> "\" BEGIN " <>- "INSERT INTO inserted_values SELECT * FROM \"" <> sqliteEscape nm <> "\" WHERE ROWID=last_insert_rowid(); END" ))- dropInsertTrigger conn () =- execute_ conn "DROP TRIGGER insert_trigger"+ let startSavepoint =+ execute_ conn (Query ("SAVEPOINT insert_savepoint_" <> processId))+ rollbackToSavepoint =+ execute_ conn (Query ("ROLLBACK TRANSACTION TO SAVEPOINT insert_savepoint_" <> processId))+ releaseSavepoint =+ execute_ conn (Query ("RELEASE SAVEPOINT insert_savepoint_" <> processId))++ createInsertedValuesTable =+ execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values_" <> processId <> " AS SELECT * FROM \"" <> sqliteEscape nm <> "\" LIMIT 0"))+ dropInsertedValuesTable =+ execute_ conn (Query ("DROP TABLE inserted_values_" <> processId))++ createInsertTrigger =+ execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger_" <> processId <> " AFTER INSERT ON \"" <> sqliteEscape nm <> "\" BEGIN " <>+ "INSERT INTO inserted_values_" <> processId <> " SELECT * FROM \"" <> sqliteEscape nm <> "\" WHERE ROWID=last_insert_rowid(); END" ))+ dropInsertTrigger =+ execute_ conn (Query ("DROP TRIGGER insert_trigger_" <> processId))+++ mask $ \restore -> do+ startSavepoint+ flip onException rollbackToSavepoint . restore $ do+ x <- bracket_ createInsertedValuesTable dropInsertedValuesTable $+ bracket_ createInsertTrigger dropInsertTrigger $ do+ runSqliteInsert logger conn insertStmt_+ fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT * FROM inserted_values_" <> processId))+ releaseSavepoint+ return x
Database/Beam/Sqlite/Migrate.hs view
@@ -29,8 +29,7 @@ import Control.Monad.Reader import Database.SQLite.Simple- ( Connection, Only(..)- , open, close, query_ )+ ( Connection, open, close, query_ ) import Data.Aeson import Data.Attoparsec.Text (asciiCI, skipSpace)@@ -40,7 +39,7 @@ import Data.Char (isSpace) import Data.Int (Int64) import Data.List (sortBy)-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, isJust) import Data.Monoid (Endo(..), (<>)) import Data.Ord (comparing) import Data.String (fromString)@@ -49,7 +48,7 @@ -- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the -- @beam-migrate@ CLI tool.-migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteCommandSyntax Connection+migrationBackend :: Tool.BeamMigrationBackend SqliteCommandSyntax Sqlite Connection SqliteM migrationBackend = Tool.BeamMigrationBackend "sqlite" "For beam-sqlite, this is the path to a sqlite3 file"@@ -131,6 +130,7 @@ (Db.BeamSerializedDataType $ Db.beamSerializeJSON "sqlite" (toJSON txt))+ False Right x -> x where dtParser = charP <|> varcharP <|>@@ -139,7 +139,7 @@ doubleP <|> integerP <|> smallIntP <|> bigIntP <|> floatP <|> doubleP <|> realP <|> dateP <|>- timeP <|> timestampP <|> textP <|>+ timestampP <|> timeP <|> textP <|> blobP <|> booleanP ws = A.many1 A.space@@ -184,10 +184,10 @@ intTypeP pure intType smallIntP = do- asciiCI "INT2" <|> (asciiCI "SMALL" >> ws >> intTypeP)+ asciiCI "INT2" <|> (asciiCI "SMALL" >> optional ws >> intTypeP) pure smallIntType bigIntP = do- asciiCI "INT8" <|> (asciiCI "BIG" >> ws >> intTypeP)+ asciiCI "INT8" <|> (asciiCI "BIG" >> optional ws >> intTypeP) pure sqliteBigIntType dateP = dateType <$ asciiCI "DATE" timeP = do@@ -236,17 +236,32 @@ getDbConstraints :: SqliteM [Db.SomeDatabasePredicate] getDbConstraints = SqliteM . ReaderT $ \(_, conn) -> do- tblNames <- query_ conn "SELECT name from sqlite_master where type='table'"+ tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'" tblPreds <-- fmap mconcat . forM tblNames $ \(Only tblName) -> do+ fmap mconcat . forM tblNames $ \(tblName, sql) -> do columns <- fmap (sortBy (comparing (\(cid, _, _, _, _, _) -> cid :: Int))) $ query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblName <> "')")) let columnPreds = foldMap (\(_ ::Int, nm, typStr, notNull, _, _) ->- let dtType = parseSqliteDataType typStr+ let dtType = if isAutoincrement then sqliteSerialType else parseSqliteDataType typStr+ isAutoincrement = isJust (A.maybeResult (A.parse autoincrementParser sql)) + autoincrementParser = do+ A.manyTill A.anyChar $ do+ hadQuote <- optional (A.char '"')+ A.string nm+ maybe (pure ()) (\_ -> void $ A.char '"') hadQuote+ A.many1 A.space+ asciiCI "INTEGER"+ A.many1 A.space+ asciiCI "PRIMARY"+ A.many1 A.space+ asciiCI "KEY"+ A.many1 A.space+ asciiCI "AUTOINCREMENT"+ notNullPred = if notNull then [ Db.SomeDatabasePredicate@@ -254,6 +269,7 @@ (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint SqliteColumnSchemaSyntax) ] else []+ in [ Db.SomeDatabasePredicate (Db.TableHasColumn tblName nm dtType :: Db.TableHasColumn SqliteColumnSchemaSyntax) ] ++
Database/Beam/Sqlite/Syntax.hs view
@@ -1,8 +1,10 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing#-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} -- | SQLite implementations of the Beam SQL syntax classes --@@ -23,7 +25,7 @@ -- * SQLite data type syntax , SqliteDataTypeSyntax(..) , sqliteTextType, sqliteBlobType- , sqliteBigIntType+ , sqliteBigIntType, sqliteSerialType -- * Building and consuming 'SqliteSyntax' , fromSqliteCommand, formatSqliteInsert@@ -36,28 +38,31 @@ import Database.Beam.Backend.SQL import Database.Beam.Haskell.Syntax-import Database.Beam.Migrate.Checks import Database.Beam.Migrate.Generics import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.SQL (DataType(..), FieldReturnType(..), field)+import Database.Beam.Migrate.SQL.BeamExtensions import Database.Beam.Migrate.Serialization-import Database.Beam.Migrate.Types import Database.Beam.Query import Database.Beam.Query.SQL92 import Data.ByteString (ByteString)+import qualified Data.ByteString as B import Data.ByteString.Builder import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString as B import Data.Coerce import qualified Data.DList as DL import Data.Hashable import Data.Int import Data.Maybe import Data.Monoid+import Data.Proxy (Proxy(..))+import Data.Scientific import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL import Data.Time import Data.Word @@ -220,9 +225,12 @@ -- | SQLite syntax for column schemas in @CREATE TABLE@ or @ALTER COLUMN ... ADD -- COLUMN@ statements-newtype SqliteColumnSchemaSyntax- = SqliteColumnSchemaSyntax { fromSqliteColumnSchema :: SqliteSyntax }- deriving (Show, Eq, Hashable)+data SqliteColumnSchemaSyntax+ = SqliteColumnSchemaSyntax+ { fromSqliteColumnSchema :: SqliteSyntax+ , sqliteIsSerialColumn :: Bool }+ deriving (Show, Eq, Generic)+instance Hashable SqliteColumnSchemaSyntax instance Sql92DisplaySyntax SqliteColumnSchemaSyntax where displaySyntax = displaySyntax . fromSqliteColumnSchema@@ -234,9 +242,10 @@ { fromSqliteDataType :: SqliteSyntax , sqliteDataTypeToHs :: HsDataType , sqliteDataTypeSerialized :: BeamSerializedDataType+ , sqliteDataTypeSerial :: Bool } deriving (Show, Eq, Generic) instance Hashable SqliteDataTypeSyntax where- hashWithSalt salt (SqliteDataTypeSyntax s _ _) = hashWithSalt salt s+ hashWithSalt salt (SqliteDataTypeSyntax s _ _ _) = hashWithSalt salt s instance Sql92DisplaySyntax SqliteDataTypeSyntax where displaySyntax = displaySyntax . fromSqliteDataType @@ -254,7 +263,10 @@ = SqliteColumnConstraintSyntax { fromSqliteColumnConstraint :: SqlConstraintAttributesBuilder -> SqliteSyntax , sqliteColumnConstraintSerialized :: BeamSerializedConstraint }-newtype SqliteTableConstraintSyntax = SqliteTableConstraintSyntax { fromSqliteTableConstraint :: SqliteSyntax }+data SqliteTableConstraintSyntax+ = SqliteTableConstraintSyntax+ { fromSqliteTableConstraint :: SqliteSyntax+ , sqliteTableConstraintPrimaryKey :: Maybe [ T.Text ] } data SqliteMatchTypeSyntax = SqliteMatchTypeSyntax { fromSqliteMatchType :: SqliteSyntax@@ -315,7 +327,7 @@ SqliteAlterTableSyntax $ case fromSqliteAlterTableAction action of Just alterTable ->- emit "ALTER TABLE " <> quotedIdentifier nm <> alterTable+ emit "ALTER TABLE " <> quotedIdentifier nm <> emit " " <> alterTable Nothing -> emit "SELECT 1" @@ -353,11 +365,12 @@ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax SqliteColumnSchemaSyntax = SqliteColumnConstraintDefinitionSyntax columnSchemaSyntax ty defVal constraints collation =- SqliteColumnSchemaSyntax $- fromSqliteDataType ty <>- maybe mempty (\defVal -> emit " DEFAULT " <> parens (fromSqliteExpression defVal)) defVal <>- foldMap (\constraint -> emit " " <> fromSqliteColumnConstraintDefinition constraint <> emit " ") constraints <>- maybe mempty (\c -> emit " COLLATE " <> quotedIdentifier c) collation+ SqliteColumnSchemaSyntax+ (fromSqliteDataType ty <>+ maybe mempty (\defVal -> emit " DEFAULT " <> parens (fromSqliteExpression defVal)) defVal <>+ foldMap (\constraint -> emit " " <> fromSqliteColumnConstraintDefinition constraint <> emit " ") constraints <>+ maybe mempty (\c -> emit " COLLATE " <> quotedIdentifier c) collation)+ (if sqliteDataTypeSerial ty then True else False) instance IsSql92ColumnConstraintDefinitionSyntax SqliteColumnConstraintDefinitionSyntax where type Sql92ColumnConstraintDefinitionConstraintSyntax SqliteColumnConstraintDefinitionSyntax = SqliteColumnConstraintSyntax@@ -418,8 +431,9 @@ instance IsSql92TableConstraintSyntax SqliteTableConstraintSyntax where primaryKeyConstraintSyntax fields =- SqliteTableConstraintSyntax $- emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier fields))+ SqliteTableConstraintSyntax+ (emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier fields)))+ (Just fields) instance IsSql92CreateTableSyntax SqliteCreateTableSyntax where type Sql92CreateTableColumnSchemaSyntax SqliteCreateTableSyntax = SqliteColumnSchemaSyntax@@ -429,50 +443,72 @@ createTableSyntax _ nm fields constraints = let fieldDefs = map mkFieldDef fields constraintDefs = map fromSqliteTableConstraint constraints+ noPkConstraintDefs = map fromSqliteTableConstraint (filter (isNothing . sqliteTableConstraintPrimaryKey) constraints) + constraintPks = mapMaybe sqliteTableConstraintPrimaryKey constraints+ fieldPrimaryKey = map fst (filter (sqliteIsSerialColumn . snd) fields)+ mkFieldDef (fieldNm, fieldTy) =- quotedIdentifier fieldNm <> emit " " <> fromSqliteColumnSchema fieldTy+ quotedIdentifier fieldNm <> emit " " <>+ fromSqliteColumnSchema fieldTy - in SqliteCreateTableSyntax $- emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs))+ createWithConstraints constraintDefs' =+ SqliteCreateTableSyntax $+ emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs'))+ normalCreateTable = createWithConstraints constraintDefs+ createTableNoPkConstraint = createWithConstraints noPkConstraintDefs + in case fieldPrimaryKey of+ [] -> normalCreateTable+ [field] ->+ case constraintPks of+ [] -> error "A column claims to have a primary key, but there is no key on this table"+ [[fieldPk]]+ | field /= fieldPk -> error "Two columns claim to be a primary key on this table"+ | otherwise -> createTableNoPkConstraint+ _ -> error "There are multiple primary key constraints on this table"+ _ -> error "More than one column claims to be a primary key on this table"+ instance IsSql92DataTypeSyntax SqliteDataTypeSyntax where- domainType nm = SqliteDataTypeSyntax (quotedIdentifier nm) (domainType nm) (domainType nm)+ domainType nm = SqliteDataTypeSyntax (quotedIdentifier nm) (domainType nm) (domainType nm) False charType prec charSet = SqliteDataTypeSyntax (emit "CHAR" <> sqliteOptPrec prec <> sqliteOptCharSet charSet) (charType prec charSet) (charType prec charSet)+ False varCharType prec charSet = SqliteDataTypeSyntax (emit "VARCHAR" <> sqliteOptPrec prec <> sqliteOptCharSet charSet) (varCharType prec charSet) (varCharType prec charSet)+ False nationalCharType prec = SqliteDataTypeSyntax (emit "NATIONAL CHAR" <> sqliteOptPrec prec) (nationalCharType prec) (nationalCharType prec)+ False nationalVarCharType prec = SqliteDataTypeSyntax (emit "NATIONAL CHARACTER VARYING" <> sqliteOptPrec prec) (nationalVarCharType prec) (nationalVarCharType prec)-- bitType prec = SqliteDataTypeSyntax (emit "BIT" <> sqliteOptPrec prec) (bitType prec) (bitType prec)- varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec)+ False+ bitType prec = SqliteDataTypeSyntax (emit "BIT" <> sqliteOptPrec prec) (bitType prec) (bitType prec) False+ varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec) False - numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec)- decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec)+ numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec) False+ decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False - intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType- smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType+ intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType False+ smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType False - floatType prec = SqliteDataTypeSyntax (emit "FLOAT" <> sqliteOptPrec prec) (floatType prec) (floatType prec)- doubleType = SqliteDataTypeSyntax (emit "DOUBLE PRECISION") doubleType doubleType- realType = SqliteDataTypeSyntax (emit "REAL") realType realType- dateType = SqliteDataTypeSyntax (emit "DATE") dateType dateType+ floatType prec = SqliteDataTypeSyntax (emit "FLOAT" <> sqliteOptPrec prec) (floatType prec) (floatType prec) False+ doubleType = SqliteDataTypeSyntax (emit "DOUBLE PRECISION") doubleType doubleType False+ realType = SqliteDataTypeSyntax (emit "REAL") realType realType False+ dateType = SqliteDataTypeSyntax (emit "DATE") dateType dateType False timeType prec withTz = SqliteDataTypeSyntax (emit "TIME" <> sqliteOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty)- (timeType prec withTz) (timeType prec withTz)+ (timeType prec withTz) (timeType prec withTz) False timestampType prec withTz = SqliteDataTypeSyntax (emit "TIMESTAMP" <> sqliteOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty)- (timestampType prec withTz) (timestampType prec withTz)+ (timestampType prec withTz) (timestampType prec withTz) False instance IsSql99DataTypeSyntax SqliteDataTypeSyntax where characterLargeObjectType = sqliteTextType binaryLargeObjectType = sqliteBlobType- booleanType = SqliteDataTypeSyntax (emit "BOOLEAN") booleanType booleanType+ booleanType = SqliteDataTypeSyntax (emit "BOOLEAN") booleanType booleanType False arrayType _ _ = error "SQLite does not support arrayType" rowType _ = error "SQLite does not support rowType" @@ -486,18 +522,21 @@ (importSome "Data.Text" [importTyNamed "Text"])) characterLargeObjectType) characterLargeObjectType+ False sqliteBlobType = SqliteDataTypeSyntax (emit "BLOB") (HsDataType (hsVarFrom "sqliteBlob" "Database.Beam.Sqlite") (HsType (tyConNamed "ByteString") (importSome "Data.ByteString" [importTyNamed "ByteString"])) binaryLargeObjectType)- binaryLargeObjectType+ binaryLargeObjectType+ False sqliteBigIntType = SqliteDataTypeSyntax (emit "BIGINT")- (HsDataType (hsVarFrom "sqliteBigInt" "Database.Beam.Sqlite")- (HsType (tyConNamed "Int64")- (importSome "Data.Int" [importTyNamed "Int64"]))- bigIntType)- bigIntType+ (HsDataType (hsVarFrom "sqliteBigInt" "Database.Beam.Sqlite")+ (HsType (tyConNamed "Int64")+ (importSome "Data.Int" [importTyNamed "Int64"]))+ bigIntType)+ bigIntType+ False instance Sql92SerializableDataTypeSyntax SqliteDataTypeSyntax where serializeDataType = fromBeamSerializedDataType . sqliteDataTypeSerialized@@ -627,12 +666,16 @@ sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i)))+instance HasSqlValueSyntax SqliteValueSyntax Word8 where+ sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word16 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word32 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word64 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i)))+instance HasSqlValueSyntax SqliteValueSyntax Scientific where+ sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (fromString (show s)))) -- Rely on sqlites duck typing instance HasSqlValueSyntax SqliteValueSyntax Float where sqlValueSyntax f = SqliteValueSyntax (emitValue (SQLFloat (float2Double f))) instance HasSqlValueSyntax SqliteValueSyntax Double where@@ -645,12 +688,12 @@ sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (fromString s))) instance HasSqlValueSyntax SqliteValueSyntax T.Text where sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText s))+instance HasSqlValueSyntax SqliteValueSyntax TL.Text where+ sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (TL.toStrict s))) instance HasSqlValueSyntax SqliteValueSyntax x => HasSqlValueSyntax SqliteValueSyntax (Maybe x) where sqlValueSyntax (Just x) = sqlValueSyntax x sqlValueSyntax Nothing = sqlValueSyntax SqlNull-instance HasSqlValueSyntax SqliteValueSyntax (Maybe x) => HasSqlValueSyntax SqliteValueSyntax (Auto x) where- sqlValueSyntax (Auto x) = sqlValueSyntax x instance IsCustomSqlSyntax SqliteExpressionSyntax where newtype CustomSqlSyntax SqliteExpressionSyntax =@@ -684,10 +727,12 @@ negateE = unOp "-"; notE = unOp "NOT" isNotNullE = postFix "IS NOT NULL"; isNullE = postFix "IS NULL"- isTrueE = postFix "IS TRUE"; isNotTrueE = postFix "IS NOT TRUE"- isFalseE = postFix "IS FALSE"; isNotFalseE = postFix "IS NOT FALSE"- isUnknownE = postFix "IS UNKNOWN"; isNotUnknownE = postFix "IS NOT UNKNOWN" + -- SQLite doesn't handle tri-state booleans properly+ isTrueE = postFix "IS 1"; isNotTrueE = postFix "IS NOT 1"+ isFalseE = postFix "IS 0"; isNotFalseE = postFix "IS NOT 0"+ isUnknownE = postFix "IS NULL"; isNotUnknownE = postFix "IS NOT NULL"+ existsE select = SqliteExpressionSyntax (emit "EXISTS " <> parens (fromSqliteSelect select)) uniqueE select = SqliteExpressionSyntax (emit "UNIQUE " <> parens (fromSqliteSelect select)) @@ -714,6 +759,9 @@ bitLengthE x = SqliteExpressionSyntax (emit "BIT_LENGTH" <> parens (fromSqliteExpression x)) charLengthE x = SqliteExpressionSyntax (emit "CHAR_LENGTH" <> parens (fromSqliteExpression x)) octetLengthE x = SqliteExpressionSyntax (emit "OCTET_LENGTH" <> parens (fromSqliteExpression x))+ lowerE x = SqliteExpressionSyntax (emit "LOWER" <> parens (fromSqliteExpression x))+ upperE x = SqliteExpressionSyntax (emit "UPPER" <> parens (fromSqliteExpression x))+ trimE x = SqliteExpressionSyntax (emit "TRIM" <> parens (fromSqliteExpression x)) coalesceE es = SqliteExpressionSyntax (emit "COALESCE" <> parens (commas (map fromSqliteExpression es))) extractE field from = SqliteExpressionSyntax $@@ -734,7 +782,7 @@ concatE [] = valueE (sqlValueSyntax ("" :: T.Text)) concatE (x:xs) = SqliteExpressionSyntax $ parens $- foldr (\a b -> parens (fromSqliteExpression a) <> emit " || " <> parens b) (fromSqliteExpression x) xs+ foldl (\a b -> a <> emit " || " <> parens (fromSqliteExpression b)) (fromSqliteExpression x) xs binOp :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax -> SqliteExpressionSyntax binOp op a b =@@ -748,8 +796,8 @@ SqliteExpressionSyntax $ parens (fromSqliteExpression a) <> emit op <>- parens (maybe mempty (\q -> emit " " <> fromSqliteComparisonQuantifier q <> emit " ") quantifier <>- fromSqliteExpression b)+ maybe mempty (\q -> emit " " <> fromSqliteComparisonQuantifier q <> emit " ") quantifier <>+ parens (fromSqliteExpression b) unOp, postFix :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax unOp op a =@@ -812,7 +860,7 @@ maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_ spaces, parens :: SqliteSyntax -> SqliteSyntax-spaces a = emit " " <> a <> emit " " +spaces a = emit " " <> a <> emit " " parens a = emit "(" <> a <> emit ")" commas :: [SqliteSyntax] -> SqliteSyntax@@ -820,12 +868,25 @@ commas [x] = x commas (x:xs) = x <> foldMap (emit ", " <>) xs +sqliteSerialType :: SqliteDataTypeSyntax+sqliteSerialType = SqliteDataTypeSyntax (emit "INTEGER PRIMARY KEY AUTOINCREMENT")+ intType+ (BeamSerializedDataType (beamSerializeJSON "sqlite" "serial"))+ True++data SqliteHasDefault = SqliteHasDefault+instance FieldReturnType 'True 'False SqliteColumnSchemaSyntax resTy a =>+ FieldReturnType 'False 'False SqliteColumnSchemaSyntax resTy (SqliteHasDefault -> a) where+ field' _ _ nm ty _ collation constraints SqliteHasDefault =+ field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints++instance IsBeamSerialColumnSchemaSyntax SqliteColumnSchemaSyntax where+ genericSerial nm = field nm (DataType sqliteSerialType) SqliteHasDefault+ instance HasDefaultSqlDataType SqliteDataTypeSyntax (SqlSerial Int) where- defaultSqlDataType _ _ = intType+ defaultSqlDataType _ False = sqliteSerialType+ defaultSqlDataType _ True = intType instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax (SqlSerial Int) where- defaultSqlDataTypeConstraints _ _ False = [ FieldCheck $ \tblNm colNm -> p (TableColumnHasConstraint tblNm colNm c :: TableColumnHasConstraint SqliteColumnSchemaSyntax) ]- where c = constraintDefinitionSyntax Nothing (SqliteColumnConstraintSyntax (\_ -> emit "DEFAULT ROWID")- (BeamSerializedConstraint (beamSerializeJSON "sqlite" "serial"))) Nothing defaultSqlDataTypeConstraints _ _ _ = [] instance HasDefaultSqlDataType SqliteDataTypeSyntax ByteString where@@ -847,3 +908,33 @@ instance HasSqlValueSyntax SqliteValueSyntax Day where sqlValueSyntax tm = SqliteValueSyntax (emitValue (SQLText (fromString tmStr))) where tmStr = formatTime defaultTimeLocale (iso8601DateFormat Nothing) tm++-- * Equality checks+#define HAS_SQLITE_EQUALITY_CHECK(ty) \+ instance HasSqlEqualityCheck SqliteExpressionSyntax (ty); \+ instance HasSqlQuantifiedEqualityCheck SqliteExpressionSyntax (ty);++HAS_SQLITE_EQUALITY_CHECK(Int)+HAS_SQLITE_EQUALITY_CHECK(Int8)+HAS_SQLITE_EQUALITY_CHECK(Int16)+HAS_SQLITE_EQUALITY_CHECK(Int32)+HAS_SQLITE_EQUALITY_CHECK(Int64)+HAS_SQLITE_EQUALITY_CHECK(Word)+HAS_SQLITE_EQUALITY_CHECK(Word8)+HAS_SQLITE_EQUALITY_CHECK(Word16)+HAS_SQLITE_EQUALITY_CHECK(Word32)+HAS_SQLITE_EQUALITY_CHECK(Word64)+HAS_SQLITE_EQUALITY_CHECK(Double)+HAS_SQLITE_EQUALITY_CHECK(Float)+HAS_SQLITE_EQUALITY_CHECK(Bool)+HAS_SQLITE_EQUALITY_CHECK(String)+HAS_SQLITE_EQUALITY_CHECK(T.Text)+HAS_SQLITE_EQUALITY_CHECK(TL.Text)+HAS_SQLITE_EQUALITY_CHECK(B.ByteString)+HAS_SQLITE_EQUALITY_CHECK(BL.ByteString)+HAS_SQLITE_EQUALITY_CHECK(UTCTime)+HAS_SQLITE_EQUALITY_CHECK(LocalTime)+HAS_SQLITE_EQUALITY_CHECK(ZonedTime)+HAS_SQLITE_EQUALITY_CHECK(Char)+HAS_SQLITE_EQUALITY_CHECK(Integer)+HAS_SQLITE_EQUALITY_CHECK(Scientific)
beam-sqlite.cabal view
@@ -1,11 +1,12 @@+ name: beam-sqlite-version: 0.2.0.0+version: 0.3.0.0 synopsis: Beam driver for SQLite description: Beam driver for the <https://sqlite.org/ SQLite> embedded database. See <http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/ here> for more information homepage: http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/-license: BSD3+license: MIT license-file: LICENSE author: Travis Athougies maintainer: travis@athougies.net@@ -14,7 +15,8 @@ build-type: Simple extra-source-files: README.md extra-doc-files: ChangeLog.md-cabal-version: >=1.18+bug-reports: https://github.com/tathougies/beam/issues+cabal-version: 1.18 library exposed-modules: Database.Beam.Sqlite@@ -23,8 +25,8 @@ Database.Beam.Sqlite.Migrate build-depends: base >=4.7 && <5, - beam-core >=0.6 && <0.7,- beam-migrate >=0.2 && <0.3,+ beam-core >=0.7 && <0.8,+ beam-migrate >=0.3 && <0.4, sqlite-simple >=0.4 && <0.5, text >=1.0 && <1.3,@@ -33,7 +35,7 @@ time >=1.6 && <1.10, dlist >=0.8 && <0.9, mtl >=2.1 && <2.3,- free >=4.12 && <4.13,+ free >=4.12 && <5.1, scientific >=0.3 && <0.4, network-uri >=2.6 && <2.7, aeson >=0.11 && <1.3,@@ -45,6 +47,13 @@ ghc-options: -Wall if flag(werror) ghc-options: -Werror++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends: Win32 >=2.4 && <2.8+ if os(freebsd) || os(netbsd) || os(darwin) || os(linux) || os(solaris)+ cpp-options: -DUNIX+ build-depends: unix >=2.0 && <2.8 flag werror description: Enable -Werror during development