groundhog-sqlite 0.5.0 → 0.5.1
raw patch · 3 files changed
+50/−39 lines, 3 filesdep ~monad-controldep ~monad-loggerPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: monad-control, monad-logger
API changes (from Hackage documentation)
Files
- Database/Groundhog/Sqlite.hs +36/−28
- changelog +3/−0
- groundhog-sqlite.cabal +11/−11
Database/Groundhog/Sqlite.hs view
@@ -36,6 +36,7 @@ import Data.IORef import qualified Data.HashMap.Strict as Map import Data.Maybe (fromMaybe)+import Data.Monoid import Data.Pool import qualified Data.Text as T @@ -65,7 +66,7 @@ insertByAll v = H.insertByAll renderConfig queryRawCached' True v replace k v = H.replace renderConfig queryRawCached' executeRawCached' insertIntoConstructorTable k v replaceBy k v = H.replaceBy renderConfig executeRawCached' k v- select options = H.select renderConfig queryRawCached' "LIMIT -1" options+ select options = H.select renderConfig queryRawCached' preColumns "LIMIT -1" options selectAll = H.selectAll renderConfig queryRawCached' get k = H.get renderConfig queryRawCached' k getBy k = H.getBy renderConfig queryRawCached' k@@ -75,7 +76,7 @@ deleteAll v = H.deleteAll renderConfig executeRawCached' v count cond = H.count renderConfig queryRawCached' cond countAll fakeV = H.countAll renderConfig queryRawCached' fakeV- project p options = H.project renderConfig queryRawCached' "LIMIT -1" p options+ project p options = H.project renderConfig queryRawCached' preColumns "LIMIT -1" p options migrate fakeV = migrate' fakeV executeRaw False query ps = executeRaw' (fromString query) ps@@ -88,6 +89,7 @@ instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist Sqlite m) where schemaExists = error "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) analyzeTable = analyzeTable'@@ -212,16 +214,16 @@ rawColumns -> do let mkColumn :: (Int, (String, String, Int, Maybe String, Int)) -> Column mkColumn (_, (name, typ, isNotNull, defaultValue, _)) = Column name (isNotNull == 0) (readSqlType typ) defaultValue- let primaryKeyColumnNames = foldr (\(_ , (name, _, _, _, isPrimary)) xs -> if isPrimary == 1 then name:xs else xs) [] rawColumns- let columns = map mkColumn rawColumns+ primaryKeyColumnNames = foldr (\(_ , (name, _, _, _, primaryIndex)) xs -> if primaryIndex > 0 then name:xs else xs) [] rawColumns+ columns = map mkColumn rawColumns indexList <- queryRaw' ("pragma index_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) let uniqueNames = map (\(_ :: Int, name, _) -> name) $ filter (\(_, _, isUnique) -> isUnique) indexList uniques <- forM uniqueNames $ \name -> do uFields <- queryRaw' ("pragma index_info(" <> fromName name <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy) sql <- queryRaw' ("select sql from sqlite_master where type = 'index' and name = ?") [toPrimitivePersistValue proxy name] id let columnNames = map (\(_, _, columnName) -> columnName) (uFields :: [(Int, Int, String)])- let uType = if sql == Just [PersistNull]- then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary else UniqueConstraint+ uType = if sql == Just [PersistNull]+ then if sort columnNames == sort primaryKeyColumnNames then UniquePrimary False else UniqueConstraint else UniqueIndex return $ UniqueDef' (Just name) uType columnNames foreignKeyList <- queryRaw' ("pragma foreign_key_list(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)@@ -231,28 +233,31 @@ mkAction c = Just $ fromMaybe (error $ "unknown reference action type: " ++ c) $ readReferenceAction c forM foreigns $ \rows -> do let (_, (_, foreignTable, _, (onUpdate, onDelete, _))) = head rows- refs <- forM rows $ \(_, (_, _, (child, parent), _)) -> case parent of+ (children, parents) = unzip $ map (\(_, (_, _, pair, _)) -> pair) rows+ parents' <- case head parents of Nothing -> analyzePrimaryKey foreignTable >>= \x -> case x of- Just primaryKeyName -> return (child, primaryKeyName)+ Just primaryCols -> return primaryCols Nothing -> error $ "analyzeTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"- Just columnName -> return (child, columnName)+ Just _ -> return $ map (fromMaybe (error "analyzeTable: all parents must be either NULL or values")) parents+ let refs = zip children parents' return (Nothing, Reference Nothing foreignTable refs (mkAction onDelete) (mkAction onUpdate))- let uniques' = uniques ++ - if all ((/= UniquePrimary) . uniqueDefType) uniques && not (null primaryKeyColumnNames)- then [UniqueDef' Nothing UniquePrimary primaryKeyColumnNames]+ let notPrimary x = case x of+ UniquePrimary _ -> False+ _ -> True+ uniques' = uniques ++ + if all (notPrimary . uniqueDefType) uniques && not (null primaryKeyColumnNames)+ then [UniqueDef' Nothing (UniquePrimary True) primaryKeyColumnNames] else [] return $ Just $ TableInfo columns uniques' foreigns -analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> DbPersist Sqlite m (Maybe String)+analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> DbPersist Sqlite m (Maybe [String]) analyzePrimaryKey tName = do tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)- let rawColumns :: [(Int, (String, String, Int, Maybe String, Int))]- rawColumns = filter (\(_ , (_, _, _, _, isPrimary)) -> isPrimary == 1) tableInfo- return $ case rawColumns of- [(_, (name, _, _, _, _))] -> Just name- -- if the list is empty, there is no primary key- -- if the list has more than 1 element, the key is read by pragma index_list as a unique constraint in another place- _ -> Nothing+ let cols = map (\(_ , (name, _, _, _, primaryIndex)) -> (primaryIndex, name)) (tableInfo :: [(Int, (String, String, Int, Maybe String, Int))])+ cols' = map snd $ sort $ filter ((> 0) . fst) cols+ return $ if null cols'+ then Nothing+ else Just cols' getStatementCached :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> DbPersist Sqlite m S.Statement getStatementCached sql = do@@ -329,14 +334,14 @@ sqlUnique :: UniqueDef' -> String sqlUnique (UniqueDef' name typ cols) = concat [- maybe "" ((" CONSTRAINT " ++) . escape) name+ maybe "" (\x -> "CONSTRAINT " ++ escape x ++ " ") name , constraintType , intercalate "," $ map escape cols , ")" ] where constraintType = case typ of- UniquePrimary -> " PRIMARY KEY("- UniqueConstraint -> " UNIQUE("+ UniquePrimary _ -> "PRIMARY KEY("+ UniqueConstraint -> "UNIQUE(" UniqueIndex -> error "sqlUnique: does not handle indexes" insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Sqlite m (AutoKey v)@@ -386,11 +391,13 @@ -- TODO: In Sqlite we can insert null to the id column. If so, id will be generated automatically. Check performance change from this. insertIntoConstructorTable :: Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r insertIntoConstructorTable withId tName c vals = RenderS query vals' where- query = "INSERT INTO " <> tName <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")"+ query = "INSERT INTO " <> tName <> columnsValues fields = case constrAutoKeyName c of Just idName | withId -> (idName, dbType (0 :: Int64)):constrParams c _ -> constrParams c- fieldNames = renderFields escapeS fields+ columnsValues = case foldr (flatten escapeS) [] fields of+ [] -> " DEFAULT VALUES"+ xs -> "(" <> commasJoin xs <> ") VALUES(" <> placeholders <> ")" RenderS placeholders vals' = commasJoin $ map renderPersistValue vals insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist Sqlite m Int64@@ -541,9 +548,7 @@ toEntityPersistValues' = liftM ($ []) . toEntityPersistValues compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2--- only one of the uniques is primary-compareUniqs (UniqueDef' _ type1 _) (UniqueDef' _ type2 _) | UniquePrimary `elem` [type1, type2] = False+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@@ -621,3 +626,6 @@ , escape uName ]) showAlterTable _ _ = Nothing++preColumns :: HasSelectOptions opts db r => opts -> RenderS db r+preColumns _ = mempty
changelog view
@@ -1,3 +1,6 @@+0.5.1+* Add getCurrentSchema function into SchemaAnalyzer+ 0.5.0 * Compatibility with GHC 7.8
groundhog-sqlite.cabal view
@@ -1,5 +1,5 @@ name: groundhog-sqlite-version: 0.5.0+version: 0.5.1 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -15,16 +15,16 @@ changelog library- build-depends: base >= 4 && < 5- , bytestring >= 0.9- , transformers >= 0.2.1- , groundhog >= 0.5.0 && < 0.6.0- , monad-control >= 0.3- , monad-logger >= 0.3- , containers >= 0.2- , text >= 0.8- , direct-sqlite >= 2.3.5- , resource-pool >= 0.2.1+ build-depends: base >= 4 && < 5+ , bytestring >= 0.9+ , transformers >= 0.2.1+ , groundhog >= 0.5.0 && < 0.6.0+ , monad-control >= 0.3 && < 0.4+ , monad-logger >= 0.3 && < 0.4+ , containers >= 0.2+ , text >= 0.8+ , direct-sqlite >= 2.3.5+ , resource-pool >= 0.2.1 , unordered-containers exposed-modules: Database.Groundhog.Sqlite ghc-options: -Wall -fno-warn-unused-do-bind