ArtifactIdentity.hs

-- | When two recorded artifact origins name the same artifact.
--
-- The manifest identifies an artifact by its origin plus its name (see
-- docs\/adr\/0002-artifact-identity-is-origin-url-plus-name.md), and several
-- places have to ask whether two such identities are the same one: the
-- blueprint-migration receipt ledger in 'Seihou.Manifest.Types' when it
-- upserts a receipt, the pending-edge filter in
-- 'Seihou.CLI.BlueprintMigration' when it decides what still has to run, and
-- the pre-generation guard in 'Seihou.CLI.ManifestGuard' when it compares
-- what the manifest records against what is installed here. They must agree,
-- or a receipt could be written as a new entry while being read as a
-- duplicate, so the comparison lives in one place.
--
-- This module answers a plain yes-or-no question. The richer three-way
-- judgement that distinguishes "different artifact" from "cannot be proved
-- either way" belongs to 'Seihou.CLI.ManifestGuard.judgeArtifact' and is not
-- appropriate here: a receipt either records this exact identity or it does
-- not, with no unverifiable middle ground.
module Seihou.Core.ArtifactIdentity
  ( sameArtifactIdentity,
    normalizeOriginUrl,
    normalizeProjectPath,
    isMachineLocalOriginUrl,
  )
where

import Data.Char (isAsciiLower, isAsciiUpper)
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Seihou.Core.Types (ArtifactOrigin (..))
import Seihou.Prelude

-- | Whether two recorded origins name the same artifact.
--
-- Two origins of different kinds are never the same artifact. Within a kind
-- the comparison is structural, after normalising away spellings that differ
-- without meaning anything: a trailing @.git@ on a git URL, and a @.\/@
-- prefix or trailing slash on a project-relative path.
--
-- A 'LocalOrigin' carries no provenance at all, so two of them compare equal
-- exactly when they carry the same name. That is deliberately weak — it is
-- also the strongest statement available about an artifact seihou can only
-- identify by name — and it is what makes two receipts written before origins
-- were recorded still match each other.
sameArtifactIdentity :: ArtifactOrigin -> ArtifactOrigin -> Bool
sameArtifactIdentity left right = case (left, right) of
  (RemoteOrigin leftUrl leftName _, RemoteOrigin rightUrl rightName _) ->
    normalizeOriginUrl leftUrl == normalizeOriginUrl rightUrl
      && leftName == rightName
  (ProjectOrigin leftPath, ProjectOrigin rightPath) ->
    normalizeProjectPath leftPath == normalizeProjectPath rightPath
  (LocalOrigin leftName, LocalOrigin rightName) -> leftName == rightName
  _ -> False

-- | Reduce a git URL to a form two spellings of the same repository share.
--
-- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and
-- @https:\/\/host\/repo\/@ all name the same repository, and a manifest
-- written by a developer who typed one of them must not read as a different
-- artifact to a developer who typed another.
normalizeOriginUrl :: Text -> Text
normalizeOriginUrl =
  dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip
  where
    dropTrailingSlashes = T.dropWhileEnd (== '/')
    dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url)

-- | Reduce a project-relative path to a comparable form. The manifest stores
-- these with forward slashes; @.\/@ prefixes and trailing slashes are noise.
normalizeProjectPath :: FilePath -> FilePath
normalizeProjectPath =
  dropWhileEnd' (== '/') . dropDotPrefix . dropWhileEnd' (== '/')
  where
    dropDotPrefix path = fromMaybe path (stripPrefix' "./" path)
    stripPrefix' prefix path =
      if take (length prefix) path == prefix
        then Just (drop (length prefix) path)
        else Nothing
    dropWhileEnd' p = reverse . dropWhile p . reverse

-- | Whether a recorded origin URL is a path on the machine that recorded it
-- rather than a location every developer can reach.
--
-- @seihou install@ accepts a local checkout, and before plan 98 it stored
-- that path verbatim as the installed copy's @sourceUrl@, which then reached
-- the manifest as a 'RemoteOrigin'. A path means nothing on another machine
-- (docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md)
-- and turns into a false origin mismatch on this one as soon as the artifact
-- is reinstalled from its real remote.
--
-- True for text that, once stripped, starts with @\/@, @.\/@, @..\/@, @~@
-- or @file:@, is exactly @.@ or @..@, or is a Windows drive path
-- (@C:\\@ or @C:\/@). False for URLs with a network scheme
-- (@https:\/\/@, @ssh:\/\/@, @git:\/\/@) and for scp-style
-- @user\@host:path@.
isMachineLocalOriginUrl :: Text -> Bool
isMachineLocalOriginUrl raw =
  any (`T.isPrefixOf` url) ["/", "./", "../", "~", "file:"]
    || url == "."
    || url == ".."
    || isDrivePath url
  where
    url = T.strip raw
    isDrivePath text = case T.unpack (T.take 3 text) of
      [letter, ':', sep] -> isDriveLetter letter && (sep == '\\' || sep == '/')
      _ -> False
    isDriveLetter c = isAsciiLower c || isAsciiUpper c