diff --git a/.github/workflows/hlint.yaml b/.github/workflows/hlint.yaml new file mode 100644 index 0000000..86098e9 --- /dev/null +++ b/.github/workflows/hlint.yaml @@ -0,0 +1,34 @@ +name: Hlint + +on: + pull_request: + paths: + - "**.hs" + - .github/workflows/hlint.yaml + push: + paths: + - "**.hs" + - .github/workflows/hlint.yaml + branches: + - master + +concurrency: + group: hpqtypes-extras-hlint-${{ github.ref_name }} + cancel-in-progress: true + +jobs: + hlint: + runs-on: + - ubuntu-22.04 + steps: + # v3.5.3 + - uses: actions/checkout@c85c95e3d7251135ab7dc9ce3241c5835cc595a9 + # v2.4.6 + - uses: haskell/actions/hlint-setup@a99601b177e00b98c78b6f6de680a101cf1c619d + with: + version: 3.5 + # v2.4.6 + - uses: haskell/actions/hlint-run@a99601b177e00b98c78b6f6de680a101cf1c619d + with: + path: ./ + fail-on: warning diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs index 9de6fa1..08a630e 100644 --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -23,7 +23,6 @@ import Data.Function import Data.List (partition) import Data.Maybe import Data.Monoid.Utils -import Data.Ord (comparing) import Data.Typeable (cast) import qualified Data.String import Data.Text (Text) @@ -112,8 +111,7 @@ checkDatabase options composites domains tables = do where checkInitialSetups :: [Table] -> m ValidationResult - checkInitialSetups tbls = - liftM mconcat . mapM checkInitialSetup' $ tbls + checkInitialSetups = fmap mconcat . mapM checkInitialSetup' checkInitialSetup' :: Table -> m ValidationResult checkInitialSetup' t@Table{..} = case tblInitialSetup of @@ -158,7 +156,7 @@ setDBTimeZoneToUTC = do <> "' database to return timestamps in UTC" runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'" -- Setting the database timezone doesn't change the session timezone. - runSQL_ $ "SET timezone = 'UTC'" + runSQL_ "SET timezone = 'UTC'" -- | Get the names of all user-defined tables that actually exist in -- the DB. @@ -171,9 +169,7 @@ getDBTableNames = do sqlWhereExists $ sqlSelect "unnest(current_schemas(false)) as cs" $ do sqlResult "TRUE" sqlWhere "cs = table_schema" - - dbTableNames <- fetchMany runIdentity - return dbTableNames + fetchMany runIdentity checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult checkVersions options = mconcat . map checkVersion @@ -204,8 +200,8 @@ checkUnknownTables tables = do mapM_ (logInfo_ . (<+>) "Unknown table:") absent mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent return $ - (validateIsNull "Unknown tables:" absent) <> - (validateIsNull "Tables not present in the database:" notPresent) + validateIsNull "Unknown tables:" absent <> + validateIsNull "Tables not present in the database:" notPresent else return mempty validateIsNull :: Text -> [Text] -> ValidationResult @@ -232,8 +228,8 @@ checkExistenceOfVersionsForTables tables = do mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':") notPresent return $ - (validateIsNull "Unknown entry in table_versions':" absent ) <> - (validateIsNull "Tables not present in the 'table_versions':" notPresent) + validateIsNull "Unknown entry in table_versions':" absent <> + validateIsNull "Tables not present in the 'table_versions':" notPresent else return mempty @@ -445,7 +441,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) , colType = ctype , colCollation = flip rawSQL () <$> collation , colNullable = nullable - , colDefault = unsafeSQL `liftM` mdefault + , colDefault = unsafeSQL <$> mdefault } checkColumns @@ -465,8 +461,8 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -- sequences as they're implicitly specified by db, so -- let's omit them in such case. , validateDefaults $ colDefault d == colDefault c || - (colDefault d == Nothing - && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c) + (isNothing (colDefault d) + && (T.isPrefixOf "nextval('" . unRawSQL <$> colDefault c) == Just True) , validateNullables $ colNullable d == colNullable c , checkColumns (n+1) defs cols @@ -489,7 +485,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) validateDefaults True = mempty validateDefaults False = validationError $ - (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) + errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault) <+> sqlHint set_default where set_default = case colDefault d of @@ -510,7 +506,7 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) checkPrimaryKey mdef mpk = mconcat [ checkEquality "PRIMARY KEY" def (map fst pk) , checkNames (const (pkName tblName)) pk - , if (eoEnforcePKs options) + , if eoEnforcePKs options then checkPKPresence tblName mdef mpk else mempty ] @@ -615,7 +611,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a errorInvalidMigrations tblNames = error $ "checkDBConsistency: invalid migrations for tables" - <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames) + <+> L.intercalate ", " (map (T.unpack . unRawSQL) tblNames) checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m () checkMigrationsListValidity table presentMigrationVersions @@ -626,7 +622,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do , "migration_versions" .= presentMigrationVersions , "expected_migration_versions" .= expectedMigrationVersions ] - errorInvalidMigrations [tblName $ table] + errorInvalidMigrations [tblName table] validateMigrations :: m () validateMigrations = forM_ tables $ \table -> do @@ -643,15 +639,15 @@ checkDBConsistency options domains tablesWithVersions migrations = do validateDropTableMigrations :: m () validateDropTableMigrations = do let droppedTableNames = - [ mgrTableName $ mgr | mgr <- migrations - , isDropTableMigration mgr ] + [ mgrTableName mgr | mgr <- migrations + , isDropTableMigration mgr ] tableNames = [ tblName tbl | tbl <- tables ] -- Check that the intersection between the 'tables' list and -- dropped tables is empty. let intersection = L.intersect droppedTableNames tableNames - when (not . null $ intersection) $ do + unless (null intersection) $ do logAttention ("The intersection between tables " <> "and dropped tables is not empty") $ object @@ -672,7 +668,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do , (not . isDropTableMigration . last $ mgrs) || (length . filter isDropTableMigration $ mgrs) > 1 ] - when (not . null $ invalidMigrationLists) $ do + unless (null invalidMigrationLists) $ do let tablesWithInvalidMigrationLists = [ mgrTableName mgr | mgrs <- invalidMigrationLists , let mgr = head mgrs ] @@ -731,7 +727,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do | mgr <- migrations , isDropTableMigration mgr , let tblName = mgrTableName mgr - , let mver = lookup (unRawSQL tblName) $ dbTablesWithVersions + , let mver = lookup (unRawSQL tblName) dbTablesWithVersions , isJust mver ] forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) -> when (fromVer /= ver) $ @@ -767,8 +763,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do (not . droppedEventually $ mgr) -- Table exists in the DB. Run only those migrations -- that have mgrFrom >= table version in the DB. - Just ver -> not $ - mgrFrom mgr >= ver) + Just ver -> mgrFrom mgr < ver) migrations -- Special case: also include migrations for tables that do @@ -802,7 +797,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do else [] in migrationsToRun - runMigration :: (Migration m) -> m () + runMigration :: Migration m -> m () runMigration Migration{..} = do case mgrAction of StandardMigration mgrDo -> do @@ -910,7 +905,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do runMigrations dbTablesWithVersions = do let migrationsToRun = findMigrationsToRun dbTablesWithVersions validateMigrationsToRun migrationsToRun dbTablesWithVersions - when (not . null $ migrationsToRun) $ do + unless (null migrationsToRun) $ do logInfo_ "Running migrations..." forM_ migrationsToRun $ \mgr -> fix $ \loop -> do let restartMigration query = do @@ -922,7 +917,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout runMigration mgr `onException` rollback - logInfo_ $ "Committing migration changes..." + logInfo_ "Committing migration changes..." commit logInfo_ "Running migrations... done." where @@ -941,7 +936,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do let migrationsToRunGrouped :: [[Migration m]] migrationsToRunGrouped = L.groupBy ((==) `on` mgrTableName) . - L.sortBy (comparing mgrTableName) $ -- NB: stable sort + L.sortOn mgrTableName $ -- NB: stable sort migrationsToRun loc_common = "Database.PostgreSQL.PQTypes.Checks." @@ -998,7 +993,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do where head_err = loc_common ++ ".tblNames: broken invariant" - when (not . null $ groupsWithWrongDBTableVersions) $ do + unless (null groupsWithWrongDBTableVersions) $ do let tnms = tblNames . map fst $ groupsWithWrongDBTableVersions logAttention ("There are migration chains selected for execution " @@ -1008,14 +1003,14 @@ checkDBConsistency options domains tablesWithVersions migrations = do $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms - when (not . null $ groupsStartingWithDropTable) $ do + unless (null groupsStartingWithDropTable) $ do let tnms = tblNames groupsStartingWithDropTable logAttention "There are drop table migrations for non-existing tables." $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms -- NB: the following check can break if we allow renaming tables. - when (not . null $ groupsNotStartingWithCreateTable) $ do + unless (null groupsNotStartingWithCreateTable) $ do let tnms = tblNames groupsNotStartingWithCreateTable logAttention ("Some tables haven't been created yet, but" <> @@ -1055,7 +1050,7 @@ checkTableVersion tblName = do doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do sqlResult "TRUE" sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace" - sqlWhereEq "c.relname" $ tblName + sqlWhereEq "c.relname" tblName sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" if doesExist then do @@ -1123,13 +1118,13 @@ sqlGetPrimaryKey table = do sqlWhereEqSql "c.conrelid" $ sqlGetTableID table sqlResult "c.conname::text" sqlResult $ Data.String.fromString - ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]") + ("array['" <> mintercalate "', '" columnNames <> "']::text[]") join <$> fetchMaybe fetchPrimaryKey fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()) fetchPrimaryKey (name, Array1 columns) = (, unsafeSQL name) - <$> (pkOnColumns $ map unsafeSQL columns) + <$> pkOnColumns (map unsafeSQL columns) -- *** CHECKS *** @@ -1190,7 +1185,7 @@ fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, , idxMethod = read method , idxUnique = unique , idxValid = valid - , idxWhere = unsafeSQL `liftM` mconstraint + , idxWhere = unsafeSQL <$> mconstraint } , unsafeSQL name) diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs index a0d2333..6ce7b19 100644 --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -39,13 +39,11 @@ createTable withConstraints table@Table{..} = do sqlSet "version" tblVersion createTableConstraints :: MonadDB m => Table -> m () -createTableConstraints Table{..} = when (not $ null addConstraints) $ do +createTableConstraints Table{..} = unless (null addConstraints) $ do runQuery_ $ sqlAlterTable tblName addConstraints where - addConstraints = concat - [ map sqlAddValidCheckMaybeDowntime tblChecks - , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys - ] + addConstraints = map sqlAddValidCheckMaybeDowntime tblChecks + ++ map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys createTableTriggers :: MonadDB m => Table -> m () createTableTriggers = mapM_ createTrigger . tblTriggers diff --git a/test/Main.hs b/test/Main.hs index 9364788..fc85f8f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use head" #-} module Main where import Control.Monad.Catch @@ -31,7 +33,7 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Options -data ConnectionString = ConnectionString String +newtype ConnectionString = ConnectionString String deriving Typeable instance IsOption ConnectionString where @@ -104,8 +106,8 @@ tableBankMigration4 = Migration tableBankSchema4 :: Table tableBankSchema4 = tableBankSchema3 { - tblVersion = (tblVersion tableBankSchema3) + 1 - , tblColumns = (tblColumns tableBankSchema3) ++ [ + tblVersion = tblVersion tableBankSchema3 + 1 + , tblColumns = tblColumns tableBankSchema3 ++ [ tblColumn { colName = "cash", colType = IntegerT , colNullable = False @@ -121,7 +123,7 @@ tableBankMigration5fst = Migration , mgrFrom = 2 , mgrAction = StandardMigration $ do runQuery_ $ sqlAlterTable (tblName tableBankSchema4) [ - sqlDropColumn $ "cash" + sqlDropColumn "cash" ] } @@ -136,7 +138,7 @@ tableBankMigration5snd = Migration tableBankSchema5 :: Table tableBankSchema5 = tableBankSchema4 { - tblVersion = (tblVersion tableBankSchema4) + 2 + tblVersion = tblVersion tableBankSchema4 + 2 , tblColumns = filter (\c -> colName c /= "cash") (tblColumns tableBankSchema4) , tblIndexes = [(indexOnColumn "name") { idxInclude = ["id", "location"] }] @@ -428,7 +430,7 @@ schema6Tables = , tableBadGuySchema1 , tableRobberySchema1 , tableParticipatedInRobberySchema1 - { tblVersion = (tblVersion tableParticipatedInRobberySchema1) + 1, + { tblVersion = tblVersion tableParticipatedInRobberySchema1 + 1, tblPrimaryKey = Nothing } , tableWitnessSchema1 , tableWitnessedRobberySchema1 @@ -441,8 +443,8 @@ schema6Migrations = , mgrFrom = tblVersion tableParticipatedInRobberySchema1 , mgrAction = StandardMigration $ do - runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \ - \pk__participated_in_robbery" :: RawSQL ()) + runQuery_ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \ + \pk__participated_in_robbery" :: RawSQL ()) } @@ -1172,7 +1174,7 @@ testTriggers step = do verify triggers present = do dbTriggers <- getDBTriggers "bank" let trgs = map fst dbTriggers - ok = and $ map (`elem` trgs) triggers + ok = all (`elem` trgs) triggers err = "Triggers " <> (if present then "" else "not ") <> "present in the database." trans = if present then id else not liftIO . assertBool err $ trans ok @@ -1217,8 +1219,8 @@ testSqlWith step = do migrate [tableBankSchema1] [createTableMigration tableBankSchema1] step "inserting initial data" runQuery_ . sqlInsert "bank" $ do - sqlSetList "name" (["HSBC" :: T.Text, "other"]) - sqlSetList "location" (["13 Foo St., Tucson" :: T.Text, "no address"]) + sqlSetList "name" ["HSBC" :: T.Text, "other"] + sqlSetList "location" ["13 Foo St., Tucson" :: T.Text, "no address"] sqlResult "id" step "testing WITH .. INSERT SELECT" runQuery_ . sqlInsertSelect "bank" "bank_name" $ do @@ -1337,16 +1339,16 @@ migrationTest2 connSource = checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema assertException "checkDatabase should throw exception for wrong schema" $ checkDatabase extrasOptions [] [] differentSchema - assertException ("checkDatabaseAllowUnknownObjects \ - \should throw exception for wrong scheme") $ + assertException "checkDatabaseAllowUnknownObjects \ + \should throw exception for wrong scheme" $ checkDatabase extrasOptionsWithUnknownObjects [] [] differentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $ checkDatabase extrasOptions [] [] currentSchema - assertNoException ("checkDatabaseAllowUnknownObjects \ - \accepts extra entry in 'table_versions'") $ + assertNoException "checkDatabaseAllowUnknownObjects \ + \accepts extra entry in 'table_versions'" $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" @@ -1360,8 +1362,8 @@ migrationTest2 connSource = \VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $ checkDatabase extrasOptions [] [] currentSchema - assertNoException ("checkDatabaseAllowUnknownObjects \ - \accepts unknown tables with version") $ + assertNoException "checkDatabaseAllowUnknownObjects \ + \accepts unknown tables with version" $ checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema freshTestDB step @@ -1403,8 +1405,8 @@ migrationTest3 connSource = migrateDBToSchema2 step testDBSchema2 step badGuyIds robberyIds - assertException ( "Trying to run the same migration twice should fail, \ - \when starting with a createTable migration" ) $ + assertException "Trying to run the same migration twice should fail, \ + \when starting with a createTable migration" $ migrateDBToSchema2Hacky step freshTestDB step @@ -1591,14 +1593,14 @@ migrationTest5 connSource = liftIO . assertEqual "All name_is_true are true" True $ all (== Just True) rows assertNoException :: String -> TestM () -> TestM () -assertNoException t c = eitherExc +assertNoException t = eitherExc (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t)) - (const $ return ()) c + (const $ return ()) assertException :: String -> TestM () -> TestM () -assertException t c = eitherExc +assertException t = eitherExc (const $ return ()) - (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) c + (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) assertDBException :: String -> TestM () -> TestM () assertDBException t c =