keiro-migrations-0.4.0.1: test/Lint.hs

module Lint (
    LintConfig (..),
    lintViolations,
) where

import Data.ByteString (ByteString)
import Data.List (sortOn)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text.Encoding
import Data.Text.Encoding.Error (lenientDecode)

{- | Pure migration-body lint, ported from codd-extras (Codd.Extras.Guards) when the
codd toolchain moved behind the legacy-codd-tools flag. The codd-era CONCURRENTLY
check is deliberately dropped: pg-migrate runs transactional migrations inside a
single transaction, and PostgreSQL rejects CREATE INDEX CONCURRENTLY in a
transaction block, so the mistake fails the first fresh-database test run instead
of needing a lint. Genuinely non-transactional migrations must carry pg-migrate's
"-- pg-migrate: no-transaction" leading comment, which review gates.
-}
data LintConfig = LintConfig
    { requiredQualifier :: Text
    , exemptFiles :: [FilePath]
    }
    deriving stock (Eq, Show)

-- | Lint migration bodies with intentionally simple SQL heuristics.
lintViolations :: LintConfig -> [(FilePath, ByteString)] -> [Text]
lintViolations config sources =
    concatMap lintOne (sortOn fst sources)
  where
    lintOne (file, bytes)
        | file `elem` exemptFiles config = []
        | otherwise =
            searchPathViolation file body
                <> concatMap (statementViolations file) statements
      where
        body = Text.Encoding.decodeUtf8With lenientDecode bytes
        statements = map Text.strip . Text.splitOn ";" $ stripCommentLines body

    requiredLower = Text.toCaseFold (requiredQualifier config)

    searchPathViolation file body =
        [ "migration body mentions search_path: " <> Text.pack file
        | "search_path" `Text.isInfixOf` Text.toCaseFold (stripCommentLines body)
        ]

    statementViolations file statement =
        case statementTarget statement of
            Nothing -> []
            Just target
                | requiredLower `Text.isPrefixOf` Text.toCaseFold (cleanTarget target) -> []
                | otherwise ->
                    [ "migration DDL target is not qualified with "
                        <> requiredQualifier config
                        <> " in "
                        <> Text.pack file
                        <> ": "
                        <> Text.take 120 (oneLine statement)
                    ]

statementTarget :: Text -> Maybe Text
statementTarget statement
    | Text.null trimmed = Nothing
    | lower `startsWithWords` ["create", "table"] =
        targetAfter ["create", "table"] wordsOriginal
    | lower `startsWithWords` ["alter", "table"] =
        targetAfter ["alter", "table"] wordsOriginal
    | lower `startsWithWords` ["drop", "index"] =
        targetAfter ["drop", "index"] wordsOriginal
    | lower `startsWithWords` ["create", "index"] =
        targetAfterToken "on" wordsOriginal
    | lower `startsWithWords` ["create", "unique", "index"] =
        targetAfterToken "on" wordsOriginal
    | lower `startsWithWords` ["create", "function"] =
        targetAfter ["create", "function"] wordsOriginal
    | lower `startsWithWords` ["create", "or", "replace", "function"] =
        targetAfter ["create", "or", "replace", "function"] wordsOriginal
    | lower `startsWithWords` ["create", "trigger"] =
        targetAfterToken "on" wordsOriginal
    | otherwise = Nothing
  where
    trimmed = Text.strip statement
    lower = Text.toCaseFold trimmed
    wordsOriginal = Text.words trimmed

startsWithWords :: Text -> [Text] -> Bool
startsWithWords statement wordsExpected =
    wordsExpected == take (length wordsExpected) (Text.words statement)

targetAfter :: [Text] -> [Text] -> Maybe Text
targetAfter prefix wordsOriginal =
    skipIfNotExists (drop (length prefix) wordsOriginal)

targetAfterToken :: Text -> [Text] -> Maybe Text
targetAfterToken token wordsOriginal =
    skipIfNotExists . drop 1 $ dropWhile ((/= token) . Text.toCaseFold) wordsOriginal

skipIfNotExists :: [Text] -> Maybe Text
skipIfNotExists (first : second : third : target : _)
    | map Text.toCaseFold [first, second, third] == ["if", "not", "exists"] = Just target
skipIfNotExists (first : second : target : _)
    | map Text.toCaseFold [first, second] == ["if", "exists"] = Just target
skipIfNotExists (target : _) = Just target
skipIfNotExists [] = Nothing

stripCommentLines :: Text -> Text
stripCommentLines =
    Text.unlines . filter (not . Text.isPrefixOf "--" . Text.strip) . Text.lines

cleanTarget :: Text -> Text
cleanTarget =
    Text.dropAround (`elem` ("\"(),;" :: String))

oneLine :: Text -> Text
oneLine =
    Text.unwords . Text.words