Validation.hs

{-# LANGUAGE OverloadedStrings, CPP #-}
module Database.Selda.Table.Validation where
import Control.Exception ( Exception, throw )
import Data.List (group, sort)
import Data.Text (Text, any, intercalate, unpack)
import Data.Typeable ( Typeable )
import Database.Selda.Table.Type
    ( ColAttr(Required, Optional),
      ColInfo(colFKs, colName, colAttrs),
      Table(Table),
      isPrimary,
      isUnique )
import Database.Selda.Types
    ( TableName, fromColName, fromTableName )

-- | An error occurred when validating a database table.
--   If this error is thrown, there is a bug in your database schema, and the
--   particular table that triggered the error is unusable.
--   Since validation is deterministic, this error will be thrown on every
--   consecutive operation over the offending table.
--
--   Therefore, it is not meaningful to handle this exception in any way,
--   just fix your bug instead.
newtype ValidationError = ValidationError String
  deriving (Show, Eq, Typeable)
instance Exception ValidationError

-- | Ensure that there are no duplicate column names or primary keys.
--   Returns a list of validation errors encountered.
validate :: TableName -> [ColInfo] -> [Text]
validate name cis = errs
  where
    colIdents = map (fromColName . colName) cis
    allIdents = fromTableName name : colIdents
    errs = concat
      [ dupes
      , pkDupes
      , optionalRequiredMutex
      , nulIdents
      , emptyIdents
      , emptyTableName
      , nonPkFks
      ]
    emptyTableName
      | fromTableName name == "\"\"" = ["table name is empty"]
      | otherwise                    = []
    emptyIdents
      | "\"\"" `elem` colIdents =
        ["table has columns with empty names"]
      | otherwise =
        []
    nulIdents =
      [ "table or column name contains \\NUL: " <> n
      | n <- allIdents
      , Data.Text.any (== '\NUL') n
      ]
    dupes =
      ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis]
    pkDupes =
      ["multiple primary keys" | moreThanOne pkAttrs]
    nonPkFks =
      [ "column is used as a foreign key, but is not primary or unique: "
          <> fromTableName ftn <> "." <> fromColName fcn
      | ci <- cis
      , (Table ftn fcs _ _, fcn, _) <- colFKs ci
      , fc <- fcs
      , colName fc == fcn
      , not $ Prelude.any isUnique (colAttrs fc)
      ]

    -- This should be impossible, but...
    optionalRequiredMutex =
      [ "BUG: column " <> fromColName (colName ci)
                       <> " is both optional and required"
      | ci <- cis
      , Optional `elem` colAttrs ci && Required `elem` colAttrs ci
      ]

    moreThanOne []  = False
    moreThanOne [_] = False
    moreThanOne _   = True
    pkAttrs =
      [ attr
      | attr <- concatMap colAttrs cis
      , isPrimary attr
      ]

-- | Return all columns of the given table if the table schema is valid,
--   otherwise throw a 'ValidationError'.
validateOrThrow :: TableName -> [ColInfo] -> [ColInfo]
validateOrThrow name cols =
  case validate name cols of
    []     -> cols
    errors -> throw $ ValidationError $ concat
      [ "validation of table `", unpack $ fromTableName name
      , "' failed:\n  "
      , unpack $ intercalate "\n  " errors
      ]

-- | Sort a list and remove all duplicates from it.
snub :: (Ord a, Eq a) => [a] -> [a]
snub = map head . soup

-- | Sort a list, then group all identical elements.
soup :: Ord a => [a] -> [[a]]
soup = group . sort