content: -- | More structured changelog, for easy release automation.
  module Main where
  import Control.Monad (when)
  import Data.Time
  import System.Environment
  import System.Exit
  import System.FilePath
  import System.Process
  import Text.Read
  
  changeLog :: ChangeLog
  changeLog =
    [ Version "0.5.2.0" "2022-09-18"
      "Quality of life improvements"
      [ "Add support for GHC versions 8.10-9.2"
      , "Add typed UUIDs"
      , "Allow literal rows in update queries. (#139)"
      , "Add support for UNION/UNION ALL. (#140)"
      , "Suppor raw PostgreSQL connetion strings. (#136)"
      , "Move to Docker and GitHub actions for testing."
      , "Drop support for GHC versions <8.8."
      , "Various bugfixes."
      ]
    , Version "0.5.1.0" "2020-01-20"
      "Raw SQL support"
      [ "Support for raw SQL fragments. (#134)"
      , "Expose tableName."
      , "Document performance drawbacks of withoutForeignKeyEnforcement."
      , "Fix several bugs validating auto-incrementing PKs. (#133)"
      ]
    , Version "0.5.0.0" "2019-09-21"
      "Multi-column indexes and better type errors."
      [ "index and indexUsing now accept a Group instead of a Selector (#121)"
      , "Custom type errors for scope mismatches."
      , "Provide Generic instances for ID and RowID."
      , "Provide To/FromJSON instances for ID and RowID (selda-json)."
      , "Add back MonadTrans instance for SeldaT."
      ]
    , Version "0.4.0.0" "2019-06-02"
      "Major update."
      [ "Type-safe support for backend-specific functionality. Top level query definitions now require explicit type signature. (#80)"
      , "Native UUID support. (#47)"
      , "Support JSON columns on all backends through aeson."
      , "Support JSON lookups (i.e. SELECT json_column.some_property FROM ...) on PostgreSQL."
      , "Multi-column primary key and uniqueness constraint support. (#25, #99)"
      , "Switch to PostgreSQL binary protocol. (#18)"
      , "Prevent dangerous user-defined SQL result instances."
      , "Expose backend internals through Database.Selda.Backend.Internal. (#109)"
      , "Expose SQLite connection handle. (#101)"
      , "Make MonadSelda more amenable to connection pooling. (#108)"
      , "Add weakly auto-incrementing primary keys. (#94)"
      , "Move compile* functions to Database.Selda.Debug."
      , "Remove half the tuple convenience functions."
      , "Remove in-process cache. (#117)"
      , "Officially support GHC 8.6, 8.8 (SQLite only until postgres dependencies catch up with 8.8)."
      , "Drop support for GHC 7.10. (#118)"
      , "Manual (i.e. non record label) selectors are no longer exported by default; import Database.Selda.MakeSelectors is you need them. (#118)"
      , "Update toolchain to use v2-style cabal commands."
      , "Fix date/time types for PostgreSQL. (#104)"
      , "Fix bug when migrating tables with indexes. (#107)"
      , "Misc. smaller bug fixes."
      ]
    , Version "0.3.4.0" "2018-09-29"
      "Nullable convenience functions."
      [ "Added convenience functions for working with nullable columns."
      ]
    , Version "0.3.3.1" "2018-09-04"
      "Fixing DISTINCT."
      [ "DISTINCT should now always return distinct results."
      , "DISTINCT can no longer produce ill-scoped queries."
      ]
    , Version "0.3.3.0" "2018-09-01"
      "Ad hoc selectors on GHC 8.0 and up."
      [ "Ad hoc selectors using OverloadedLabels."
      , "Shorter build times."
      , "Minor API updates and simplifications."
      ]
    , Version "0.3.2.0" "2018-08-07"
      "Minor API improvements and bug fixes."
      [ "Some aggregates are now nullable."
      , "sum_ on an empty table doesn't crash anymore."
      , "Aggregating over an empty selectValues doesn't crash anymore."
      ]
    , Version "0.3.1.0" "2018-08-06"
      "Minor API fix when defining table attributes."
      [ "Minor API fix when defining table attributes." ]
    , Version "0.3.0.0" "2018-08-05"
      "Migrations, indexes, validation, and major API overhaul."
      [ "Support for Stack and GHC 8.4."
      , "Precedence fix for selector index (!) operator."
      , "Accept INT and SMALLINT columns in user-created PostgreSQL tables."
      , "Add combinator for turning off foreign key checking."
      , "Rename unsafeRowId/unsafeId to toRowId/rowId."
      , "Add typed row identifiers."
      , "More generic type for sum_."
      , "Table validation against current database."
      , "Basic migration support."
      , "Basic index support."
      , "Remove ad hoc tables; only generic tables from now on."
      ]
    , Version "0.2.0.0" "2018-04-02"
      "Fixes for inner queries and generic tables."
      [ "Support custom column names for generic tables."
      , "Scope safety fix for inner queries."
      , "Better type errors on GHC 8+ for inner queries."
      ]
    , Version "0.1.12.1" "2018-02-27"
      "Backend API fixes for PostgreSQL."
      [ "New PPConfig hook for more flexibility when compiling types."
      ]
    , Version "0.1.12.0" "2018-01-11"
      "Recursive foreign keys, arbitrary enums, and bug fixes."
      [ "Allow recursive and optional foreign keys."
      , "Allow arbitrary enums in tables, represented as text."
      , "Fix RowID issues for PostgreSQL."
      , "Fix auto-incrementing primary keys for generic tables."
      ]
    , Version "0.1.11.2" "2017-12-14"
      "PostgreSQL bugfix release."
      [ "Fix treatment of booleans in PostgreSQL backend."
      ]
    , Version "0.1.11.1" "2017-10-10"
      "Fix a rare but serious cache bug."
      [ "Fix rare infinite loop bug in in-process cache."
      ]
    , Version "0.1.11.0" "2017-09-08"
      "Conditionals, SELECT DISTINCT, and bug fixes."
      [ "Fix name generation in the presence of isIn over queries."
      , "SELECT DISTINCT support."
      , "Conditional expressions and matchNull."
      ]
    , Version "0.1.10.1" "2017-08-11"
      "Code generation bug fix."
      [ "Fix name generation in the presence of multiple aggregates."
      ]
    , Version "0.1.10.0" "2017-08-01"
      "Async exception safety, bug and API fixes. Also, GHC 8.2 support."
      [ "Async exception safety."
      , "Allow MonadSelda instances not built on SeldaT."
      , "Chunk very large insertions on backends that request it (i.e. SQLite)."
      , "GHC 8.2 support."
      ]
    , Version "0.1.9.0" "2017-06-16"
      "Conditional inserts and documentation fixes."
      [ "Properly document semantics of order."
      , "Export conditional inserts."
      , "Fix Haste build for backends."
      ]
    , Version "0.1.8.0" "2017-06-10"
      "Blobs prepared statements and better backend configuration."
      [ "Move SQL pretty-printing config into a single type."
      , "Support for binary blobs."
      , "Support for prepared statements."
      , "Support for connection reuse across Selda computations."
      , "Cleaner and more robust backend API."
      , "Stricter type constraints on comparisons."
      , "Allow limit on inner queries."
      , "Allow inspecting row identifiers."
      ]
    , Version "0.1.7.0" "2017-05-17"
      "More upserts and abstracting over auto-incrementing primary keys."
      [ "Add specialized insertUnless upsert variant."
      , "Fix potential race condition in upserts."
      , "Use abstract row identifier type for auto-incrementing primary keys."
      , "Less strict version bounds on dependencies."
      ]
  
    , Version "0.1.6.0" "2017-05-07"
      "More expressivity for inserts and queries."
      [ "Conditional insert (\"upsert\") support."
      , "Support `SELECT x IN (SELECT ...)` and `SELECT x IN (a, b, ...)` queries."
      , "Explicit inner queries."
      , "Rename `inner` to `innerJoin`, more intuitive behavior for `suchThat`."
      , "Add `from` shorthand for `\\s q -> fmap (!s) q`."
      , "Unique and foreign key constraints for generics."
      ]
  
    , Version "0.1.5.0" "2017-05-05"
      "Inner joins and bug fixing for round_ and cast."
      [ "Inner join support."
      , "More sensible names in backend API."
      , "Fix rounding and casts."
      ]
  
    , Version "0.1.4.1" "2017-05-04"
      "Cache consistency bugfix release."
      [ "Fix cache consistency bug in the presence of multiple databases."
      ]
  
    , Version "0.1.4.0" "2017-05-04"
      "Foreign keys, unique constraints, and less postgres NOTICE spam."
      [ "Add uniqueness constraints and foreign keys."
      ]
  
    , Version "0.1.3.3" "2017-05-04"
      "Bug fix for caching with transactions; documentation fixes."
      [ "Fix cache invalidation race when using transactions."
      ]
  
    , Version "0.1.3.2" "2017-05-01"
      "Discipline and document error handling."
      [ "Only throw well-documented, Selda-specific exceptions."
      ]
  
    , Version "0.1.3.1" "2017-05-01"
      "README fixes to appease Hackage."
      [ "More Hackage-friendly README."
      ]
  
    , Version "0.1.3.0" "2017-04-30"
      "Selectors, bug fixes and minor API improvements."
      [ "Add selectors for non-generic tables."
      , "Allow default insertions on all columns."
      , "More sensible API for LIMIT."
      , "Fix broken SQL being generated for pathological corner cases."
      , "Documentation fixes."
      ]
  
    , Version "0.1.2.0" "2017-04-20"
      "Replace ¤ with :*: for table definitions."
      [ "Replace `¤` with `:*:` in table definitions."
      ]
  
    , Version "0.1.1.1" "2017-04-20"
      "Minor documentation fixes."
      [ "Minor documentation fixes."
      ]
  
    , Version "0.1.1.0" "2017-04-20"
      "Generics, SELECT FROM VALUES, plus minor fixes."
      [ "Generic tables, queries and mutation."
      , "Select from inline tables."
      , "Tutorial updates."
      , "Minor bugfixes."
      ]
  
    , Version "0.1.0.0" "2017-04-14"
      "Initial release."
      [ "Initial release."
      ]
    ]
  
  data Version = Version
    { vVersion :: String -- ^ X.Y.Z.W
    , vDate    :: String -- ^ YYYY-MM-DD
    , vSummary :: String
    , vChanges :: [String]
    }
  
  type ChangeLog = [Version]
  
  -- | Get the current version.
  currentVersion :: [Version] -> String
  currentVersion = vVersion . head
  
  -- | Get the release date of the current version.
  currentDate :: [Version] -> String
  currentDate = vDate . head
  
  -- | Get the release summary of the current version.
  currentSummary :: [Version] -> String
  currentSummary = vDate . head
  
  -- | Get the git tag message for the current version, as a list of @-m <msg>@
  --   flags.
  gitTagFlags :: [Version] -> [String]
  gitTagFlags (v:_) =
    ["-m", vSummary v] ++ concat [["-m", c] | c <- vChanges v]
  
  -- | Convert a changelog to a markdown file suitable for uploading to Hackage.
  toMD :: String -> ChangeLog -> String
  toMD pkgname vs = init $ init $ unlines (heading : "\n" : map verToMD vs)
    where
      heading = "# Revision history for " ++ pkgname
      verToMD v = unlines
        [ "## " ++ vVersion v ++ " -- " ++ vDate v
        , ""
        , unlines ["* " ++ ch | ch <- vChanges v]
        ]
  
  -- | @git tag@ the current version. Fails if the tag already exists.
  tagCurrentVersion :: ChangeLog -> IO ()
  tagCurrentVersion ch = callProcess "git" flags
    where
      flags = concat
        [ ["tag", "-a", currentVersion ch]
        , gitTagFlags ch
        ]
  
  -- | Write the changelog to @ChangeLog.md@ in the given directory.
  writeChangelogMD :: String -> FilePath -> ChangeLog -> IO ()
  writeChangelogMD pkgname dir = writeFile (dir </> "ChangeLog.md") . toMD pkgname
  
  -- | Get the latest entry in the changelog.
  latestEntry :: ChangeLog -> Version
  latestEntry = head
  
  -- | Get the release date from the latest entry in the changelog.
  latestReleaseDate :: ChangeLog -> String
  latestReleaseDate = vDate . latestEntry
  
  -- | Get the version number from the latest entry in the changelog.
  latestVersion :: ChangeLog -> String
  latestVersion = vVersion . latestEntry
  
  -- | Does the given string contain a valid release date?
  validReleaseDate :: String -> Bool
  validReleaseDate date = and
      [ validate (\y -> y >= 2017 && y <  2100) year
      , validate (\m -> m >= 1    && m <= 12) month
      , validate (\d -> d >= 1    && d <= 31) day
      ]
    where
      year  = take 4 date
      month = take 2 $ drop 5 date
      day   = drop 8 date
  
  -- | Is the given string a valid version number?
  validVersion :: String -> Bool
  validVersion version =
      all (validate (\x -> x >= 0 && x <= 99)) parts && length parts == 4
    where
      parts = words $ map undot version
      undot '.' = ' '
      undot c   = c
  
  -- | Returns @True@ if the given string is readable at the given type, and the
  --   resulting value fulfills the given predicate.
  validate :: Read a => (a -> Bool) -> String -> Bool
  validate p s =
    case readMaybe s of
      Just x -> p x
      _      -> False
  
  -- | Ensure that the changelog is valid for release.
  validateChangeLog :: ChangeLog -> IO ()
  validateChangeLog changelog = do
      let date = latestReleaseDate changeLog
          version = latestVersion changeLog
  
      when (not $ validReleaseDate date) $ do
        putStrLn ("Invalid release date: " ++ date)
        exitFailure
  
      when (not $ validVersion version) $ do
        putStrLn ("Invalid version: " ++ version)
        exitFailure
  
      today <- utctDay <$> getCurrentTime
      when (show today /= date) $ do
        putStrLn "Release date does not match today's date."
        exitFailure
  
      when (null $ vSummary $ latestEntry changeLog) $ do
        putStrLn "Changelog has no summary."
        exitFailure
  
      when (null $ vChanges $ latestEntry changeLog) $ do
        putStrLn "Changelog has no list of changes."
        exitFailure
  
      when (head version /= '0') $ do
        putStrLn "Major version is not 0; make upload will complain."
        exitFailure
  
  main = do
    args <- getArgs
    when (null args || any (not . (`elem` ["tag", "md", "validate"])) args) $ do
      putStrLn "usage: runghc ChangeLog.hs tag|md|validate"
      exitFailure
  
    when ("validate" `elem` args) $ do
      validateChangeLog changeLog
    when ("tag" `elem` args) $ do
      tagCurrentVersion changeLog
    when ("md" `elem` args) $ do
      writeChangelogMD "Selda" "selda" changeLog
  