groundhog-sqlite 0.5.1 → 0.6.0
raw patch · 3 files changed
+38/−51 lines, 3 filesdep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: groundhog
API changes (from Hackage documentation)
Files
- Database/Groundhog/Sqlite.hs +32/−49
- changelog +4/−0
- groundhog-sqlite.cabal +2/−2
Database/Groundhog/Sqlite.hs view
@@ -88,17 +88,21 @@ getList k = getList' k instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist Sqlite m) where- schemaExists = error "schemaExists: is not supported by Sqlite"+ schemaExists = fail "schemaExists: is not supported by Sqlite" getCurrentSchema = return Nothing- listTables _ = queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] (mapAllRows $ return . fst . fromPurePersistValues proxy)- listTableTriggers _ name = queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)+ listTables Nothing = queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] (mapAllRows $ return . fst . fromPurePersistValues proxy)+ listTables sch = fail $ "listTables: schemas are not supported by Sqlite: " ++ show sch+ listTableTriggers Nothing name = queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)+ listTableTriggers sch _ = fail $ "listTableTriggers: schemas are not supported by Sqlite: " ++ show sch analyzeTable = analyzeTable'- analyzeTrigger _ name = do+ analyzeTrigger Nothing name = do x <- queryRaw' "SELECT sql FROM sqlite_master WHERE type='trigger' AND name=?" [toPrimitivePersistValue proxy name] id case x of Nothing -> return Nothing Just src -> return (fst $ fromPurePersistValues proxy src)+ analyzeTrigger sch _ = fail $ "analyzeTrigger: schemas are not supported by Sqlite: " ++ show sch analyzeFunction = error "analyzeFunction: is not supported by Sqlite"+ getMigrationPack = return migrationPack withSqlitePool :: (MonadBaseControl IO m, MonadIO m) => String -- ^ connection string@@ -170,11 +174,13 @@ mainTableId defaultPriority addUniquesReferences+ showSqlType showColumn showAlterDb NoAction+ NoAction -addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable])+addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable]) addUniquesReferences uniques refs = (map sqlUnique constraints ++ map sqlReference refs, map AddUnique indexes) where (constraints, indexes) = partition ((/= UniqueIndex) . uniqueDefType) uniques @@ -206,7 +212,7 @@ else [DropTrigger Nothing trigName Nothing name, addTrigger]) analyzeTable' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Sqlite m (Maybe TableInfo)-analyzeTable' _ tName = do+analyzeTable' Nothing tName = do let fromName = escapeS . fromString tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) case tableInfo of@@ -225,7 +231,7 @@ uType = if sql == Just [PersistNull] then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary False else UniqueConstraint else UniqueIndex- return $ UniqueDef' (Just name) uType columnNames+ return $ UniqueDef (Just name) uType (map Left columnNames) foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) (foreigns :: [(Maybe String, Reference)]) <- do let foreigns :: [[(Int, (Int, String, (String, Maybe String), (String, String, String)))]]@@ -246,9 +252,10 @@ _ -> True uniques' = uniques ++ if all (notPrimary . uniqueDefType) uniques && not (null primaryKeyColumnNames)- then [UniqueDef' Nothing (UniquePrimary True) primaryKeyColumnNames]+ then [UniqueDef Nothing (UniquePrimary True) (map Left primaryKeyColumnNames)] else [] return $ Just $ TableInfo columns uniques' foreigns+analyzeTable' sch _ = fail $ "analyzeTable: schemas are not supported by Sqlite: " ++ show sch analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> DbPersist Sqlite m (Maybe [String]) analyzePrimaryKey tName = do@@ -289,8 +296,7 @@ DbDayTime -> "TIMESTAMP" DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE" DbBlob -> "BLOB"- DbAutoKey -> "INTEGER"- DbOther (OtherTypeDef f) -> f showSqlType+ DbOther (OtherTypeDef ts) -> concatMap (either id showSqlType) ts readSqlType :: String -> DbTypePrimitive readSqlType "VARCHAR" = DbString@@ -302,7 +308,7 @@ readSqlType "TIMESTAMP" = DbDayTime readSqlType "TIMESTAMP WITH TIME ZONE" = DbDayTimeZoned readSqlType "BLOB" = DbBlob-readSqlType typ = DbOther $ OtherTypeDef $ const typ+readSqlType typ = DbOther $ OtherTypeDef [Left typ] data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show) @@ -332,11 +338,11 @@ (our, foreign) = f *** f $ unzip referencedColumns f = intercalate ", " . map escape -sqlUnique :: UniqueDef' -> String-sqlUnique (UniqueDef' name typ cols) = concat [+sqlUnique :: UniqueDefInfo -> String+sqlUnique (UniqueDef name typ cols) = concat [ maybe "" (\x -> "CONSTRAINT " ++ escape x ++ " ") name , constraintType- , intercalate "," $ map escape cols+ , intercalate "," $ map (either escape id) cols , ")" ] where constraintType = case typ of@@ -348,7 +354,7 @@ insert' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v- let e = entityDef v+ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue proxy (head vals) liftM fst $ if isSimple (constructors e)@@ -372,7 +378,7 @@ insert_' v = do -- constructor number and the rest of the field values vals <- toEntityPersistValues' v- let e = entityDef v+ let e = entityDef proxy v let constructorNum = fromPrimitivePersistValue proxy (head vals) if isSimple (constructors e)@@ -393,7 +399,7 @@ insertIntoConstructorTable withId tName c vals = RenderS query vals' where query = "INSERT INTO " <> tName <> columnsValues fields = case constrAutoKeyName c of- Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c+ Just idName | withId -> (idName, dbType proxy (0 :: Int64)):constrParams c _ -> constrParams c columnsValues = case foldr (flatten escapeS) [] fields of [] -> " DEFAULT VALUES"@@ -406,7 +412,7 @@ executeRawCached' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES") [] k <- getLastInsertRowId let valuesName = mainName <> delim' <> "values"- let fields = [("ord", dbType (0 :: Int)), ("value", dbType (undefined :: a))]+ let fields = [("ord", dbType proxy (0 :: Int)), ("value", dbType proxy (undefined :: a))] let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")" let go :: Int -> [a] -> DbPersist Sqlite m () go n (x:xs) = do@@ -420,9 +426,9 @@ getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => Int64 -> DbPersist Sqlite m [a] getList' k = do let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))- let valuesName = mainName <> delim' <> "values"- let value = ("value", dbType (undefined :: a))- let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"+ valuesName = mainName <> delim' <> "values"+ value = ("value", dbType proxy (undefined :: a))+ query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord" queryRawCached' query [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues) getLastInsertRowId :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => DbPersist Sqlite m PersistValue@@ -492,29 +498,6 @@ S.Done -> return Nothing S.Row -> fmap (Just . map pFromSql) $ S.columns stmt -typeToSqlite :: DbType -> Maybe S.ColumnType-typeToSqlite (DbTypePrimitive t nullable _ _) = case t of- _ | nullable -> Nothing- DbOther _ -> Nothing- DbString -> Just S.TextColumn- DbInt32 -> Just S.IntegerColumn- DbInt64 -> Just S.IntegerColumn- DbReal -> Just S.FloatColumn- DbBool -> Just S.IntegerColumn- DbDay -> Just S.TextColumn- DbTime -> Just S.TextColumn- DbDayTime -> Just S.TextColumn- DbDayTimeZoned -> Just S.TextColumn- DbBlob -> Just S.BlobColumn- DbAutoKey -> Just S.IntegerColumn-typeToSqlite (DbList _ _) = Just S.IntegerColumn-typeToSqlite t@(DbEmbedded _ _) = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t--getDbTypes :: DbType -> [DbType] -> [DbType]-getDbTypes typ acc = case typ of- DbEmbedded (EmbeddedDef _ ts) _ -> foldr (getDbTypes . snd) acc ts- t -> t:acc- pFromSql :: S.SQLData -> PersistValue pFromSql (S.SQLInteger i) = PersistInt64 i pFromSql (S.SQLFloat i) = PersistDouble i@@ -547,9 +530,9 @@ toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistEntity v) => v -> DbPersist Sqlite m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues -compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-compareUniqs (UniqueDef' _ (UniquePrimary _) cols1) (UniqueDef' _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2-compareUniqs (UniqueDef' _ type1 cols1) (UniqueDef' _ type2 cols2) = haveSameElems (==) cols1 cols2 && type1 == type2+compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool+compareUniqs (UniqueDef _ (UniquePrimary _) cols1) (UniqueDef _ (UniquePrimary _) cols2) = haveSameElems (==) cols1 cols2+compareUniqs (UniqueDef _ type1 cols1) (UniqueDef _ type2 cols2) = haveSameElems (==) cols1 cols2 && type1 == type2 compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool compareRefs (_, Reference _ tbl1 pairs1 onDel1 onUpd1) (_, Reference _ tbl2 pairs2 onDel2 onUpd2) =@@ -612,13 +595,13 @@ , escape (colName col) , " IS NULL" ])-showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = Just (False, defaultPriority, concat+showAlterTable table (AddUnique (UniqueDef uName UniqueIndex cols)) = Just (False, defaultPriority, concat [ "CREATE UNIQUE INDEX " , maybe (error $ "showAlterTable: index for table " ++ table ++ " does not have a name") escape uName , " ON " , escape table , "("- , intercalate "," $ map escape cols+ , intercalate "," $ map (either escape id) cols , ")" ]) showAlterTable _ (DropIndex uName) = Just (False, defaultPriority, concat
changelog view
@@ -1,3 +1,7 @@+0.6.0+* Entity and fields descriptions are parameterized so that they can be promoted+* Entity and fields descriptions are dependent on database proxy. It allows to use different types depending on a database, for example, the same type can be array[] in PostgreSQL and varchar elsewhere+ 0.5.1 * Add getCurrentSchema function into SchemaAnalyzer
groundhog-sqlite.cabal view
@@ -1,5 +1,5 @@ name: groundhog-sqlite-version: 0.5.1+version: 0.6.0 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -18,7 +18,7 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1- , groundhog >= 0.5.0 && < 0.6.0+ , groundhog >= 0.6 && < 0.7 , monad-control >= 0.3 && < 0.4 , monad-logger >= 0.3 && < 0.4 , containers >= 0.2