Codd.hs

{-# LANGUAGE TemplateHaskell #-}

module Keiro.Migrations.History.Codd
  ( frameworkCoddHistoryMappings,
    frameworkCoddSourceConfig,
    keiroCoddHistoryMappings,
    keiroCoddManifestText,
    keiroCoddSourcePayloads,
    keiroLegacyMigrationNames,
  )
where

import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Database.PostgreSQL.Migrate
  ( Confirmation,
    ConnectionProvider,
    EvidenceRequirement (Evidence),
    HistoryMapping,
    PayloadRelation (SamePayload),
    historyMapping,
    migrationId,
  )
import Database.PostgreSQL.Migrate.History.Codd
  ( CoddDefinitionError,
    CoddSourceConfig,
    coddEvidenceKey,
    coddSourceConfig,
    parseCoddManifest,
  )
import Keiro.Migrations.Internal.Definition (embeddedMigrationEntries)
import Keiro.Migrations.Internal.EmbedFile (embedTextFile)
import Kiroku.Store.Migrations.History.Codd qualified as Kiroku

keiroLegacyMigrationNames :: NonEmpty FilePath
keiroLegacyMigrationNames =
  "2026-05-17-13-58-15-keiro-bootstrap.sql"
    :| [ "2026-05-19-12-55-02-keiro-outbox.sql",
         "2026-05-19-13-05-23-keiro-inbox.sql",
         "2026-06-03-05-14-28-keiro-timer-recovery.sql",
         "2026-06-03-16-10-05-keiro-workflow-steps.sql",
         "2026-06-03-18-19-41-keiro-awakeables.sql",
         "2026-06-03-19-49-23-keiro-workflow-children.sql",
         "2026-06-04-02-12-28-keiro-workflow-generation.sql",
         "2026-06-04-03-53-34-keiro-subscription-shards.sql",
         "2026-06-15-13-22-31-keiro-messaging-crash-recovery.sql",
         "2026-06-15-15-07-25-keiro-workflows-instances.sql",
         "2026-06-15-17-53-48-keiro-workflow-gc-index.sql",
         "2026-06-15-18-01-33-keiro-workflows-wake-after.sql",
         "2026-06-15-21-49-37-keiro-projection-dedup.sql",
         "2026-07-02-00-15-48-keiro-outbox-claim-order-index.sql",
         "2026-07-02-00-58-54-keiro-inbox-drop-received-idx.sql"
       ]

keiroCoddHistoryMappings :: NonEmpty HistoryMapping
keiroCoddHistoryMappings =
  zipWithNonEmpty mapping keiroLegacyMigrationNames nativeMigrationNames
  where
    mapping sourceFilename targetName =
      historyMapping
        (definitionInvariant (migrationId "keiro" targetName))
        (Evidence sourceKey)
        (SamePayload sourceKey)
      where
        sourceKey = definitionInvariant (first show (coddEvidenceKey sourceFilename))

frameworkCoddHistoryMappings :: NonEmpty HistoryMapping
frameworkCoddHistoryMappings =
  Kiroku.kirokuCoddHistoryMappings <> keiroCoddHistoryMappings

frameworkCoddSourceConfig ::
  ConnectionProvider ->
  Bool ->
  Text ->
  Confirmation ->
  Either CoddDefinitionError CoddSourceConfig
frameworkCoddSourceConfig sourceProvider strictSource reason confirmation =
  coddSourceConfig
    sourceProvider
    (Kiroku.kirokuLegacyMigrationNames <> keiroLegacyMigrationNames)
    strictSource
    (Kiroku.kirokuCoddSourcePayloads <> keiroCoddSourcePayloads)
    (Just combinedManifest)
    reason
    confirmation
  where
    combinedManifest =
      definitionInvariant
        (parseCoddManifest (Kiroku.kirokuCoddManifestText <> keiroCoddManifestText))

nativeMigrationNames :: NonEmpty Text
nativeMigrationNames =
  "0001-keiro-bootstrap"
    :| [ "0002-keiro-outbox",
         "0003-keiro-inbox",
         "0004-keiro-timer-recovery",
         "0005-keiro-workflow-steps",
         "0006-keiro-awakeables",
         "0007-keiro-workflow-children",
         "0008-keiro-workflow-generation",
         "0009-keiro-subscription-shards",
         "0010-keiro-messaging-crash-recovery",
         "0011-keiro-workflows-instances",
         "0012-keiro-workflow-gc-index",
         "0013-keiro-workflows-wake-after",
         "0014-keiro-projection-dedup",
         "0015-keiro-outbox-claim-order-index",
         "0016-keiro-inbox-drop-received-idx"
       ]

keiroCoddSourcePayloads :: Map.Map FilePath ByteString
keiroCoddSourcePayloads =
  Map.fromList
    (zip (toList keiroLegacyMigrationNames) (snd <$> toList embeddedMigrationEntries))

keiroCoddManifestText :: Text
keiroCoddManifestText = $(embedTextFile "migrations.lock")

zipWithNonEmpty :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
zipWithNonEmpty combine (firstA :| restA) (firstB :| restB) =
  combine firstA firstB :| zipWith combine restA restB

definitionInvariant :: (Show error) => Either error value -> value
definitionInvariant = either (error . ("invalid checked-in Keiro migration definition: " <>) . show) id