{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) where

import Data.Bitraversable
import Data.Text qualified as Text
import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import System.FilePath ((</>))
import U.Codebase.HashTags (CausalHash (CausalHash))
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase (CodebasePath)
import Unison.Hash qualified as Hash
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import UnliftIO (catchIO)

-- | The 5 to 6 migration adds the reflog as a table in the DB
migrateSchema5To6 :: CodebasePath -> Sqlite.Transaction ()
migrateSchema5To6 :: String -> Transaction ()
migrateSchema5To6 String
codebasePath = do
  SchemaVersion -> Transaction ()
Q.expectSchemaVersion SchemaVersion
5
  Transaction ()
Q.addReflogTable
  String -> Transaction ()
migrateCurrentReflog String
codebasePath
  SchemaVersion -> Transaction ()
Q.setSchemaVersion SchemaVersion
6

migrateCurrentReflog :: CodebasePath -> Sqlite.Transaction ()
migrateCurrentReflog :: String -> Transaction ()
migrateCurrentReflog String
codebasePath = do
  UTCTime
now <- IO UTCTime -> Transaction UTCTime
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO UTCTime -> Transaction UTCTime)
-> IO UTCTime -> Transaction UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
  [Entry CausalHash Text]
oldEntries <- IO [Entry CausalHash Text] -> Transaction [Entry CausalHash Text]
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO [Entry CausalHash Text] -> Transaction [Entry CausalHash Text])
-> IO [Entry CausalHash Text]
-> Transaction [Entry CausalHash Text]
forall a b. (a -> b) -> a -> b
$ String -> UTCTime -> IO [Entry CausalHash Text]
oldReflogEntries String
reflogPath UTCTime
now
  [Entry CausalHash Text]
-> (Entry CausalHash Text -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Entry CausalHash Text]
oldEntries \Entry CausalHash Text
oldEntry -> do
    -- There's no guarantee these causals actually exist in the DB,
    -- so we check first to avoid triggering a bad foreign key constraint.
    Bool
haveFrom <- Maybe (CausalHashId, BranchHashId) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CausalHashId, BranchHashId) -> Bool)
-> Transaction (Maybe (CausalHashId, BranchHashId))
-> Transaction Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId))
Q.loadCausalByCausalHash (Entry CausalHash Text -> CausalHash
forall causal text. Entry causal text -> causal
Reflog.fromRootCausalHash Entry CausalHash Text
oldEntry)
    Bool
haveTo <- Maybe (CausalHashId, BranchHashId) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CausalHashId, BranchHashId) -> Bool)
-> Transaction (Maybe (CausalHashId, BranchHashId))
-> Transaction Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId))
Q.loadCausalByCausalHash (Entry CausalHash Text -> CausalHash
forall causal text. Entry causal text -> causal
Reflog.toRootCausalHash Entry CausalHash Text
oldEntry)
    Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
haveFrom Bool -> Bool -> Bool
&& Bool
haveTo) (Transaction () -> Transaction ())
-> Transaction () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Entry CausalHash Text -> Transaction ()
appendReflog Entry CausalHash Text
oldEntry
  IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (String -> IO ()) -> String -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"I migrated old reflog entries from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reflogPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" into the codebase; you may delete that file now if you like."
  where
    reflogPath :: FilePath
    reflogPath :: String
reflogPath = String
codebasePath String -> String -> String
</> String
"reflog"

    appendReflog :: Reflog.Entry CausalHash Text -> Sqlite.Transaction ()
    appendReflog :: Entry CausalHash Text -> Transaction ()
appendReflog Entry CausalHash Text
entry = do
      Entry CausalHashId Text
dbEntry <- ((CausalHash -> Transaction CausalHashId)
-> (Text -> Transaction Text)
-> Entry CausalHash Text
-> Transaction (Entry CausalHashId Text)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Entry a b -> f (Entry c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse CausalHash -> Transaction CausalHashId
Q.saveCausalHash Text -> Transaction Text
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Entry CausalHash Text
entry
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute
        [Sqlite.sql|
          INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason)
          VALUES (@dbEntry, @, @, @)
        |]

oldReflogEntries :: CodebasePath -> UTCTime -> IO [Reflog.Entry CausalHash Text]
oldReflogEntries :: String -> UTCTime -> IO [Entry CausalHash Text]
oldReflogEntries String
reflogPath UTCTime
now =
  ( do
      Text
contents <- String -> IO Text
readUtf8 String
reflogPath
      let lines :: [Text]
lines = Text -> [Text]
Text.lines Text
contents
      let entries :: [Entry CausalHash Text]
entries = ((Integer, Text) -> Maybe (Entry CausalHash Text))
-> [(Integer, Text)] -> [Entry CausalHash Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (Integer, Text) -> Maybe (Entry CausalHash Text)
parseEntry ([Integer] -> [Text] -> [(Integer, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] ([Text] -> [(Integer, Text)]) -> [Text] -> [(Integer, Text)]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
lines)
      [Entry CausalHash Text] -> IO [Entry CausalHash Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Entry CausalHash Text]
entries
  )
    IO [Entry CausalHash Text]
-> (IOException -> IO [Entry CausalHash Text])
-> IO [Entry CausalHash Text]
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` IO [Entry CausalHash Text]
-> IOException -> IO [Entry CausalHash Text]
forall a b. a -> b -> a
const ([Entry CausalHash Text] -> IO [Entry CausalHash Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  where
    parseEntry :: (Integer, Text) -> Maybe (Reflog.Entry CausalHash Text)
    parseEntry :: (Integer, Text) -> Maybe (Entry CausalHash Text)
parseEntry (Integer
n, Text
txt) =
      -- We offset existing entries by a number of seconds corresponding to their position in
      -- the current file; we can't reclaim timestamps for old reflog entries, but this at
      -- least puts them in the correct order chronologically.
      let offsetTime :: UTCTime
offsetTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger @NominalDiffTime Integer
n) UTCTime
now
       in case Text -> [Text]
Text.words Text
txt of
            (Text -> Maybe Hash
Hash.fromBase32HexText -> Just Hash
old) : (Text -> Maybe Hash
Hash.fromBase32HexText -> Just Hash
new) : ([Text] -> Text
Text.unwords -> Text
reason) ->
              Entry CausalHash Text -> Maybe (Entry CausalHash Text)
forall a. a -> Maybe a
Just (Entry CausalHash Text -> Maybe (Entry CausalHash Text))
-> Entry CausalHash Text -> Maybe (Entry CausalHash Text)
forall a b. (a -> b) -> a -> b
$
                Reflog.Entry
                  { $sel:time:Entry :: UTCTime
time = UTCTime
offsetTime,
                    $sel:fromRootCausalHash:Entry :: CausalHash
fromRootCausalHash = Hash -> CausalHash
CausalHash Hash
old,
                    $sel:toRootCausalHash:Entry :: CausalHash
toRootCausalHash = Hash -> CausalHash
CausalHash Hash
new,
                    Text
reason :: Text
$sel:reason:Entry :: Text
reason
                  }
            [Text]
_ -> Maybe (Entry CausalHash Text)
forall a. Maybe a
Nothing