{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | Copyright: (c) 2021-2025 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <[email protected]>
-- Stability: experimental
-- Portability: portable
--
-- The main module of nvfetcher. If you want to create CLI program with it, it's enough to import only this module.
--
-- Example:
--
-- @
-- module Main where
--
-- import NvFetcher
--
-- main :: IO ()
-- main = runNvFetcher packageSet
--
-- packageSet :: PackageSet ()
-- packageSet = do
--   define $ package "feeluown-core" `fromPypi` "feeluown"
--   define $ package "qliveplayer" `fromGitHub` ("THMonster", "QLivePlayer")
-- @
--
-- You can find more examples of packages in @Main_example.hs@.
--
-- Running the created program:
--
-- * @main@ -- abbreviation of @main build@
-- * @main build@ -- build nix sources expr from given @packageSet@
-- * @main clean@ -- delete .shake dir and generated nix file
--
-- All shake options are inherited.
module NvFetcher
  ( runNvFetcher,
    runNvFetcher',
    runNvFetcherNoCLI,
    applyCliOptions,
    parseLastVersions,
    module NvFetcher.PackageSet,
    module NvFetcher.Types,
    module NvFetcher.Types.ShakeExtras,
  )
where

import Control.Monad.Extra (forM_, unless, when, whenJust, whenM)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encode.Pretty as A
import qualified Data.Aeson.Types as A
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Default
import Data.List (partition, (\\))
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Development.Shake
import Development.Shake.FilePath
import NeatInterpolation (trimming)
import NvFetcher.Config
import NvFetcher.Core
import NvFetcher.NixExpr (ToNixExpr (toNixExpr))
import NvFetcher.NixFetcher
import NvFetcher.Nvchecker
import NvFetcher.Options
import NvFetcher.PackageSet
import NvFetcher.Types
import NvFetcher.Types.ShakeExtras
import NvFetcher.Utils (aesonKey, getDataDir)
import qualified System.Directory.Extra as D
import Text.Regex.TDFA ((=~))

-- | Run nvfetcher with CLI options
--
-- This function calls 'runNvFetcherNoCLI', using 'def' 'Config' overridden by 'CLIOptions'.
-- Use this function to create your own Haskell executable program.
runNvFetcher :: PackageSet () -> IO ()
runNvFetcher :: PackageSet () -> IO ()
runNvFetcher = Config -> PackageSet () -> IO ()
runNvFetcher' Config
forall a. Default a => a
def

-- | Similar to 'runNvFetcher', but uses custom @config@ instead of 'def' overridden by 'CLIOptions'
runNvFetcher' :: Config -> PackageSet () -> IO ()
runNvFetcher' :: Config -> PackageSet () -> IO ()
runNvFetcher' Config
config PackageSet ()
packageSet =
  Parser CLIOptions -> IO CLIOptions
forall a. Parser a -> IO a
getCLIOptions Parser CLIOptions
cliOptionsParser IO CLIOptions -> (CLIOptions -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CLIOptions
cli ->
    Config -> CLIOptions -> IO Config
applyCliOptions Config
config CLIOptions
cli IO Config -> (Config -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Config
o ->
      Config -> Target -> PackageSet () -> IO ()
runNvFetcherNoCLI Config
o (CLIOptions -> Target
optTarget CLIOptions
cli) PackageSet ()
packageSet

-- | Apply 'CLIOptions' to 'Config'
applyCliOptions :: Config -> CLIOptions -> IO Config
applyCliOptions :: Config -> CLIOptions -> IO Config
applyCliOptions Config
config CLIOptions {Bool
Int
String
Maybe String
Target
optTarget :: CLIOptions -> Target
optBuildDir :: String
optCommit :: Bool
optCommitSummary :: Maybe String
optLogPath :: Maybe String
optThreads :: Int
optRetry :: Int
optTiming :: Bool
optVerbose :: Bool
optPkgNameFilter :: Maybe String
optKeyfile :: Maybe String
optKeepOldFiles :: Bool
optKeepGoing :: Bool
optTarget :: Target
optKeepGoing :: CLIOptions -> Bool
optKeepOldFiles :: CLIOptions -> Bool
optKeyfile :: CLIOptions -> Maybe String
optPkgNameFilter :: CLIOptions -> Maybe String
optVerbose :: CLIOptions -> Bool
optTiming :: CLIOptions -> Bool
optRetry :: CLIOptions -> Int
optThreads :: CLIOptions -> Int
optLogPath :: CLIOptions -> Maybe String
optCommitSummary :: CLIOptions -> Maybe String
optCommit :: CLIOptions -> Bool
optBuildDir :: CLIOptions -> String
..} = do
  aKeyfile <- case Maybe String
optKeyfile of
    Just String
k -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
D.makeAbsolute String
k
    Maybe String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  pure $
    config
      { buildDir = optBuildDir,
        actionAfterBuild = do
          whenJust optLogPath logChangesToFile
          when optCommit (commitChanges (fromMaybe "Update" optCommitSummary))
          actionAfterBuild config,
        shakeConfig =
          (shakeConfig config)
            { shakeTimings = optTiming,
              shakeVerbosity = if optVerbose then Verbose else Info,
              shakeThreads = optThreads
            },
        filterRegex = optPkgNameFilter,
        retry = optRetry,
        keyfile = aKeyfile,
        keepOldFiles = optKeepOldFiles,
        keepGoing = optKeepGoing
      }

logChangesToFile :: FilePath -> Action ()
logChangesToFile :: String -> Action ()
logChangesToFile String
fp = do
  changes <- Action [VersionChange]
getVersionChanges
  writeFile' fp $ unlines $ show <$> changes

commitChanges :: String -> Action ()
commitChanges :: String -> Action ()
commitChanges String
commitSummary = do
  changes <- Action [VersionChange]
getVersionChanges
  let commitMsg = case [VersionChange]
changes of
        [VersionChange
x] -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ VersionChange -> String
forall a. Show a => a -> String
show VersionChange
x
        xs :: [VersionChange]
xs@(VersionChange
_ : [VersionChange]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
commitSummary String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines (VersionChange -> String
forall a. Show a => a -> String
show (VersionChange -> String) -> [VersionChange] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VersionChange]
xs)
        [] -> Maybe String
forall a. Maybe a
Nothing
  whenJust commitMsg $ \String
msg -> do
    String -> Action ()
putInfo String
"Commiting changes"
    Action String
getBuildDir Action String -> (String -> Action ()) -> Action ()
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
dir -> Located => [CmdOption] -> String -> [String] -> Action ()
[CmdOption] -> String -> [String] -> Action ()
command_ [] String
"git" [String
"add", String
dir]
    Located => [CmdOption] -> String -> [String] -> Action ()
[CmdOption] -> String -> [String] -> Action ()
command_ [] String
"git" [String
"commit", String
"-m", String
msg]

-- | @Parse generated.nix@
parseLastVersions :: FilePath -> IO (Maybe (Map.Map PackageKey Version))
parseLastVersions :: String -> IO (Maybe (Map PackageKey Version))
parseLastVersions String
jsonFile =
  String -> IO Bool
D.doesFileExist String
jsonFile IO Bool
-> (Bool -> IO (Maybe (Map PackageKey Version)))
-> IO (Maybe (Map PackageKey Version))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> do
      objs <- String -> IO (Maybe (Map PackageName Object))
forall a. FromJSON a => String -> IO (Maybe a)
A.decodeFileStrict' String
jsonFile
      pure $
        flip fmap objs $
          ( \[(PackageName, Object)]
xs ->
              [(PackageKey, Version)] -> Map PackageKey Version
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                ([(PackageKey, Version)] -> Map PackageKey Version)
-> ([Maybe (PackageKey, Version)] -> [(PackageKey, Version)])
-> [Maybe (PackageKey, Version)]
-> Map PackageKey Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (PackageKey, Version)] -> [(PackageKey, Version)]
forall a. [Maybe a] -> [a]
catMaybes
                ([Maybe (PackageKey, Version)] -> Map PackageKey Version)
-> [Maybe (PackageKey, Version)] -> Map PackageKey Version
forall a b. (a -> b) -> a -> b
$ [(PackageName -> PackageKey
PackageKey PackageName
k,) (Version -> (PackageKey, Version))
-> Maybe Version -> Maybe (PackageKey, Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> Parser Version) -> Object -> Maybe Version
forall a b. (a -> Parser b) -> a -> Maybe b
A.parseMaybe (Object -> Key -> Parser Version
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"version") Object
obj | (PackageName
k, Object
obj) <- [(PackageName, Object)]
xs]
          )
            . Map.toList
    Bool
_ -> Maybe (Map PackageKey Version)
-> IO (Maybe (Map PackageKey Version))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map PackageKey Version)
forall a. Monoid a => a
mempty

-- | Entry point of nvfetcher
runNvFetcherNoCLI :: Config -> Target -> PackageSet () -> IO ()
runNvFetcherNoCLI :: Config -> Target -> PackageSet () -> IO ()
runNvFetcherNoCLI config :: Config
config@Config {Bool
Int
String
Maybe String
ShakeOptions
Action ()
Rules ()
buildDir :: Config -> String
actionAfterBuild :: Config -> Action ()
shakeConfig :: Config -> ShakeOptions
filterRegex :: Config -> Maybe String
retry :: Config -> Int
keyfile :: Config -> Maybe String
keepOldFiles :: Config -> Bool
keepGoing :: Config -> Bool
shakeConfig :: ShakeOptions
buildDir :: String
customRules :: Rules ()
actionAfterBuild :: Action ()
actionAfterClean :: Action ()
retry :: Int
filterRegex :: Maybe String
cacheNvchecker :: Bool
keepOldFiles :: Bool
keyfile :: Maybe String
keepGoing :: Bool
cacheNvchecker :: Config -> Bool
actionAfterClean :: Config -> Action ()
customRules :: Config -> Rules ()
..} Target
target PackageSet ()
packageSet = do
  pkgs <- (Package -> Package)
-> Map PackageKey Package -> Map PackageKey Package
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Package -> Package
pinIfUnmatch (Map PackageKey Package -> Map PackageKey Package)
-> IO (Map PackageKey Package) -> IO (Map PackageKey Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageSet () -> IO (Map PackageKey Package)
runPackageSet PackageSet ()
packageSet
  lastVersions <- parseLastVersions $ buildDir </> generatedJsonFileName
  shakeDir <- getDataDir
  -- Set shakeFiles and shakeVersion
  let shakeOptions1 = ShakeOptions
shakeConfig {shakeFiles = shakeDir, shakeVersion = "2"}
  -- shakeConfig in Config will be shakeOptions1 (not including shake extra)
  shakeExtras <- initShakeExtras (config {shakeConfig = shakeOptions1}) pkgs $ fromMaybe mempty lastVersions
  -- Set shakeExtra
  let shakeOptions2 = ShakeOptions
shakeOptions1 {shakeExtra = addShakeExtra shakeExtras (shakeExtra shakeConfig)}
      rules = Config -> Rules ()
mainRules Config
config

  -- Remove all files in build dir except generated nix and json
  -- Since core rule has always rerun, any file not generated in this run will be removed
  -- Put it here to avoid removing files generated in this run
  unless (keepOldFiles || (target /= Build)) $
    whenM (D.doesDirectoryExist buildDir) $ do
      oldFiles <- (\\ [generatedJsonFileName, generatedNixFileName]) <$> D.listDirectory buildDir
      putStrLn $ "Removing old files: " <> show oldFiles
      liftIO $ removeFiles buildDir oldFiles
  shake shakeOptions2 $ want [show target] >> rules
  where
    -- Don't touch already pinned packages
    pinIfUnmatch :: Package -> Package
pinIfUnmatch x :: Package
x@Package {Maybe PackageCargoLockFiles
Maybe PackageExtractSrc
(GitDateFormat, GitTimeZone)
PackageName
UseStaleVersion
PackagePassthru
ForceFetch
CheckVersion
PackageFetcher
_pname :: PackageName
_pversion :: CheckVersion
_pfetcher :: PackageFetcher
_pextract :: Maybe PackageExtractSrc
_pcargo :: Maybe PackageCargoLockFiles
_ppassthru :: PackagePassthru
_ppinned :: UseStaleVersion
_pgitdate :: (GitDateFormat, GitTimeZone)
_pforcefetch :: ForceFetch
_pforcefetch :: Package -> ForceFetch
_pgitdate :: Package -> (GitDateFormat, GitTimeZone)
_ppinned :: Package -> UseStaleVersion
_ppassthru :: Package -> PackagePassthru
_pcargo :: Package -> Maybe PackageCargoLockFiles
_pextract :: Package -> Maybe PackageExtractSrc
_pfetcher :: Package -> PackageFetcher
_pversion :: Package -> CheckVersion
_pname :: Package -> PackageName
..}
      | Just String
regex <- Maybe String
filterRegex =
          Package
x
            { _ppinned = case _ppinned of
                UseStaleVersion
PermanentStale -> UseStaleVersion
PermanentStale
                UseStaleVersion
_ ->
                  if PackageName
_pname PackageName -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
regex
                    then UseStaleVersion
NoStale
                    else UseStaleVersion
TemporaryStale
            }
      | Bool
otherwise = Package
x

--------------------------------------------------------------------------------

mainRules :: Config -> Rules ()
mainRules :: Config -> Rules ()
mainRules Config {Bool
Int
String
Maybe String
ShakeOptions
Action ()
Rules ()
buildDir :: Config -> String
actionAfterBuild :: Config -> Action ()
shakeConfig :: Config -> ShakeOptions
filterRegex :: Config -> Maybe String
retry :: Config -> Int
keyfile :: Config -> Maybe String
keepOldFiles :: Config -> Bool
keepGoing :: Config -> Bool
cacheNvchecker :: Config -> Bool
actionAfterClean :: Config -> Action ()
customRules :: Config -> Rules ()
shakeConfig :: ShakeOptions
buildDir :: String
customRules :: Rules ()
actionAfterBuild :: Action ()
actionAfterClean :: Action ()
retry :: Int
filterRegex :: Maybe String
cacheNvchecker :: Bool
keepOldFiles :: Bool
keyfile :: Maybe String
keepGoing :: Bool
..} = do
  String
"clean" Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
~> do
    Action String
getBuildDir Action String -> (String -> Action ()) -> Action ()
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> [String] -> Action ())
-> [String] -> String -> Action ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Action ()
removeFilesAfter [String
"//*"]
    Action ()
actionAfterClean

  String
"purge" Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
~> do
    shakeDir <- ShakeOptions -> String
shakeFiles (ShakeOptions -> String) -> Action ShakeOptions -> Action String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action ShakeOptions
getShakeOptions
    removeFilesAfter shakeDir ["//*"]

  String
"build" Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
~> do
    allKeys <- Action [PackageKey]
getAllPackageKeys
    results <- fmap (zip allKeys) $ parallel $ runPackage <$> allKeys
    let (fmap (fromJust . snd) -> successResults, fmap fst -> failureKeys) = partition (isJust . snd) results
    -- Record removed packages to version changes
    -- Failure keys are also considered as removed in this run
    getAllOnDiskVersions
      >>= \Map PackageKey Version
oldPkgs -> [PackageKey] -> (PackageKey -> Action ()) -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PackageKey Version -> [PackageKey]
forall k a. Map k a -> [k]
Map.keys Map PackageKey Version
oldPkgs [PackageKey] -> [PackageKey] -> [PackageKey]
forall a. Eq a => [a] -> [a] -> [a]
\\ ([PackageKey]
allKeys [PackageKey] -> [PackageKey] -> [PackageKey]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PackageKey]
failureKeys)) ((PackageKey -> Action ()) -> Action ())
-> (PackageKey -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$
        \PackageKey
pkg -> PackageName -> Maybe Version -> Version -> Action ()
recordVersionChange (PackageKey -> PackageName
forall a b. Coercible a b => a -> b
coerce PackageKey
pkg) (Map PackageKey Version
oldPkgs Map PackageKey Version -> PackageKey -> Maybe Version
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? PackageKey
pkg) Version
"∅"
    getVersionChanges >>= \[VersionChange]
changes ->
      if [VersionChange] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VersionChange]
changes
        then String -> Action ()
putInfo String
"Up to date"
        else do
          String -> Action ()
putInfo String
"Changes:"
          String -> Action ()
putInfo (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ VersionChange -> String
forall a. Show a => a -> String
show (VersionChange -> String) -> [VersionChange] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VersionChange]
changes
    buildDir <- getBuildDir
    let generatedNixPath = String
buildDir String -> String -> String
</> String
generatedNixFileName
        generatedJSONPath = String
buildDir String -> String -> String
</> String
generatedJsonFileName
    putVerbose $ "Generating " <> generatedNixPath
    writeFileChanged generatedNixPath $ T.unpack $ srouces (T.unlines $ toNixExpr <$> successResults) <> "\n"
    putVerbose $ "Generating " <> generatedJSONPath
    writeFileChanged generatedJSONPath $ LBS.unpack $ A.encodePretty $ A.object [aesonKey (_prname r) A..= r | r <- successResults]
    actionAfterBuild

  Rules ()
customRules
  Rules ()
coreRules

srouces :: Text -> Text
srouces :: PackageName -> PackageName
srouces PackageName
body =
  [trimming|
    # This file was generated by nvfetcher, please do not modify it manually.
    {
      fetchgit,
      fetchurl,
      fetchFromGitHub,
      dockerTools,
    }:
    {
      $body
    }
  |]

generatedNixFileName :: String
generatedNixFileName :: String
generatedNixFileName = String
"generated.nix"

generatedJsonFileName :: String
generatedJsonFileName :: String
generatedJsonFileName = String
"generated.json"