module Hix.Managed.Cabal.Repo where

import Data.Time (
  NominalDiffTime,
  UTCTime (..),
  diffUTCTime,
  getCurrentTime,
  nominalDay,
  showGregorian,
  timeToTimeOfDay,
  )
import Distribution.Client.CmdUpdate (updateAction)
import qualified Distribution.Client.GlobalFlags
import Distribution.Client.GlobalFlags (GlobalFlags (..))
import Distribution.Client.IndexUtils (currentIndexTimestamp, indexBaseName)
import Distribution.Client.IndexUtils.Timestamp (Timestamp, timestampToUTCTime)
import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
import Distribution.Client.Setup (RepoContext, withRepoContext)
import Distribution.Client.Types (RemoteRepo (..), Repo (RepoSecure), RepoName (RepoName))
import qualified Distribution.Client.Types.Repo
import Distribution.Verbosity (Verbosity)
import Exon (exon)
import Path (Abs, File, Path, addExtension, parseAbsFile)

import Hix.Data.Error (Error (Fatal))
import Hix.Error (pathText)
import qualified Hix.Log as Log
import qualified Hix.Managed.Cabal.Data.Config
import Hix.Managed.Cabal.Data.Config (
  CabalConfig (CabalConfig),
  HackageIndexState (HackageIndexState),
  HackageRepoName (HackageRepoName),
  SolveConfig (SolveConfig),
  )
import Hix.Monad (M, catchIOM, eitherFatalShow, noteFatal, tryIOM, tryIOMWith, withLower)
import Hix.Pretty (showP)

withRepoContextM ::
  SolveConfig ->
  GlobalFlags ->
  (RepoContext -> M a) ->
  M a
withRepoContextM :: forall a. SolveConfig -> GlobalFlags -> (RepoContext -> M a) -> M a
withRepoContextM SolveConfig
conf GlobalFlags
flags RepoContext -> M a
f =
  (forall b. (M a -> IO b) -> IO b) -> M a
forall a. (forall b. (M a -> IO b) -> IO b) -> M a
withLower \ M a -> IO b
lower -> Verbosity -> GlobalFlags -> (RepoContext -> IO b) -> IO b
forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext SolveConfig
conf.verbosity GlobalFlags
flags \ RepoContext
ctx -> M a -> IO b
lower (RepoContext -> M a
f RepoContext
ctx)

fullHackageRepo ::
  SolveConfig ->
  RepoContext ->
  M Repo
fullHackageRepo :: SolveConfig -> RepoContext -> M Repo
fullHackageRepo SolveConfig {$sel:hackageRepoName:SolveConfig :: SolveConfig -> HackageRepoName
hackageRepoName = HackageRepoName (Text -> String
forall a. ToString a => a -> String
toString -> String
hackage)} RepoContext
ctx =
  Text -> Maybe Repo -> M Repo
forall a. Text -> Maybe a -> M a
noteFatal Text
err (Maybe Repo -> M Repo) -> Maybe Repo -> M Repo
forall a b. (a -> b) -> a -> b
$ ((Repo -> Bool) -> [Repo] -> Maybe Repo)
-> [Repo] -> (Repo -> Bool) -> Maybe Repo
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Repo -> Bool) -> [Repo] -> Maybe Repo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find RepoContext
ctx.repoContextRepos \case
    RepoSecure {repoRemote :: Repo -> RemoteRepo
repoRemote = RemoteRepo {remoteRepoName :: RemoteRepo -> RepoName
remoteRepoName = RepoName String
name}} -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hackage
    Repo
_ -> Bool
False
  where
    err :: Text
err = Text
"Bad Hackage repo config"

data IndexProblem =
  IndexMissing
  |
  IndexOutdated NominalDiffTime
  |
  IndexMismatch
  |
  IndexCorrupt Timestamp
  deriving stock (IndexProblem -> IndexProblem -> Bool
(IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> Bool) -> Eq IndexProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexProblem -> IndexProblem -> Bool
== :: IndexProblem -> IndexProblem -> Bool
$c/= :: IndexProblem -> IndexProblem -> Bool
/= :: IndexProblem -> IndexProblem -> Bool
Eq, Int -> IndexProblem -> ShowS
[IndexProblem] -> ShowS
IndexProblem -> String
(Int -> IndexProblem -> ShowS)
-> (IndexProblem -> String)
-> ([IndexProblem] -> ShowS)
-> Show IndexProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IndexProblem -> ShowS
showsPrec :: Int -> IndexProblem -> ShowS
$cshow :: IndexProblem -> String
show :: IndexProblem -> String
$cshowList :: [IndexProblem] -> ShowS
showList :: [IndexProblem] -> ShowS
Show, (forall x. IndexProblem -> Rep IndexProblem x)
-> (forall x. Rep IndexProblem x -> IndexProblem)
-> Generic IndexProblem
forall x. Rep IndexProblem x -> IndexProblem
forall x. IndexProblem -> Rep IndexProblem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IndexProblem -> Rep IndexProblem x
from :: forall x. IndexProblem -> Rep IndexProblem x
$cto :: forall x. Rep IndexProblem x -> IndexProblem
to :: forall x. Rep IndexProblem x -> IndexProblem
Generic)

data ValidIndex =
  IndexMatch HackageIndexState
  |
  IndexRecent NominalDiffTime
  deriving stock (ValidIndex -> ValidIndex -> Bool
(ValidIndex -> ValidIndex -> Bool)
-> (ValidIndex -> ValidIndex -> Bool) -> Eq ValidIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidIndex -> ValidIndex -> Bool
== :: ValidIndex -> ValidIndex -> Bool
$c/= :: ValidIndex -> ValidIndex -> Bool
/= :: ValidIndex -> ValidIndex -> Bool
Eq, Int -> ValidIndex -> ShowS
[ValidIndex] -> ShowS
ValidIndex -> String
(Int -> ValidIndex -> ShowS)
-> (ValidIndex -> String)
-> ([ValidIndex] -> ShowS)
-> Show ValidIndex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidIndex -> ShowS
showsPrec :: Int -> ValidIndex -> ShowS
$cshow :: ValidIndex -> String
show :: ValidIndex -> String
$cshowList :: [ValidIndex] -> ShowS
showList :: [ValidIndex] -> ShowS
Show, (forall x. ValidIndex -> Rep ValidIndex x)
-> (forall x. Rep ValidIndex x -> ValidIndex) -> Generic ValidIndex
forall x. Rep ValidIndex x -> ValidIndex
forall x. ValidIndex -> Rep ValidIndex x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidIndex -> Rep ValidIndex x
from :: forall x. ValidIndex -> Rep ValidIndex x
$cto :: forall x. Rep ValidIndex x -> ValidIndex
to :: forall x. Rep ValidIndex x -> ValidIndex
Generic)

updateRequest ::
  SolveConfig ->
  String
updateRequest :: SolveConfig -> String
updateRequest SolveConfig {HackageRepoName
$sel:hackageRepoName:SolveConfig :: SolveConfig -> HackageRepoName
hackageRepoName :: HackageRepoName
hackageRepoName, $sel:cabal:SolveConfig :: SolveConfig -> CabalConfig
cabal = CabalConfig {Maybe HackageIndexState
indexState :: Maybe HackageIndexState
$sel:indexState:CabalConfig :: CabalConfig -> Maybe HackageIndexState
indexState}} =
  [exon|#{hackage}#{extra}|]
  where
    extra :: String
extra = (UTCTime -> String) -> Maybe UTCTime -> String
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap UTCTime -> String
stateField (Timestamp -> Maybe UTCTime
timestampToUTCTime (Timestamp -> Maybe UTCTime)
-> (HackageIndexState -> Timestamp)
-> HackageIndexState
-> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageIndexState -> Timestamp
forall a b. Coercible a b => a -> b
coerce (HackageIndexState -> Maybe UTCTime)
-> Maybe HackageIndexState -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe HackageIndexState
indexState)

    stateField :: UTCTime -> String
stateField UTCTime {DiffTime
Day
utctDay :: Day
utctDayTime :: DiffTime
utctDay :: UTCTime -> Day
utctDayTime :: UTCTime -> DiffTime
..} = [exon|,#{showGregorian utctDay}T#{show (timeToTimeOfDay utctDayTime)}Z|]

    HackageRepoName (Text -> String
forall a. ToString a => a -> String
toString -> String
hackage) = HackageRepoName
hackageRepoName

maxIndexAgeDays :: Int
maxIndexAgeDays :: Int
maxIndexAgeDays = Int
7

maxIndexAge :: NominalDiffTime
maxIndexAge :: NominalDiffTime
maxIndexAge = NominalDiffTime
nominalDay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxIndexAgeDays

updateIndex ::
  SolveConfig ->
  GlobalFlags ->
  NixStyleFlags () ->
  IndexProblem ->
  M ()
updateIndex :: SolveConfig
-> GlobalFlags -> NixStyleFlags () -> IndexProblem -> M ()
updateIndex SolveConfig
conf GlobalFlags
global NixStyleFlags ()
main IndexProblem
problem = do
  Text -> M ()
Log.verbose [exon|Hackage snapshot #{message}, fetching...|]
  (Text -> Error) -> IO () -> M ()
forall a. (Text -> Error) -> IO a -> M a
tryIOMWith (\ Text
err -> Text -> Error
Fatal [exon|Fetching Hackage snapshot failed: #{err}|]) do
    NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
updateAction NixStyleFlags ()
main [SolveConfig -> String
updateRequest SolveConfig
conf] GlobalFlags
global
  where
    message :: Text
message = case IndexProblem
problem of
      IndexProblem
IndexMissing -> Text
"doesn't exist"
      IndexOutdated NominalDiffTime
age -> [exon|is older than #{show maxIndexAgeDays} days (#{show age})|]
      IndexProblem
IndexMismatch -> Text
"differs from requested index state"
      IndexCorrupt Timestamp
stamp -> [exon|has corrupt timestamp (#{show stamp})|]

indexPath :: Repo -> M (Path Abs File)
indexPath :: Repo -> M (Path Abs File)
indexPath Repo
repo =
  Text -> Either SomeException (Path Abs File) -> M (Path Abs File)
forall b a. Show b => Text -> Either b a -> M a
eitherFatalShow Text
err do
    Path Abs File
base <- String -> Either SomeException (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (Repo -> String
indexBaseName Repo
repo)
    String -> Path Abs File -> Either SomeException (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
".tar" Path Abs File
base
  where
    err :: Text
err = Text
"Bad Hackage repo config"

currentIndexState ::
  Verbosity ->
  RepoContext ->
  Repo ->
  M (Maybe HackageIndexState)
currentIndexState :: Verbosity -> RepoContext -> Repo -> M (Maybe HackageIndexState)
currentIndexState Verbosity
verbosity RepoContext
ctx Repo
repo =
  IO (Maybe HackageIndexState)
-> (Text -> M (Maybe HackageIndexState))
-> M (Maybe HackageIndexState)
forall a. IO a -> (Text -> M a) -> M a
catchIOM (HackageIndexState -> Maybe HackageIndexState
forall a. a -> Maybe a
Just (HackageIndexState -> Maybe HackageIndexState)
-> (Timestamp -> HackageIndexState)
-> Timestamp
-> Maybe HackageIndexState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> HackageIndexState
HackageIndexState (Timestamp -> Maybe HackageIndexState)
-> IO Timestamp -> IO (Maybe HackageIndexState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp Verbosity
verbosity RepoContext
ctx Repo
repo) (M (Maybe HackageIndexState) -> Text -> M (Maybe HackageIndexState)
forall a b. a -> b -> a
const (Maybe HackageIndexState -> M (Maybe HackageIndexState)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HackageIndexState
forall a. Maybe a
Nothing))

indexProblem ::
  SolveConfig ->
  RepoContext ->
  Repo ->
  Path Abs File ->
  M (Either IndexProblem ValidIndex)
indexProblem :: SolveConfig
-> RepoContext
-> Repo
-> Path Abs File
-> M (Either IndexProblem ValidIndex)
indexProblem SolveConfig {Verbosity
verbosity :: Verbosity
$sel:verbosity:SolveConfig :: SolveConfig -> Verbosity
verbosity, CabalConfig
$sel:cabal:SolveConfig :: SolveConfig -> CabalConfig
cabal :: CabalConfig
cabal} RepoContext
ctx Repo
repo Path Abs File
path = do
  UTCTime
now <- IO UTCTime -> M UTCTime
forall a. IO a -> M a
tryIOM IO UTCTime
getCurrentTime
  Text -> M ()
Log.debug [exon|Checking Hackage snapshot at #{pathText path}|]
  Verbosity -> RepoContext -> Repo -> M (Maybe HackageIndexState)
currentIndexState Verbosity
verbosity RepoContext
ctx Repo
repo M (Maybe HackageIndexState)
-> (Maybe HackageIndexState -> Either IndexProblem ValidIndex)
-> M (Either IndexProblem ValidIndex)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    -- There is no index, so the target is irrelevant.
    Maybe HackageIndexState
Nothing -> IndexProblem -> Either IndexProblem ValidIndex
forall a b. a -> Either a b
Left IndexProblem
IndexMissing
    Just HackageIndexState
currentState
      -- If a target index state was specified, we only care whether it matches exactly.
      -- The later conditions are irrelevant.
      | Just HackageIndexState
target <- CabalConfig
cabal.indexState
      -> if HackageIndexState
currentState HackageIndexState -> HackageIndexState -> Bool
forall a. Eq a => a -> a -> Bool
== HackageIndexState
target
         then ValidIndex -> Either IndexProblem ValidIndex
forall a b. b -> Either a b
Right (HackageIndexState -> ValidIndex
IndexMatch HackageIndexState
target)
         else IndexProblem -> Either IndexProblem ValidIndex
forall a b. a -> Either a b
Left IndexProblem
IndexMismatch
      -- If no target was specified, the age of the current index must be below the threshold.
      -- The guard expresses that the timestamp could be parsed.
      | Just UTCTime
current <- Maybe UTCTime
currentUTC
      , let age :: NominalDiffTime
age = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
current
      -> if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
current NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
maxIndexAge
         then IndexProblem -> Either IndexProblem ValidIndex
forall a b. a -> Either a b
Left (NominalDiffTime -> IndexProblem
IndexOutdated NominalDiffTime
age)
         else ValidIndex -> Either IndexProblem ValidIndex
forall a b. b -> Either a b
Right (NominalDiffTime -> ValidIndex
IndexRecent NominalDiffTime
age)
      -- If the current state's timestamp can't be converted to UTCTime, it may be corrupt, so we update.
      | Bool
otherwise
      -> IndexProblem -> Either IndexProblem ValidIndex
forall a b. a -> Either a b
Left (Timestamp -> IndexProblem
IndexCorrupt (HackageIndexState -> Timestamp
forall a b. Coercible a b => a -> b
coerce HackageIndexState
currentState))
      where
        currentUTC :: Maybe UTCTime
currentUTC = Timestamp -> Maybe UTCTime
timestampToUTCTime (HackageIndexState -> Timestamp
forall a b. Coercible a b => a -> b
coerce HackageIndexState
currentState)

logValid ::
  ValidIndex ->
  M ()
logValid :: ValidIndex -> M ()
logValid = \case
  IndexMatch (HackageIndexState Timestamp
ts) -> Text -> M ()
Log.debug [exon|Snapshot matches target: #{showP ts}|]
  IndexRecent NominalDiffTime
age ->
    Text -> M ()
Log.debug [exon|Snapshot is less than #{desc} old (maximum #{show maxIndexAgeDays}).|]
    where
      desc :: Text
desc | Int
days Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Text
"a day"
           | Bool
otherwise = [exon|#{show days} days|]
      days :: Int
      days :: Int
days = Int -> (NominalDiffTime -> Int) -> Maybe NominalDiffTime -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> Maybe NominalDiffTime
forall a. (Eq a, Fractional a) => a -> a -> Maybe a
/ NominalDiffTime
nominalDay)

-- TODO currentIndexTimestamp has a different signature in later versions
ensureHackageIndex ::
  SolveConfig ->
  GlobalFlags ->
  NixStyleFlags () ->
  M ()
ensureHackageIndex :: SolveConfig -> GlobalFlags -> NixStyleFlags () -> M ()
ensureHackageIndex SolveConfig
conf GlobalFlags
global NixStyleFlags ()
main =
  SolveConfig -> GlobalFlags -> (RepoContext -> M ()) -> M ()
forall a. SolveConfig -> GlobalFlags -> (RepoContext -> M a) -> M a
withRepoContextM SolveConfig
conf GlobalFlags
global \ RepoContext
ctx -> do
    Repo
repo <- SolveConfig -> RepoContext -> M Repo
fullHackageRepo SolveConfig
conf RepoContext
ctx
    Path Abs File
path <- Repo -> M (Path Abs File)
indexPath Repo
repo
    (IndexProblem -> M ())
-> (ValidIndex -> M ()) -> Either IndexProblem ValidIndex -> M ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SolveConfig
-> GlobalFlags -> NixStyleFlags () -> IndexProblem -> M ()
updateIndex SolveConfig
conf GlobalFlags
global NixStyleFlags ()
main) ValidIndex -> M ()
logValid (Either IndexProblem ValidIndex -> M ())
-> M (Either IndexProblem ValidIndex) -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SolveConfig
-> RepoContext
-> Repo
-> Path Abs File
-> M (Either IndexProblem ValidIndex)
indexProblem SolveConfig
conf RepoContext
ctx Repo
repo Path Abs File
path