module Poseidon.CLI.Timetravel where

import           Poseidon.Chronicle     (PackageIteration (..),
                                         PoseidonPackageChronicle (..),
                                         chroniclePackages, readChronicle)
import           Poseidon.EntityTypes   (renderNameWithVersion)
import           Poseidon.Package       (PackageReadOptions (..),
                                         defaultPackageReadOptions,
                                         readPoseidonPackageCollection)
import           Poseidon.Utils         (LogA, PoseidonException (..),
                                         PoseidonIO, envLogAction, logDebug,
                                         logInfo, logWithEnv)

import           Control.Exception      (finally)
import           Control.Monad          (forM_)
import           Control.Monad.Catch    (throwM)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Set               as S
import           GitHash                (getGitInfo, giBranch, giHash)
import           System.Directory       (copyFile, createDirectoryIfMissing,
                                         listDirectory)
import           System.FilePath        ((</>))
import           System.Process         (callCommand)

data TimetravelOptions = TimetravelOptions
    { TimetravelOptions -> [String]
_timetravelBaseDirs      :: [FilePath]
    , TimetravelOptions -> String
_timetravelSourceDir     :: FilePath
    , TimetravelOptions -> String
_timetravelChronicleFile :: FilePath
    }

pacReadOpts :: PackageReadOptions
pacReadOpts :: PackageReadOptions
pacReadOpts = PackageReadOptions
defaultPackageReadOptions {
      _readOptIgnoreChecksums :: Bool
_readOptIgnoreChecksums      = Bool
True
    , _readOptIgnoreGeno :: Bool
_readOptIgnoreGeno           = Bool
True
    , _readOptGenoCheck :: Bool
_readOptGenoCheck            = Bool
False
    , _readOptIgnorePosVersion :: Bool
_readOptIgnorePosVersion     = Bool
True
    }

runTimetravel :: TimetravelOptions -> PoseidonIO ()
runTimetravel :: TimetravelOptions -> PoseidonIO ()
runTimetravel (TimetravelOptions [String]
baseDirs String
srcDir String
chroniclePath) = do
    [PoseidonPackage]
allPackages <- PackageReadOptions -> [String] -> PoseidonIO [PoseidonPackage]
readPoseidonPackageCollection PackageReadOptions
pacReadOpts [String]
baseDirs
    Set PackageIteration
pacsInBaseDirs <- String -> [PoseidonPackage] -> PoseidonIO (Set PackageIteration)
chroniclePackages String
chroniclePath [PoseidonPackage]
allPackages
    PoseidonPackageChronicle
chronicle <- String -> PoseidonIO PoseidonPackageChronicle
readChronicle String
chroniclePath
    let pacsInChronicle :: Set PackageIteration
pacsInChronicle = PoseidonPackageChronicle -> Set PackageIteration
snapYamlPackages PoseidonPackageChronicle
chronicle
    case Set PackageIteration -> [PackageIteration]
forall a. Set a -> [a]
S.toList (Set PackageIteration -> [PackageIteration])
-> Set PackageIteration -> [PackageIteration]
forall a b. (a -> b) -> a -> b
$ Set PackageIteration
-> Set PackageIteration -> Set PackageIteration
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set PackageIteration
pacsInChronicle Set PackageIteration
pacsInBaseDirs of
        []             -> do String -> PoseidonIO ()
logInfo String
"All packages already there, nothing to add"
        [PackageIteration]
pacStatesToAdd -> do
            Either GitHashException GitInfo
eitherGit <- IO (Either GitHashException GitInfo)
-> ReaderT Env IO (Either GitHashException GitInfo)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GitHashException GitInfo)
 -> ReaderT Env IO (Either GitHashException GitInfo))
-> IO (Either GitHashException GitInfo)
-> ReaderT Env IO (Either GitHashException GitInfo)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either GitHashException GitInfo)
getGitInfo String
srcDir
            case Either GitHashException GitInfo
eitherGit of
                Left GitHashException
e -> do PoseidonException -> PoseidonIO ()
forall e a. Exception e => e -> ReaderT Env IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PoseidonException -> PoseidonIO ())
-> PoseidonException -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> PoseidonException
PoseidonGitException String
srcDir (GitHashException -> String
forall a. Show a => a -> String
show GitHashException
e)
                Right GitInfo
gitRef -> do
                    let currentBranch :: String
currentBranch = GitInfo -> String
giBranch GitInfo
gitRef
                    String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting at branch " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
currentBranch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir
                    LogA
logAction <- PoseidonIO LogA
envLogAction
                    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally
                        (LogA -> [PackageIteration] -> IO ()
recoverPacsIO LogA
logAction [PackageIteration]
pacStatesToAdd)
                        (LogA -> String -> IO ()
gitCheckoutIO LogA
logAction String
currentBranch)
                    String -> PoseidonIO ()
logInfo String
"Done"
    where
        -- these IO actions are only necessary to wrap the computation
        -- in Control.Exception.finally, which runs in IO, not PoseidonIO
        recoverPacsIO :: LogA -> [PackageIteration] -> IO ()
        recoverPacsIO :: LogA -> [PackageIteration] -> IO ()
recoverPacsIO LogA
logA [PackageIteration]
pacIters = LogA -> PoseidonIO () -> IO ()
forall (m :: * -> *). MonadIO m => LogA -> PoseidonIO () -> m ()
logWithEnv LogA
logA (PoseidonIO () -> IO ()) -> PoseidonIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (PackageIteration -> PoseidonIO ())
-> [PackageIteration] -> PoseidonIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageIteration -> PoseidonIO ()
recoverPacIter [PackageIteration]
pacIters
        gitCheckoutIO :: LogA -> String -> IO ()
        gitCheckoutIO :: LogA -> String -> IO ()
gitCheckoutIO LogA
logA String
s = LogA -> PoseidonIO () -> IO ()
forall (m :: * -> *). MonadIO m => LogA -> PoseidonIO () -> m ()
logWithEnv LogA
logA (PoseidonIO () -> IO ()) -> PoseidonIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> PoseidonIO ()
gitCheckout String
srcDir String
s
        recoverPacIter :: PackageIteration -> PoseidonIO ()
        recoverPacIter :: PackageIteration -> PoseidonIO ()
recoverPacIter pacIter :: PackageIteration
pacIter@(PackageIteration String
_ Version
_ String
commit String
path) = do
            let pacIterName :: String
pacIterName = PackageIteration -> String
forall a. HasNameAndVersion a => a -> String
renderNameWithVersion PackageIteration
pacIter
            String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Recovering package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pacIterName
            -- this exists to reduce the number of checkouts
            Either GitHashException GitInfo
eitherGit <- IO (Either GitHashException GitInfo)
-> ReaderT Env IO (Either GitHashException GitInfo)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GitHashException GitInfo)
 -> ReaderT Env IO (Either GitHashException GitInfo))
-> IO (Either GitHashException GitInfo)
-> ReaderT Env IO (Either GitHashException GitInfo)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either GitHashException GitInfo)
getGitInfo String
srcDir
            case Either GitHashException GitInfo
eitherGit of
                Left GitHashException
e -> do PoseidonException -> PoseidonIO ()
forall e a. Exception e => e -> ReaderT Env IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PoseidonException -> PoseidonIO ())
-> PoseidonException -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> PoseidonException
PoseidonGitException String
srcDir (GitHashException -> String
forall a. Show a => a -> String
show GitHashException
e)
                Right GitInfo
gitRef -> do
                    let currentCommit :: String
currentCommit = GitInfo -> String
giHash GitInfo
gitRef
                    if String
currentCommit String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
commit
                    then do
                        String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Already at the right commit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
commit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir
                        String -> String -> PoseidonIO ()
copyDirectory (String
srcDir String -> String -> String
</> String
path) ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
baseDirs String -> String -> String
</> String
pacIterName)
                    else do
                        String -> String -> PoseidonIO ()
gitCheckout String
srcDir String
commit
                        String -> String -> PoseidonIO ()
copyDirectory (String
srcDir String -> String -> String
</> String
path) ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
baseDirs String -> String -> String
</> String
pacIterName)

gitCheckout :: FilePath -> String -> PoseidonIO ()
gitCheckout :: String -> String -> PoseidonIO ()
gitCheckout String
srcDir String
commit = do
    String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Checking out " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
commit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir
    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
callCommand (String
"git -C " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" checkout " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
commit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --quiet")
    -- Instead of this nasty system call and changing the world with the checkout
    -- we could do something like this:
    -- https://hackage.haskell.org/package/git-0.3.0/docs/Data-Git-Monad.html#v:withCommit
    -- Unfortunately this library is not maintained any more.
    -- And I'm also not entirely sure how git lfs integrates with that...

copyDirectory :: FilePath -> FilePath -> PoseidonIO ()
copyDirectory :: String -> String -> PoseidonIO ()
copyDirectory String
srcDir String
destDir = do
  String -> PoseidonIO ()
logInfo (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Copying dir " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destDir
  IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
destDir
  [String]
files <- IO [String] -> ReaderT Env IO [String]
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> ReaderT Env IO [String])
-> IO [String] -> ReaderT Env IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory String
srcDir
  [String] -> (String -> PoseidonIO ()) -> PoseidonIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files ((String -> PoseidonIO ()) -> PoseidonIO ())
-> (String -> PoseidonIO ()) -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ \String
file -> do
    let srcFile :: String
srcFile = String
srcDir String -> String -> String
</> String
file
        destFile :: String
destFile = String
destDir String -> String -> String
</> String
file
    String -> PoseidonIO ()
logDebug (String -> PoseidonIO ()) -> String -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String
"Copying: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destFile
    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ()) -> IO () -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
srcFile String
destFile