{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE TupleSections #-}

-- | Migrations support for SQLite databases
module Database.Beam.Sqlite.Migrate
  ( -- * @beam-migrate@ CLI support
    migrationBackend, SqliteCommandSyntax

    -- * @beam-migrate@ utility functions
  , migrateScript, writeMigrationScript
  , sqlitePredConverter, sqliteTypeToHs
  , getDbConstraints

    -- * SQLite-specific data types
  , sqliteText, sqliteBlob, sqliteBigInt
  ) where

import qualified Database.Beam.Migrate as Db
import qualified Database.Beam.Migrate.Backend as Tool
import qualified Database.Beam.Migrate.Serialization as Db
import           Database.Beam.Migrate.Types (QualifiedName(..))
import qualified Database.Beam.Query.DataTypes as Db

import           Database.Beam.Backend.SQL
import           Database.Beam.Haskell.Syntax
import           Database.Beam.Sqlite.Connection
import           Database.Beam.Sqlite.Syntax

import           Control.Applicative
import           Control.Exception
import           Control.Monad
import           Control.Monad.Reader

import           Database.SQLite.Simple (open, close, query_)

import           Data.Aeson
import           Data.Attoparsec.Text (asciiCI, skipSpace)
import qualified Data.Attoparsec.Text as A
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BL
import           Data.Char (isSpace)
import           Data.Int (Int64)
import           Data.List (sortBy)
import           Data.Maybe (mapMaybe, isJust)
import           Data.Monoid (Endo(..))
import           Data.Ord (comparing)
import           Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

-- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the
-- @beam-migrate@ CLI tool.
migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM
migrationBackend :: BeamMigrationBackend Sqlite SqliteM
migrationBackend = forall be (m :: * -> *).
(MonadBeam be m, MonadFail m, HasQBuilder be,
 BeamMigrateSqlBackend be,
 HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be),
 BeamSqlBackendCanSerialize be LocalTime,
 BeamSqlBackendCanSerialize be (Maybe LocalTime),
 BeamSqlBackendCanSerialize be Text,
 BeamSqlBackendCanSerialize be SqlNull,
 Sql92ReasonableMarshaller be) =>
[Char]
-> [Char]
-> m [SomeDatabasePredicate]
-> BeamDeserializers be
-> (BeamSqlBackendSyntax be -> [Char])
-> [Char]
-> HaskellPredicateConverter
-> ActionProvider be
-> (forall a. [Char] -> m a -> IO (Either [Char] a))
-> BeamMigrationBackend be m
Tool.BeamMigrationBackend
                       [Char]
"sqlite"
                       [Char]
"For beam-sqlite, this is the path to a sqlite3 file"
                       SqliteM [SomeDatabasePredicate]
getDbConstraints
                       (forall be. BeamMigrateSqlBackend be => BeamDeserializers be
Db.sql92Deserializers forall a. Semigroup a => a -> a -> a
<> BeamDeserializers Sqlite
sqliteDataTypeDeserializers forall a. Semigroup a => a -> a -> a
<>
                        forall be.
(Typeable be, BeamMigrateOnlySqlBackend be,
 HasDataTypeCreatedCheck
   (BeamMigrateSqlBackendDataTypeSyntax be)) =>
BeamDeserializers be
Db.beamCheckDeserializers)
                       (ByteString -> [Char]
BL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> ByteString
";") forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteSyntax -> ByteString
sqliteRenderSyntaxScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteCommandSyntax -> SqliteSyntax
fromSqliteCommand)
                       [Char]
"sqlite.sql"
                       HaskellPredicateConverter
sqlitePredConverter forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
Db.defaultActionProvider
                       (\[Char]
fp SqliteM a
action ->
                            forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ([Char] -> IO Connection
open [Char]
fp) Connection -> IO ()
close forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
                              forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. SqliteM a -> ReaderT ([Char] -> IO (), Connection) IO a
runSqliteM SqliteM a
action)
                                                          (\[Char]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (), Connection
conn))
                                    (\SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (forall a. Show a => a -> [Char]
show (SomeException
e :: SomeException)))))

-- | 'Db.BeamDeserializers' or SQLite specific types. Specifically,
-- 'sqliteBlob', 'sqliteText', and 'sqliteBigInt'. These are compatible with the
-- "typical" serialized versions of the standard 'Db.binaryLargeObject',
-- 'Db.characterLargeObject', and 'Db.bigint' types.
sqliteDataTypeDeserializers :: Db.BeamDeserializers Sqlite
sqliteDataTypeDeserializers :: BeamDeserializers Sqlite
sqliteDataTypeDeserializers =
  forall ty be.
Typeable ty =>
(forall be'. BeamDeserializers be' -> Value -> Parser ty)
-> BeamDeserializers be
Db.beamDeserializer forall a b. (a -> b) -> a -> b
$ \BeamDeserializers be'
_ Value
v ->
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> a
id @SqliteDataTypeSyntax) forall a b. (a -> b) -> a -> b
$
  case Value
v of
    Value
"blob" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SqliteDataTypeSyntax
sqliteBlobType
    Value
"clob" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SqliteDataTypeSyntax
sqliteTextType
    Value
"bigint" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SqliteDataTypeSyntax
sqliteBigIntType
    Object Object
o ->
       (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Maybe Word
_ :: Maybe Word) -> SqliteDataTypeSyntax
sqliteBlobType) (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"binary")) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Maybe Word
_ :: Maybe Word) -> SqliteDataTypeSyntax
sqliteBlobType) (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"varbinary"))
    Value
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Could not parse sqlite-specific data type"

-- | Render a series of 'Db.MigrationSteps' in the 'SqliteCommandSyntax' into a
-- line-by-line list of lazy 'BL'ByteString's. The output is suitable for
-- inclusion in a migration script. Comments are generated giving a description
-- of each migration step.
migrateScript :: Db.MigrationSteps Sqlite () a -> [BL.ByteString]
migrateScript :: forall a. MigrationSteps Sqlite () a -> [ByteString]
migrateScript MigrationSteps Sqlite () a
steps =
  ByteString
"-- Generated by beam-sqlite beam-migrate backend\n" forall a. a -> [a] -> [a]
:
  ByteString
"\n" forall a. a -> [a] -> [a]
:
  forall a. Endo a -> a -> a
appEndo (forall be m a.
(Monoid m, Semigroup m, BeamSqlBackend be) =>
(Text -> m)
-> (BeamSqlBackendSyntax be -> m) -> MigrationSteps be () a -> m
Db.migrateScript Text -> Endo [ByteString]
renderHeader SqliteCommandSyntax -> Endo [ByteString]
renderCommand MigrationSteps Sqlite () a
steps) []
  where
    renderHeader :: Text -> Endo [ByteString]
renderHeader Text
nm =
      forall a. (a -> a) -> Endo a
Endo ((ByteString
"-- " forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BL.fromStrict (Text -> ByteString
TE.encodeUtf8 Text
nm) forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")forall a. a -> [a] -> [a]
:)
    renderCommand :: SqliteCommandSyntax -> Endo [ByteString]
renderCommand SqliteCommandSyntax
cmd =
      forall a. (a -> a) -> Endo a
Endo ((SqliteSyntax -> ByteString
sqliteRenderSyntaxScript (SqliteCommandSyntax -> SqliteSyntax
fromSqliteCommand SqliteCommandSyntax
cmd) forall a. Semigroup a => a -> a -> a
<> ByteString
";\n")forall a. a -> [a] -> [a]
:)

-- | Write the output of 'migrateScript' to a file
writeMigrationScript :: FilePath -> Db.MigrationSteps Sqlite () a -> IO ()
writeMigrationScript :: forall a. [Char] -> MigrationSteps Sqlite () a -> IO ()
writeMigrationScript [Char]
fp MigrationSteps Sqlite () a
steps =
  let stepBs :: [ByteString]
stepBs = forall a. MigrationSteps Sqlite () a -> [ByteString]
migrateScript MigrationSteps Sqlite () a
steps
  in [Char] -> ByteString -> IO ()
BL.writeFile [Char]
fp ([ByteString] -> ByteString
BL.concat [ByteString]
stepBs)

-- | 'Tool.HaskellPredicateConverter' that can convert all constraints generated
-- by 'getDbConstaints' into their equivalent in the @beam-migrate@ haskell
-- syntax. Suitable for auto-generation of a haskell migration.
sqlitePredConverter :: Tool.HaskellPredicateConverter
sqlitePredConverter :: HaskellPredicateConverter
sqlitePredConverter = forall fromBe.
Typeable fromBe =>
(BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType)
-> HaskellPredicateConverter
Tool.sql92HsPredicateConverters @Sqlite SqliteDataTypeSyntax -> Maybe HsDataType
sqliteTypeToHs forall a. Semigroup a => a -> a -> a
<>
                      forall pred.
Typeable pred =>
(pred -> Maybe SomeDatabasePredicate) -> HaskellPredicateConverter
Tool.hsPredicateConverter TableColumnHasConstraint Sqlite -> Maybe SomeDatabasePredicate
sqliteHasColumnConstraint
  where
    sqliteHasColumnConstraint :: TableColumnHasConstraint Sqlite -> Maybe SomeDatabasePredicate
sqliteHasColumnConstraint (Db.TableColumnHasConstraint QualifiedName
tblNm Text
colNm BeamSqlBackendColumnConstraintDefinitionSyntax Sqlite
c ::
                                  Db.TableColumnHasConstraint Sqlite)
      | BeamSqlBackendColumnConstraintDefinitionSyntax Sqlite
c forall a. Eq a => a -> a -> Bool
== forall constraint.
IsSql92ColumnConstraintDefinitionSyntax constraint =>
Maybe Text
-> Sql92ColumnConstraintDefinitionConstraintSyntax constraint
-> Maybe
     (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)
-> constraint
Db.constraintDefinitionSyntax forall a. Maybe a
Nothing forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
Db.notNullConstraintSyntax forall a. Maybe a
Nothing =
        forall a. a -> Maybe a
Just (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
Db.SomeDatabasePredicate (forall be.
QualifiedName
-> Text
-> BeamSqlBackendColumnConstraintDefinitionSyntax be
-> TableColumnHasConstraint be
Db.TableColumnHasConstraint QualifiedName
tblNm Text
colNm (forall constraint.
IsSql92ColumnConstraintDefinitionSyntax constraint =>
Maybe Text
-> Sql92ColumnConstraintDefinitionConstraintSyntax constraint
-> Maybe
     (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)
-> constraint
Db.constraintDefinitionSyntax forall a. Maybe a
Nothing forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
Db.notNullConstraintSyntax forall a. Maybe a
Nothing) ::
                                           Db.TableColumnHasConstraint HsMigrateBackend))
      | Bool
otherwise = forall a. Maybe a
Nothing

-- | Convert a SQLite data type to the corresponding Haskell one
sqliteTypeToHs :: SqliteDataTypeSyntax
               -> Maybe HsDataType
sqliteTypeToHs :: SqliteDataTypeSyntax -> Maybe HsDataType
sqliteTypeToHs = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteDataTypeSyntax -> HsDataType
sqliteDataTypeToHs

parseSqliteDataType :: T.Text -> SqliteDataTypeSyntax
parseSqliteDataType :: Text -> SqliteDataTypeSyntax
parseSqliteDataType Text
txt =
  case forall a. Parser a -> Text -> Either [Char] a
A.parseOnly Parser Text SqliteDataTypeSyntax
dtParser Text
txt of
    Left {} -> SqliteSyntax
-> HsDataType
-> BeamSerializedDataType
-> Bool
-> SqliteDataTypeSyntax
SqliteDataTypeSyntax (ByteString -> SqliteSyntax
emit (Text -> ByteString
TE.encodeUtf8 Text
txt))
                                    ([Char] -> HsDataType
hsErrorType ([Char]
"Unknown SQLite datatype '" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
txt forall a. [a] -> [a] -> [a]
++ [Char]
"'"))
                                    (Value -> BeamSerializedDataType
Db.BeamSerializedDataType forall a b. (a -> b) -> a -> b
$
                                     Text -> Value -> Value
Db.beamSerializeJSON Text
"sqlite"
                                       (forall a. ToJSON a => a -> Value
toJSON Text
txt))
                                    Bool
False
    Right SqliteDataTypeSyntax
x -> SqliteDataTypeSyntax
x
  where
    dtParser :: Parser Text SqliteDataTypeSyntax
dtParser = Parser Text SqliteDataTypeSyntax
charP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
varcharP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
ncharP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
nvarcharP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
bitP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
varbitP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
numericP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
decimalP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
doubleP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
integerP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
smallIntP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
bigIntP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
floatP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
doubleP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
realP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
dateP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
timestampP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
timeP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
textP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               Parser Text SqliteDataTypeSyntax
blobP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SqliteDataTypeSyntax
booleanP

    ws :: Parser Text [Char]
ws = forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Char
A.space

    characterP :: Parser Text Text
characterP = Text -> Parser Text Text
asciiCI Text
"CHARACTER" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text Text
asciiCI Text
"CHAR"
    characterVaryingP :: Parser Text Text
characterVaryingP = Parser Text Text
characterP forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
asciiCI Text
"VARYING"
    charP :: Parser Text SqliteDataTypeSyntax
charP = do
      Parser Text Text
characterP
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
charType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text (Maybe Text)
charSetP
    varcharP :: Parser Text SqliteDataTypeSyntax
varcharP = do
      Text -> Parser Text Text
asciiCI Text
"VARCHAR" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
characterVaryingP
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
varCharType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text (Maybe Text)
charSetP
    ncharP :: Parser Text SqliteDataTypeSyntax
ncharP = do
      Text -> Parser Text Text
asciiCI Text
"NATIONAL"
      Parser Text [Char]
ws
      Parser Text Text
characterP
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
nationalCharType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP
    nvarcharP :: Parser Text SqliteDataTypeSyntax
nvarcharP = do
      Text -> Parser Text Text
asciiCI Text
"NVARCHAR" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text Text
asciiCI Text
"NATIONAL" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text Text
characterVaryingP)
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
nationalVarCharType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP
    bitP :: Parser Text SqliteDataTypeSyntax
bitP = do
      Text -> Parser Text Text
asciiCI Text
"BIT"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
bitType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP
    varbitP :: Parser Text SqliteDataTypeSyntax
varbitP = do
      Text -> Parser Text Text
asciiCI Text
"VARBIT" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text Text
asciiCI Text
"BIT" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
asciiCI Text
"VARYING")
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
varBitType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP

    numericP :: Parser Text SqliteDataTypeSyntax
numericP = do
      Text -> Parser Text Text
asciiCI Text
"NUMERIC"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe (Word, Maybe Word))
numericPrecP
    decimalP :: Parser Text SqliteDataTypeSyntax
decimalP = do
      Text -> Parser Text Text
asciiCI Text
"DECIMAL"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
decimalType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe (Word, Maybe Word))
numericPrecP
    floatP :: Parser Text SqliteDataTypeSyntax
floatP = do
      Text -> Parser Text Text
asciiCI Text
"FLOAT"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
floatType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP
    doubleP :: Parser Text SqliteDataTypeSyntax
doubleP = do
      Text -> Parser Text Text
asciiCI Text
"DOUBLE"
      forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser ()
skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
asciiCI Text
"PRECISION"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall dataType. IsSql92DataTypeSyntax dataType => dataType
doubleType
    realP :: Parser Text SqliteDataTypeSyntax
realP = forall dataType. IsSql92DataTypeSyntax dataType => dataType
realType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
asciiCI Text
"REAL"

    intTypeP :: Parser Text Text
intTypeP =
      Text -> Parser Text Text
asciiCI Text
"INT" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text Text
asciiCI Text
"INTEGER"
    integerP :: Parser Text SqliteDataTypeSyntax
integerP = do
      Parser Text Text
intTypeP
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType
    smallIntP :: Parser Text SqliteDataTypeSyntax
smallIntP = do
      Text -> Parser Text Text
asciiCI Text
"INT2" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text Text
asciiCI Text
"SMALL" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text Text
intTypeP)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall dataType. IsSql92DataTypeSyntax dataType => dataType
smallIntType
    bigIntP :: Parser Text SqliteDataTypeSyntax
bigIntP = do
      Text -> Parser Text Text
asciiCI Text
"INT8" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text Text
asciiCI Text
"BIG" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text Text
intTypeP)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure SqliteDataTypeSyntax
sqliteBigIntType
    dateP :: Parser Text SqliteDataTypeSyntax
dateP = forall dataType. IsSql92DataTypeSyntax dataType => dataType
dateType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
asciiCI Text
"DATE"
    timeP :: Parser Text SqliteDataTypeSyntax
timeP = do
      Text -> Parser Text Text
asciiCI Text
"TIME"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timeType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Bool
timezoneP
    timestampP :: Parser Text SqliteDataTypeSyntax
timestampP = do
      Text -> Parser Text Text
asciiCI Text
"TIMESTAMP"
      forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Word)
precP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Bool
timezoneP
    textP :: Parser Text SqliteDataTypeSyntax
textP = SqliteDataTypeSyntax
sqliteTextType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
asciiCI Text
"TEXT"
    blobP :: Parser Text SqliteDataTypeSyntax
blobP = SqliteDataTypeSyntax
sqliteBlobType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
asciiCI Text
"BLOB"

    booleanP :: Parser Text SqliteDataTypeSyntax
booleanP = forall dataType. IsSql99DataTypeSyntax dataType => dataType
booleanType forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> Parser Text Text
asciiCI Text
"BOOL" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text Text
asciiCI Text
"BOOLEAN")

    timezoneP :: Parser Text Bool
timezoneP = (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                 Text -> Parser Text Text
asciiCI Text
"WITH" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text [Char]
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                 (Text -> Parser Text Text
asciiCI Text
"TIMEZONE" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                  (Text -> Parser Text Text
asciiCI Text
"TIME" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                   Text -> Parser Text Text
asciiCI Text
"ZONE")) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    precP :: Parser Text (Maybe Word)
precP = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
A.char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                      forall a. Integral a => Parser a
A.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
')')
    numericPrecP :: Parser Text (Maybe (Word, Maybe Word))
numericPrecP = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
A.char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                                      forall a. Integral a => Parser a
A.decimal)
                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                                      forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Char
A.char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                                                 forall a. Integral a => Parser a
A.decimal) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
                                      Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
')'))

    charSetP :: Parser Text (Maybe Text)
charSetP = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                         Text -> Parser Text Text
asciiCI Text
"CHARACTER" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text [Char]
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                         Text -> Parser Text Text
asciiCI Text
"SET" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text [Char]
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                         (Char -> Bool) -> Parser Text Text
A.takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))

-- TODO constraints and foreign keys

-- | Get a list of database predicates for the current database. This is beam's
-- best guess at providing a schema for the current database. Note that SQLite
-- type names are not standardized, and the so-called column "affinities" are
-- too broad to be of use. This function attemps to guess a good enough type
-- based on the exact type supplied in the @CREATE TABLE@ commands. It will
-- correctly parse any type generated by beam and most SQL compliant types, but
-- it may falter on databases created or managed by tools that do not follow
-- these standards.
getDbConstraints :: SqliteM [Db.SomeDatabasePredicate]
getDbConstraints :: SqliteM [SomeDatabasePredicate]
getDbConstraints =
  forall a. ReaderT ([Char] -> IO (), Connection) IO a -> SqliteM a
SqliteM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \([Char] -> IO ()
_, Connection
conn) -> do
    [(Text, Text)]
tblNames <- forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT name, sql from sqlite_master where type='table'"
    [SomeDatabasePredicate]
tblPreds <-
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, Text)]
tblNames forall a b. (a -> b) -> a -> b
$ \(Text
tblNameStr, Text
sql) -> do
        let tblName :: QualifiedName
tblName = Maybe Text -> Text -> QualifiedName
QualifiedName forall a. Maybe a
Nothing Text
tblNameStr
        [(Int, Text, Text, Bool, Maybe Text, Int)]
columns <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Int
cid, Text
_, Text
_, Bool
_, Maybe Text
_, Int
_) -> Int
cid :: Int))) forall a b. (a -> b) -> a -> b
$
                   forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn (forall a. IsString a => [Char] -> a
fromString ([Char]
"PRAGMA table_info('" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
tblNameStr forall a. Semigroup a => a -> a -> a
<> [Char]
"')"))

        let columnPreds :: [SomeDatabasePredicate]
columnPreds =
              forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                (\(Int
_ ::Int, Text
nm, Text
typStr, Bool
notNull, Maybe Text
_, Int
_) ->
                     let dtType :: SqliteDataTypeSyntax
dtType = if Bool
isAutoincrement then SqliteDataTypeSyntax
sqliteSerialType else Text -> SqliteDataTypeSyntax
parseSqliteDataType Text
typStr
                         isAutoincrement :: Bool
isAutoincrement = forall a. Maybe a -> Bool
isJust (forall r. Result r -> Maybe r
A.maybeResult (forall a. Parser a -> Text -> Result a
A.parse Parser Text [Char]
autoincrementParser Text
sql))

                         autoincrementParser :: Parser Text [Char]
autoincrementParser = do
                           forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.manyTill Parser Char
A.anyChar forall a b. (a -> b) -> a -> b
$ do
                             Maybe Char
hadQuote <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Char
A.char Char
'"')
                             Text -> Parser Text Text
A.string Text
nm
                             forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\Char
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
'"') Maybe Char
hadQuote
                             forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Char
A.space
                             Text -> Parser Text Text
asciiCI Text
"INTEGER"
                             forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Char
A.space
                             Text -> Parser Text Text
asciiCI Text
"PRIMARY"
                             forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Char
A.space
                             Text -> Parser Text Text
asciiCI Text
"KEY"
                             forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Char
A.space
                             Text -> Parser Text Text
asciiCI Text
"AUTOINCREMENT"

                         notNullPred :: [SomeDatabasePredicate]
notNullPred =
                           if Bool
notNull
                           then [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
Db.SomeDatabasePredicate
                                    (forall be.
QualifiedName
-> Text
-> BeamSqlBackendColumnConstraintDefinitionSyntax be
-> TableColumnHasConstraint be
Db.TableColumnHasConstraint QualifiedName
tblName Text
nm
                                       (forall constraint.
IsSql92ColumnConstraintDefinitionSyntax constraint =>
Maybe Text
-> Sql92ColumnConstraintDefinitionConstraintSyntax constraint
-> Maybe
     (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)
-> constraint
Db.constraintDefinitionSyntax forall a. Maybe a
Nothing forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
Db.notNullConstraintSyntax forall a. Maybe a
Nothing)
                                         :: Db.TableColumnHasConstraint Sqlite) ]
                           else []

                     in [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
Db.SomeDatabasePredicate
                            (forall be.
HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) =>
QualifiedName
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> TableHasColumn be
Db.TableHasColumn QualifiedName
tblName Text
nm SqliteDataTypeSyntax
dtType ::
                               Db.TableHasColumn Sqlite) ] forall a. [a] -> [a] -> [a]
++
                        [SomeDatabasePredicate]
notNullPred
                )
                [(Int, Text, Text, Bool, Maybe Text, Int)]
columns

            pkColumns :: [Text]
pkColumns = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
                        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int
_, Text
nm, Text
_, Bool
_, Maybe Text
_ :: Maybe T.Text, Int
pk) ->
                                      (Text
nm,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
pk forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
pk forall a. Ord a => a -> a -> Bool
> (Int
0 :: Int)))) [(Int, Text, Text, Bool, Maybe Text, Int)]
columns
            pkPred :: [SomeDatabasePredicate]
pkPred = case [Text]
pkColumns of
                       [] -> []
                       [Text]
_  -> [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
Db.SomeDatabasePredicate (QualifiedName -> [Text] -> TableHasPrimaryKey
Db.TableHasPrimaryKey QualifiedName
tblName [Text]
pkColumns) ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
Db.SomeDatabasePredicate (QualifiedName -> TableExistsPredicate
Db.TableExistsPredicate QualifiedName
tblName) ]
             forall a. [a] -> [a] -> [a]
++ [SomeDatabasePredicate]
pkPred forall a. [a] -> [a] -> [a]
++ [SomeDatabasePredicate]
columnPreds )

    forall (f :: * -> *) a. Applicative f => a -> f a
pure [SomeDatabasePredicate]
tblPreds

sqliteText :: Db.DataType Sqlite T.Text
sqliteText :: DataType Sqlite Text
sqliteText = forall be a. BeamSqlBackendCastTargetSyntax be -> DataType be a
Db.DataType SqliteDataTypeSyntax
sqliteTextType

sqliteBlob :: Db.DataType Sqlite ByteString
sqliteBlob :: DataType Sqlite ByteString
sqliteBlob = forall be a. BeamSqlBackendCastTargetSyntax be -> DataType be a
Db.DataType SqliteDataTypeSyntax
sqliteBlobType

sqliteBigInt :: Db.DataType Sqlite Int64
sqliteBigInt :: DataType Sqlite Int64
sqliteBigInt = forall be a. BeamSqlBackendCastTargetSyntax be -> DataType be a
Db.DataType SqliteDataTypeSyntax
sqliteBigIntType