LowLevel.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}

module GHCup.Command.Install.LowLevel where

import GHCup.Errors
import GHCup.Input.Parsers.Domain
import GHCup.Input.SymlinkSpec
import GHCup.Prelude
import GHCup.Prelude.Process
import GHCup.Query.DB
import GHCup.Query.GHCupDirs
import GHCup.Query.Symlink
import GHCup.System.Cmd
import GHCup.System.Directory
import GHCup.Types
import GHCup.Types.JSON (safePath, safeFilename)
import GHCup.Types.Optics

import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Data.Yaml.Pretty
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Maybe
import Data.Variant.Excepts
import Data.Versions                hiding ( patch )
import Prelude                      hiding ( abs )
import System.FilePath
import System.FilePattern.Directory

import qualified Data.ByteString       as B
import qualified Data.Map.Strict       as M
import qualified Data.Text             as T
import qualified System.FilePath.Posix as Posix
import qualified Text.Megaparsec       as MP





mergeToFileSystem ::
  ( MonadMask m
  , MonadReader env m
  , HasDirs env
  , HasLog env
  , MonadCatch m
  , MonadIOish m
  )
  => Tool
  -> TargetVersion
  -> InstallDirResolved   -- ^ Path to install to
  -> GHCupPath            -- ^ DESTDIR
  -> Bool
  -> Bool
  -> Bool
  -> Excepts '[MergeFileTreeError] m ()
mergeToFileSystem tool tver installDest tmpInstallDest preserveMtimes forceInstall append = do
  mergeFileTree
    (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir installDest))
    installDest
    tool
    tver
    (\f t -> if preserveMtimes
             then liftIO $ copyFuncMtime f t
             else liftIO $ install f t (not forceInstall)


    )
    append
 where
  copyFuncMtime f t = do
    mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)
    install f t (not forceInstall)
    forM_ mtime $ setModificationTime t

installTheSpec ::
  ( HasLog env
  , HasDirs env
  , HasSettings env
  , MonadReader env m
  , MonadIOish m
  )
  => InstallationSpecInput
  -> FilePath             -- ^ Path to the unpacked bindist
  -> InstallDirResolved   -- ^ Path to install to
  -> GHCupPath            -- ^ DESTDIR
  -> [String]
  -> Maybe [String]
  -> Bool
  -> Excepts '[ CopyError
              , MergeFileTreeError
              , ProcessError
              , ParseError
              , MalformedInstallInfo
              , InvalidBuildConfig
              ] m ()
installTheSpec InstallationSpec{..} workdir installDest tmpInstallDest extraArgs installTargets forceInstall = do
  -- run configure first
  case _isConfigure of
    Just ConfigSpec{..} -> do
      addConfArgs <- lift $ sanitizefConfOptions extraArgs

      let configFile = fromMaybe "configure" _csConfigFile
      processedConfArgs <- forM _csConfigArgs $ \a -> liftE $ throwOnParseError . parseDomain $ a
      newEnv <- forM _csConfigEnv $ \EnvSpec{..} -> do
        processedEnv <- liftE $ throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val)
        liftIO (augmentEnvironment processedEnv _esUnion)
      liftE $ execWithWrapper "sh"
                       (("." Posix.</> configFile) : processedConfArgs <> addConfArgs
                       )
                       (Just workdir)
                       "ghc-configure"
                       newEnv
    _ -> pure ()

  -- then make
  case _isMake of
    Just MakeSpec{..} -> do
      processedMakeArgs <- case installTargets of
        Just it -> do
          -- we need to check whether applying 'installTargets' would wipe out PREFIX/DESTDIR
          origArgs <- liftE $ throwOnParseError $ forM _msMakeArgs parseDomain
          if origArgs /= _msMakeArgs
          then throwE $ InvalidBuildConfig $ "Can't overwrite install targets " <> T.pack (show _msMakeArgs) <> " since they contain domain variables."
          else liftE $ throwOnParseError $ forM it parseDomain
        Nothing ->
          liftE $ throwOnParseError $ forM _msMakeArgs parseDomain

      newEnv <- forM _msMakeEnv $ \EnvSpec{..} -> do
        processedEnv <- liftE $ throwOnParseError $ forM _esEnv (\(var, val) -> (var,) <$> parseDomain val)
        liftIO (augmentEnvironment processedEnv _esUnion)
      liftE $ makeWithWrapper processedMakeArgs (Just workdir) "make" newEnv
    _ -> pure ()

  -- then copy files manually, if any
  forM_ _isExeRules $ \case
    InstallFileRule{..} -> do
      f <- copy _ibrInstallSource _ibrInstallDest
      lift $ chmod_755 f
    InstallFilePatternRule{..} -> do
      files <- liftIO $ getDirectoryFiles workdir _ibrInstallPattern
      forM_ files $ \file -> do
        f <- copy file Nothing
        lift $ chmod_755 f

  forM_ _isDataRules $ \case
    InstallFileRule{..} ->
      void $ copy _ibrInstallSource _ibrInstallDest
    InstallFilePatternRule{..} -> do
      files <- liftIO $ getDirectoryFiles workdir _ibrInstallPattern
      forM_ files $ \file -> copy file Nothing

 where
  copy source destFile = do
    let from = workdir </> source
        destDir = fromGHCupPath tmpInstallDest </> dropDrive (fromInstallDir installDest)
        into = destDir </> fromMaybe source destFile
    liftIO $ createDirRecursive' (takeDirectory into)
    handleIO (throwE . CopyError . show) . liftIO . install from into  $ not forceInstall
    logDebug $ "cp " <> (if forceInstall then "-f " else "") <> T.pack from <> " " <> T.pack into
    pure into

  env = M.fromList [(PREFIX, fromInstallDir installDest)
                   ,(TMPDIR, fromGHCupPath tmpInstallDest)
                   ]
  parseDomain = MP.parse (domainParser env) "installTheSpec"

makeWithWrapper ::
  ( MonadIOish m
  , HasSettings env
  , HasLog env
  , HasDirs env
  , MonadReader env m
  )
  => [String]
  -> Maybe FilePath
  -> FilePath
  -> Maybe [(String, String)]
  -> Excepts
       '[ ProcessError
        ]
       m
       ()
makeWithWrapper args' mWorkDir logLabel mEnv = do
  mymake <- liftIO getBestMake
  liftE $ execWithWrapper mymake args' mWorkDir logLabel mEnv

execWithWrapper ::
  ( MonadIOish m
  , HasSettings env
  , HasLog env
  , HasDirs env
  , MonadReader env m
  )
  => String
  -> [String]
  -> Maybe FilePath
  -> FilePath
  -> Maybe [(String, String)]
  -> Excepts
       '[ ProcessError
        ]
       m
       ()
execWithWrapper cmd' args' mWorkDir logLabel mEnv = do
  Settings{ buildWrapper } <- lift getSettings
  case buildWrapper of
    Just ProcessSpec{..} ->
      lEM $ execLogged cmd (cmdArgs <> ["--"] <> (cmd':args')) mWorkDir logLabel mEnv
    Nothing ->
      lEM $ execLogged cmd' args' mWorkDir logLabel mEnv

-- | Write InstallationInfo to the disk.
recordInstallationInfo ::
  ( MonadReader env m
  , HasDirs env
  , HasLog env
  , MonadIOish m
  )
  => InstallDirResolved
  -> Tool
  -> Maybe ToolDescription
  -> TargetVersionRev
  -> DownloadInfo
  -> InstallationSpecResolved
  -> m ()
recordInstallationInfo installDest tool toolDesc TargetVersionRev{..} dlInfo instSpec
  | isSafeDir installDest = do
      spec <- recordedInstallationSpecFile tool _tvrTargetVer
      liftIO $ createDirectoryIfMissing True (takeDirectory spec)
      let metadata = InstallMetadata dlInfo instSpec toolDesc _tvrRev
      logDebug2 $ "Writing install metadata to " <> T.pack spec <> "\n  " <> T.pack (show metadata)
      liftIO $ encodeFilePretty spec metadata
  | otherwise = do
      logDebug2 $ "Skipping spec installation, because installing into isolated dir: " <> T.pack (show installDest)
      pure ()
 where
  encodeFilePretty file json =
    let encoded = encodePretty defConfig json
    in B.writeFile file encoded

sanitizefConfOptions :: MonadFail m => [String] -> m [String]
sanitizefConfOptions args
  | "--prefix" `elem` fmap (takeWhile (/= '=')) args = fail "Don't explicitly set --prefix ...aborting"
  | otherwise = pure args


-- TODO: move to other module
-- | Symlink e.g. @~/.ghcup/ghc/9.6.7/bin/ghc@ to
-- @~/.ghcup/bin/ghc-9.6.7@.
--
-- But we follow the spec from the metadata.
symlinkBinaries ::
  ( HasLog env
  , MonadReader env m
  , HasDirs env   -- createLink needs it on windows
  , MonadIOish m
  )
  => InstallDirResolved                    -- ^ base dir of the tool
  -> [SymlinkSpec [Either Char Version]]   -- ^ symlink spec
  -> InstallDirResolved                    -- ^ binary dir
  -> Tool
  -> TargetVersion
  -> Excepts '[MalformedInstallInfo] m ()
symlinkBinaries (IsolateDirResolved _) _ _ _ _ = pure ()
symlinkBinaries (fromInstallDir -> toolDir) rawSpec bindir tool tver = do
  let spec = substituteSpec <$> rawSpec
  forM_ spec safeSpec
  pvpSyms <- lift $ getPVPSymlinks' (fromInstallDir bindir) spec toolDir
  forM_ pvpSyms $ lift . uncurry createLink
  case bindir of
    IsolateDirResolved d -> linkMajor d
    GHCupDir d           -> linkMajor (fromGHCupPath d)
    GHCupBinDir d        -> whenM (lift isLatest) $ linkMajor d
 where
  safeSpec SymlinkSpec{..} = do
    checkSafePath _slTarget
    checkSafeFilename _slLinkName
    forM_ _slSetName checkSafeFilename

  checkSafePath fp = unless (safePath fp) $ throwE (MalformedInstallInfo "'..' or '.' are not allowed")

  checkSafeFilename fp = unless (safeFilename fp) $ throwE (MalformedInstallInfo "'..' or '.' are not allowed and filepath must have no path separators")

  linkMajor d = do
    let ver = _tvVersion tver
    pvpMajorSyms <- liftE $ getPVPMajorSymlinks' d rawSpec ver toolDir
    forM_ pvpMajorSyms $ lift . uncurry createLink
  isLatest = do
    vers <- getInstalledVersions tool (_tvTarget tver)
    let latestVer = _vrVersion $ maximum vers
    pure $ latestVer == _tvVersion tver