module Hix.Managed.Cabal.Repo where

import Data.Time (UTCTime (..), 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 (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.Compat.Time (getFileAge)
import Distribution.Verbosity (Verbosity)
import Exon (exon)
import Path (Abs, File, Path, addExtension, parseAbsFile, toFilePath)
import Path.IO (doesFileExist)

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.Maybe (justIf)
import Hix.Monad (M, catchIOM, eitherFatalShow, noteFatal, tryIOM, tryIOMWith, withLower)

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
  |
  IndexMismatch
  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)

indexOutdated :: Path Abs File -> IO Bool
indexOutdated :: Path Abs File -> IO Bool
indexOutdated (Path Abs File -> String
forall b t. Path b t -> String
toFilePath -> String
index) =
  (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
7) (Double -> Bool) -> IO Double -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Double
getFileAge String
index

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

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"
      IndexProblem
IndexOutdated -> Text
"is older than 7 days"
      IndexProblem
IndexMismatch -> Text
"differs from requested index state"

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"

matchIndexState ::
  Verbosity ->
  RepoContext ->
  Repo ->
  HackageIndexState ->
  M (Maybe IndexProblem)
matchIndexState :: Verbosity
-> RepoContext
-> Repo
-> HackageIndexState
-> M (Maybe IndexProblem)
matchIndexState Verbosity
verbosity RepoContext
ctx Repo
repo (HackageIndexState Timestamp
target) =
  IO (Maybe IndexProblem)
-> (Text -> M (Maybe IndexProblem)) -> M (Maybe IndexProblem)
forall a. IO a -> (Text -> M a) -> M a
catchIOM (Timestamp -> Maybe IndexProblem
match (Timestamp -> Maybe IndexProblem)
-> IO Timestamp -> IO (Maybe IndexProblem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp Verbosity
verbosity RepoContext
ctx Repo
repo) (\ Text
_ -> Maybe IndexProblem -> M (Maybe IndexProblem)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just IndexProblem
IndexMissing))
  where
    match :: Timestamp -> Maybe IndexProblem
match Timestamp
current | Timestamp
current Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
== Timestamp
target = Maybe IndexProblem
forall a. Maybe a
Nothing
                  | Bool
otherwise = IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just IndexProblem
IndexMismatch

indexProblem ::
  SolveConfig ->
  RepoContext ->
  Repo ->
  Path Abs File ->
  M (Maybe IndexProblem)
indexProblem :: SolveConfig
-> RepoContext -> Repo -> Path Abs File -> M (Maybe IndexProblem)
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
  Text -> M ()
Log.debug [exon|Checking hackage snapshot at #{pathText path}|]
  IO Bool -> M Bool
forall a. IO a -> M a
tryIOM (Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path) M Bool
-> (Bool -> M (Maybe IndexProblem)) -> M (Maybe IndexProblem)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> Maybe IndexProblem -> M (Maybe IndexProblem)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just IndexProblem
IndexMissing)
    Bool
True
      | Just HackageIndexState
target <- CabalConfig
cabal.indexState
      -> Verbosity
-> RepoContext
-> Repo
-> HackageIndexState
-> M (Maybe IndexProblem)
matchIndexState Verbosity
verbosity RepoContext
ctx Repo
repo HackageIndexState
target
      | Bool
otherwise
      -> (Bool -> IndexProblem -> Maybe IndexProblem)
-> IndexProblem -> Bool -> Maybe IndexProblem
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IndexProblem -> Maybe IndexProblem
forall a. Bool -> a -> Maybe a
justIf IndexProblem
IndexOutdated (Bool -> Maybe IndexProblem) -> M Bool -> M (Maybe IndexProblem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> M Bool
forall a. IO a -> M a
tryIOM (Path Abs File -> IO Bool
indexOutdated Path Abs File
path)

-- 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 ()) -> Maybe IndexProblem -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SolveConfig
-> GlobalFlags -> NixStyleFlags () -> IndexProblem -> M ()
updateIndex SolveConfig
conf GlobalFlags
global NixStyleFlags ()
main) (Maybe IndexProblem -> M ()) -> M (Maybe IndexProblem) -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SolveConfig
-> RepoContext -> Repo -> Path Abs File -> M (Maybe IndexProblem)
indexProblem SolveConfig
conf RepoContext
ctx Repo
repo Path Abs File
path