Source.hs

module Seihou.CLI.Update.Source
  ( stageCandidateSources,
    hashArtifactDirectory,
  )
where

import Control.Exception (SomeException, displayException, try)
import Control.Monad (foldM, forM)
import Data.ByteString qualified as BS
import Data.Foldable (traverse_)
import Data.Generics.Labels ()
import Data.List (sort)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Seihou.CLI.InstallShared
  ( OriginInfo (..),
    cloneRepo,
    copyDirectoryRecursive,
  )
import Seihou.CLI.Update.Types
import Seihou.Core.ArtifactRef (ArtifactRefError, resolveArtifactOrigin)
import Seihou.Core.Module (defaultSearchPaths, validateModule)
import Seihou.Core.Recipe (validateRecipe)
import Seihou.Core.Registry (Registry (..), RegistryEntry (..), validateRegistry)
import Seihou.Core.Types
import Seihou.Dhall.Eval (evalModuleFromFile, evalRecipeFromFile, evalRegistryFromFile)
import Seihou.Manifest.Hash (hashContent)
import Seihou.Prelude
import System.Directory qualified as Directory
import System.Exit (ExitCode (..))
import System.Process (readProcessWithExitCode)

-- | One artifact an update has to obtain before it can re-plan.
--
-- @sourceDirectory@ is where the currently-applied copy lives on this
-- machine, resolved from the manifest's recorded origin. It is only consulted
-- for artifacts with no remote to clone from, so a resolution failure is
-- carried rather than raised: an artifact that will be cloned does not need
-- to exist locally at all.
data ArtifactRequirement = ArtifactRequirement
  { kind :: !CandidateArtifactKind,
    name :: !Text,
    sourceDirectory :: !(Either ArtifactRefError FilePath),
    origin :: !(Maybe OriginInfo)
  }
  deriving stock (Generic)

-- | Clone every distinct remote once, validate its complete module/recipe
-- catalog, and materialize a name-keyed temporary search root. Local artifacts
-- remain a fallback and are called out explicitly.
stageCandidateSources ::
  FilePath ->
  FilePath ->
  FilePath ->
  [AppliedComposition] ->
  IO (Either UpdateError (CandidateCatalog, [UpdateWarning]))
stageCandidateSources sessionRoot projectRoot installedDirectory selected = do
  requirements <- requirementsFor projectRoot installedDirectory selected
  let remoteOrigins =
        Map.fromList
          [ (origin ^. #sourceUrl, origin)
          | requirement <- requirements,
            Just origin <- [requirement ^. #origin]
          ]
      clonesRoot = sessionRoot </> "clones"
      searchRoot = sessionRoot </> "search"
  Directory.createDirectoryIfMissing True clonesRoot
  Directory.createDirectoryIfMissing True searchRoot
  remoteResult <- stageRemoteOrigins clonesRoot searchRoot (Map.toAscList remoteOrigins)
  case remoteResult of
    Left err -> pure (Left err)
    Right (remoteArtifacts, clones) -> do
      localResult <- stageLocalRequirements searchRoot remoteArtifacts requirements
      pure $ do
        (allArtifacts, localWarnings) <- localResult
        verifyRemoteRequirements requirements allArtifacts
        Right
          ( CandidateCatalog
              { searchRoot,
                artifacts = allArtifacts,
                clonedOrigins = clones
              },
            localWarnings
          )

requirementsFor :: FilePath -> FilePath -> [AppliedComposition] -> IO [ArtifactRequirement]
requirementsFor projectRoot installedDirectory applications = concat <$> mapM applicationRequirements applications
  where
    applicationRequirements application = do
      targetRequirement <-
        requirement
          ( case application ^. #target of
              AppliedModuleTarget name -> (CandidateModule, name ^. #unModuleName)
              AppliedRecipeTarget name -> (CandidateRecipe, name ^. #unRecipeName)
          )
          (application ^. #targetOrigin)
      instanceRequirements <-
        forM (application ^. #instances) $ \state ->
          requirement (CandidateModule, state ^. #name . #unModuleName) (state ^. #origin)
      pure (targetRequirement : instanceRequirements)

    requirement (kind, name) origin = do
      searchPaths <- defaultSearchPaths
      sourceDirectory <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) origin
      pure ArtifactRequirement {kind, name, sourceDirectory, origin = remoteProvenance origin}

definitionFileFor :: CandidateArtifactKind -> FilePath
definitionFileFor CandidateModule = "module.dhall"
definitionFileFor CandidateRecipe = "recipe.dhall"

-- | Recover the remote-provenance view an update needs from the manifest's
-- portable origin.
--
-- Before schema version 6 this was read from the @.seihou-origin.json@ file
-- beside the absolute path the manifest recorded — that is, from whatever the
-- machine that ran the command happened to have installed. Taking it from the
-- manifest instead is both portable and more authoritative: it is the
-- project's own record of what it was generated from. The installed-at
-- version is deliberately not reconstructed here; nothing in staging reads it.
remoteProvenance :: ArtifactOrigin -> Maybe OriginInfo
remoteProvenance (RemoteOrigin url _ repo) = Just (OriginInfo url repo Nothing)
remoteProvenance (ProjectOrigin _) = Nothing
remoteProvenance (LocalOrigin _) = Nothing

stageRemoteOrigins ::
  FilePath ->
  FilePath ->
  [(Text, OriginInfo)] ->
  IO
    ( Either
        UpdateError
        (Map (CandidateArtifactKind, Text) CandidateArtifact, Map Text FilePath)
    )
stageRemoteOrigins clonesRoot searchRoot = go 0 Map.empty Map.empty
  where
    go _ artifacts clones [] = pure (Right (artifacts, clones))
    go index artifacts clones ((url, origin) : rest) = do
      let cloneDirectory = clonesRoot </> show index
      cloneResult <- cloneRepo url cloneDirectory
      case cloneResult of
        Left message -> pure (Left (CandidateCloneFailed url message))
        Right () -> do
          revision <- gitRevision cloneDirectory
          discovered <- discoverRemote url origin revision cloneDirectory
          case discovered of
            Left err -> pure (Left err)
            Right candidates -> do
              inserted <- foldM (insertCandidate searchRoot) (Right artifacts) candidates
              case inserted of
                Left err -> pure (Left err)
                Right artifacts' ->
                  go (index + 1) artifacts' (Map.insert url cloneDirectory clones) rest

discoverRemote ::
  Text ->
  OriginInfo ->
  Maybe Text ->
  FilePath ->
  IO (Either UpdateError [CandidateArtifact])
discoverRemote url origin revision repoRoot = do
  let registryFile = repoRoot </> "seihou-registry.dhall"
  hasRegistry <- Directory.doesFileExist registryFile
  if hasRegistry
    then do
      decoded <- evalRegistryFromFile registryFile
      case decoded of
        Left err -> pure (Left (CandidateLoadFailed (T.pack registryFile) err))
        Right registry -> do
          validationErrors <- validateRegistry repoRoot registry
          if null validationErrors
            then discoverRegistryArtifacts url revision repoRoot registry
            else pure (Left (CandidateRepositoryInvalid url validationErrors))
    else discoverSingleArtifact url origin revision repoRoot

discoverRegistryArtifacts ::
  Text ->
  Maybe Text ->
  FilePath ->
  Registry ->
  IO (Either UpdateError [CandidateArtifact])
discoverRegistryArtifacts url revision repoRoot registry = do
  modules <- traverse (loadRemoteModule url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #modules)
  recipes <- traverse (loadRemoteRecipe url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #recipes)
  pure ((<>) <$> sequence modules <*> sequence recipes)

discoverSingleArtifact ::
  Text ->
  OriginInfo ->
  Maybe Text ->
  FilePath ->
  IO (Either UpdateError [CandidateArtifact])
discoverSingleArtifact url origin revision repoRoot = do
  hasModule <- Directory.doesFileExist (repoRoot </> "module.dhall")
  hasRecipe <- Directory.doesFileExist (repoRoot </> "recipe.dhall")
  if hasModule
    then fmap (fmap (: [])) (loadModuleArtifact (Just url) (origin ^. #repoName) [] revision repoRoot)
    else
      if hasRecipe
        then fmap (fmap (: [])) (loadRecipeArtifact (Just url) (origin ^. #repoName) [] revision repoRoot)
        else pure (Left (CandidateRepositoryInvalid url ["repository contains no module, recipe, or registry"]))

loadRemoteModule ::
  Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact)
loadRemoteModule url repoName revision repoRoot entry =
  loadModuleArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot </> entry ^. #path)

loadRemoteRecipe ::
  Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact)
loadRemoteRecipe url repoName revision repoRoot entry =
  loadRecipeArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot </> entry ^. #path)

loadModuleArtifact ::
  Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact)
loadModuleArtifact sourceUrl repoName tags revision directory = do
  decoded <- evalModuleFromFile (directory </> "module.dhall")
  case decoded of
    Left err -> pure (Left (CandidateLoadFailed (T.pack directory) err))
    Right modul -> do
      validated <- validateModule directory modul
      case validated of
        Left err -> pure (Left (CandidateLoadFailed (modul ^. #name . #unModuleName) err))
        Right candidateModule -> do
          contentHash <- hashArtifactDirectory directory
          pure
            ( Right
                CandidateArtifact
                  { kind = CandidateModule,
                    name = candidateModule ^. #name . #unModuleName,
                    version = candidateModule ^. #version,
                    originalDirectory = directory,
                    sourceDirectory = directory,
                    sourceUrl,
                    repoName,
                    tags,
                    sourceRevision = revision,
                    contentHash,
                    moduleDefinition = Just candidateModule,
                    recipeDefinition = Nothing
                  }
            )

loadRecipeArtifact ::
  Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact)
loadRecipeArtifact sourceUrl repoName tags revision directory = do
  decoded <- evalRecipeFromFile (directory </> "recipe.dhall")
  case first (CandidateLoadFailed (T.pack directory)) decoded of
    Left err -> pure (Left err)
    Right recipe -> case first (CandidateRepositoryInvalid (maybe "local" id sourceUrl)) (validateRecipe recipe) of
      Left err -> pure (Left err)
      Right validated -> do
        contentHash <- hashArtifactDirectory directory
        pure
          ( Right
              CandidateArtifact
                { kind = CandidateRecipe,
                  name = validated ^. #name . #unRecipeName,
                  version = validated ^. #version,
                  originalDirectory = directory,
                  sourceDirectory = directory,
                  sourceUrl,
                  repoName,
                  tags,
                  sourceRevision = revision,
                  contentHash,
                  moduleDefinition = Nothing,
                  recipeDefinition = Just validated
                }
          )

stageLocalRequirements ::
  FilePath ->
  Map (CandidateArtifactKind, Text) CandidateArtifact ->
  [ArtifactRequirement] ->
  IO (Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact, [UpdateWarning]))
stageLocalRequirements searchRoot initial = go initial []
  where
    go artifacts warnings [] = pure (Right (artifacts, reverse warnings))
    go artifacts warnings (requirement : rest) = case requirement ^. #origin of
      Just _ -> go artifacts warnings rest
      Nothing
        | Map.member (requirement ^. #kind, requirement ^. #name) artifacts -> go artifacts warnings rest
        | otherwise -> case requirement ^. #sourceDirectory of
            -- There is no remote to fall back on and no local copy either, so
            -- the update cannot proceed. Report the resolution failure with
            -- its own wording rather than a generic "artifact missing".
            Left refErr -> pure (Left (CandidateArtifactUnresolved refErr))
            Right directory -> do
              loaded <- case requirement ^. #kind of
                CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing directory
                CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing directory
              case loaded of
                Left err -> pure (Left err)
                Right candidate -> do
                  inserted <- insertCandidate searchRoot (Right artifacts) candidate
                  case inserted of
                    Left err -> pure (Left err)
                    Right artifacts' ->
                      go artifacts' (LocalArtifactHasNoRemote (requirement ^. #name) : warnings) rest

insertCandidate ::
  FilePath ->
  Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact) ->
  CandidateArtifact ->
  IO (Either UpdateError (Map (CandidateArtifactKind, Text) CandidateArtifact))
insertCandidate _ (Left err) _ = pure (Left err)
insertCandidate searchRoot (Right artifacts) candidate =
  case Map.lookup key artifacts of
    Just existing ->
      pure
        ( Left
            ( CandidateArtifactAmbiguous
                (candidate ^. #kind)
                (candidate ^. #name)
                (map (maybe "local" id . (^. #sourceUrl)) [existing, candidate])
            )
        )
    Nothing -> do
      let destination = searchRoot </> T.unpack (candidate ^. #name)
      Directory.createDirectoryIfMissing True destination
      copied <- try @SomeException (copyDirectoryRecursive (candidate ^. #sourceDirectory) destination)
      pure $ case copied of
        Left err -> Left (CandidateRepositoryInvalid (candidate ^. #name) [T.pack (displayException err)])
        Right () ->
          Right
            ( Map.insert
                key
                (setCandidateSource destination candidate)
                artifacts
            )
  where
    key = (candidate ^. #kind, candidate ^. #name)

setCandidateSource :: FilePath -> CandidateArtifact -> CandidateArtifact
setCandidateSource directory candidate =
  CandidateArtifact
    { kind = candidate ^. #kind,
      name = candidate ^. #name,
      version = candidate ^. #version,
      originalDirectory = candidate ^. #originalDirectory,
      sourceDirectory = directory,
      sourceUrl = candidate ^. #sourceUrl,
      repoName = candidate ^. #repoName,
      tags = candidate ^. #tags,
      sourceRevision = candidate ^. #sourceRevision,
      contentHash = candidate ^. #contentHash,
      moduleDefinition = candidate ^. #moduleDefinition,
      recipeDefinition = candidate ^. #recipeDefinition
    }

verifyRemoteRequirements ::
  [ArtifactRequirement] ->
  Map (CandidateArtifactKind, Text) CandidateArtifact ->
  Either UpdateError ()
verifyRemoteRequirements requirements artifacts = traverse_ verify requirements
  where
    verify requirement = case Map.lookup (requirement ^. #kind, requirement ^. #name) artifacts of
      Nothing -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name))
      Just candidate -> case requirement ^. #origin of
        Nothing -> Right ()
        Just origin
          | candidate ^. #sourceUrl == Just (origin ^. #sourceUrl) -> Right ()
          | otherwise -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name))

gitRevision :: FilePath -> IO (Maybe Text)
gitRevision directory = do
  result <- try @SomeException (readProcessWithExitCode "git" ["-C", directory, "rev-parse", "HEAD"] "")
  pure $ case result of
    Right (ExitSuccess, stdout, _) -> Just (T.strip (T.pack stdout))
    _ -> Nothing

hashArtifactDirectory :: FilePath -> IO SHA256
hashArtifactDirectory root = do
  entries <- collectFiles root ""
  chunks <- forM entries $ \relative -> do
    bytes <- BS.readFile (root </> relative)
    pure (T.pack relative <> "\NUL" <> T.pack (show bytes))
  pure (hashContent (T.intercalate "\NUL" chunks))
  where
    collectFiles base relative = do
      let directory = if null relative then base else base </> relative
      names <- sort <$> Directory.listDirectory directory
      fmap concat $ forM names $ \name -> do
        let childRelative = if null relative then name else relative </> name
            child = base </> childRelative
        isDirectory <- Directory.doesDirectoryExist child
        if name == ".seihou-origin.json"
          then pure []
          else
            if isDirectory
              then
                if name == ".git"
                  then pure []
                  else collectFiles base childRelative
              else pure [childRelative]