ghcup-hs/lib/GHCup.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeApplications      #-}

-- TODO: handle SIGTERM, SIGUSR
module GHCup where


import           GHCup.Download
import           GHCup.Errors
import           GHCup.Platform
import           GHCup.Types
import           GHCup.Types.JSON               ( )
import           GHCup.Types.Optics
import           GHCup.Utils
import           GHCup.Utils.File
import           GHCup.Utils.Prelude

import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.Fail             ( MonadFail )
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Class      ( lift )
import           Control.Monad.Trans.Resource
                                         hiding ( throwM )
import           Data.ByteString                ( ByteString )
import           Data.Foldable
import           Data.List
import           Data.Maybe
import           Data.String.Interpolate
import           Data.String.QQ
import           Data.Versions
import           Data.Word8
import           GHC.IO.Exception
import           HPath
import           HPath.IO
import           Haskus.Utils.Variant.Excepts
import           Optics
import           Prelude                 hiding ( abs
                                                , readFile
                                                , writeFile
                                                )
import           System.IO.Error
import           System.Posix.Env.ByteString    ( getEnvironment )
import           System.Posix.FilePath          ( getSearchPath )
import           System.Posix.RawFilePath.Directory.Errors
                                                ( hideError )

import qualified Data.ByteString               as B
import qualified Data.Map.Strict               as Map
import qualified Data.Text.Encoding            as E



    -------------------------
    --[ Tool installation ]--
    -------------------------

-- TODO: custom logger intepreter and pretty printing

-- | Install a tool, such as GHC or cabal. This also sets
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
installTool :: ( MonadThrow m
               , MonadReader Settings m
               , MonadLogger m
               , MonadCatch m
               , MonadIO m
               , MonadFail m
               , MonadResource m
               ) -- tmp file
            => BinaryDownloads
            -> ToolRequest
            -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
            -> Excepts
                 '[ AlreadyInstalled
                  , ArchiveError
                  , DistroNotFound
                  , FileDoesNotExistError
                  , FileError
                  , JSONError
                  , NoCompatibleArch
                  , NoDownload
                  , NotInstalled
                  , PlatformResultError
                  , ProcessError
                  , URLException
                  , DigestError
                  ]
                 m
                 ()
installTool bDls treq mpfReq = do
  lift $ $(logDebug) [i|Requested to install: #{treq}|]
  alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
  when alreadyInstalled $ (throwE $ AlreadyInstalled treq)

  Settings {..} <- lift ask

  -- download (or use cached version)
  dlinfo        <- liftE $ getDownloadInfo bDls treq mpfReq
  dl            <- liftE $ downloadCached dlinfo Nothing

  -- unpack
  tmpUnpack     <- lift withGHCupTmpDir
  liftE $ unpackToDir tmpUnpack dl

  -- prepare paths
  ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
  bindir <- liftIO ghcupBinDir

  -- the subdir of the archive where we do the work
  let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)

  case treq of
    (ToolRequest GHC ver) -> do
      liftE $ installGHC archiveSubdir ghcdir
      liftE $ postGHCInstall ver
    (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
  pure ()


toolAlreadyInstalled :: ToolRequest -> IO Bool
toolAlreadyInstalled ToolRequest {..} = case _trTool of
  GHC   -> ghcInstalled _trVersion
  Cabal -> cabalInstalled _trVersion



-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC :: (MonadLogger m, MonadIO m)
           => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
           -> Path Abs      -- ^ Path to install to
           -> Excepts '[ProcessError] m ()
installGHC path inst = do
  lift $ $(logInfo) [s|Installing GHC|]
  lEM $ liftIO $ exec [s|./configure|]
                      False
                      [[s|--prefix=|] <> toFilePath inst]
                      (Just path)
                      Nothing
  lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
  pure ()


-- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Path Abs      -- ^ Path to the unpacked cabal bindist (where the executable resides)
             -> Path Abs      -- ^ Path to install to
             -> Excepts '[FileError] m ()
installCabal path inst = do
  lift $ $(logInfo) [s|Installing cabal|]
  let cabalFile = [rel|cabal|] :: Path Rel
  liftIO $ createDirIfMissing newDirPerms inst
  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
    (path </> cabalFile)
    (inst </> cabalFile)
    Overwrite



    ---------------
    --[ Set GHC ]--
    ---------------



-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
--   * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
--   * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
--   * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
       => Version
       -> SetGHC
       -> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
  let verBS = verToBS ver
  ghcdir <- liftIO $ ghcupGHCDir ver

  -- symlink destination
  bindir <- liftIO $ ghcupBinDir
  liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir

  when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)

  -- for ghc tools (ghc, ghci, haddock, ...)
  verfiles <- ghcToolFiles ver
  forM_ verfiles $ \file -> do
    liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
    targetFile <- case sghc of
      SetGHCOnly  -> pure file
      SetGHCMajor -> do
        major' <-
          (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
            <$> getGHCMajor ver
        parseRel (toFilePath file <> B.singleton _hyphen <> major')
      SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
    liftIO $ hideError doesNotExistErrorType $ deleteFile
      (bindir </> targetFile)
    liftIO $ createSymlink (bindir </> targetFile)
                           (ghcLinkDestination (toFilePath file) ver)

  -- create symlink for share dir
  liftIO $ symlinkShareDir ghcdir verBS

  pure ()

 where

  symlinkShareDir :: Path Abs -> ByteString -> IO ()
  symlinkShareDir ghcdir verBS = do
    destdir <- ghcupBaseDir
    case sghc of
      SetGHCOnly -> do
        let sharedir     = [rel|share|] :: Path Rel
        let fullsharedir = ghcdir </> sharedir
        whenM (doesDirectoryExist fullsharedir) $ do
          liftIO $ hideError doesNotExistErrorType $ deleteFile
            (destdir </> sharedir)
          createSymlink
            (destdir </> sharedir)
            ([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
      _ -> pure ()

  -- The old tool symlinks might be different (e.g. more) than the
  -- requested version. Have to avoid "stray" symlinks.
  delOldSymlinks :: forall m
                  . (MonadThrow m, MonadFail m, MonadIO m)
                 => Path Abs
                 -> Excepts '[] m ()
  delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
    mv <- ghcSet
    for_ mv $ \ver' -> do
      verfiles <- ghcToolFiles ver'
      for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)




    ------------------
    --[ List tools ]--
    ------------------


data ListCriteria = ListInstalled
                  | ListSet
                  deriving Show

data ListResult = ListResult
  { lTool      :: Tool
  , lVer       :: Version
  , lTag       :: [Tag]
  , lInstalled :: Bool
  , lSet       :: Bool
  }
  deriving Show


availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf
  (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
  av


listVersions :: BinaryDownloads
             -> Maybe Tool
             -> Maybe ListCriteria
             -> IO [ListResult]
listVersions av lt criteria = case lt of
  Just t -> do
    filter' <$> forM (availableToolVersions av t) (toListResult t)
  Nothing -> do
    ghcvers   <- listVersions av (Just GHC) criteria
    cabalvers <- listVersions av (Just Cabal) criteria
    pure (ghcvers <> cabalvers)

 where
  toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
  toListResult t (v, tags) = case t of
    GHC -> do
      lSet       <- fmap (maybe False (== v)) $ ghcSet
      lInstalled <- ghcInstalled v
      pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
    Cabal -> do
      lSet       <- fmap (== v) $ cabalSet
      lInstalled <- cabalInstalled v
      pure ListResult { lVer = v, lTag = tags, lTool = t, .. }

  filter' :: [ListResult] -> [ListResult]
  filter' lr = case criteria of
    Nothing            -> lr
    Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
    Just ListSet       -> filter (\ListResult {..} -> lSet) lr





    --------------
    --[ GHC rm ]--
    --------------


-- | This function may throw and crash in various ways.
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
         => Version
         -> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
  isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
  dir      <- liftIO $ ghcupGHCDir ver
  let d' = toFilePath dir
  exists     <- liftIO $ doesDirectoryExist dir

  toolsFiles <- liftE $ ghcToolFiles ver

  if exists
    then do
      -- this isn't atomic, order matters
      lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
      liftIO $ deleteDirRecursive dir

      lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
      liftIO $ rmMinorSymlinks

      lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
      liftE fixMajorSymlinks

      when isSetGHC $ liftE $ do
        lift $ $(logInfo) [i|Removing ghc symlinks|]
        rmPlain toolsFiles

      liftIO
        $   ghcupBaseDir
        >>= hideError doesNotExistErrorType
        .   deleteFile
        .   (</> ([rel|share|] :: Path Rel))
    else throwE (NotInstalled $ ToolRequest GHC ver)

 where
  -- e.g. ghc-8.6.5
  rmMinorSymlinks :: IO ()
  rmMinorSymlinks = do
    bindir <- ghcupBinDir
    files  <- getDirsFiles' bindir
    let myfiles = filter
          (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
          files
    forM_ myfiles $ \f -> deleteFile (bindir </> f)

  -- E.g. ghc, if this version is the set one.
  -- This reads `ghcupGHCDir`.
  rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
          => [Path Rel] -- ^ tools files
          -> Excepts '[NotInstalled] m ()
  rmPlain files = do
    bindir <- liftIO $ ghcupBinDir
    forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)

  -- e.g. ghc-8.6
  fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
                   => Excepts '[NotInstalled] m ()
  fixMajorSymlinks = do
    (mj, mi) <- getGHCMajor ver
    let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi

    bindir <- liftIO $ ghcupBinDir

    -- first delete them
    files  <- liftIO $ getDirsFiles' bindir
    let myfiles =
          filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
    forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)

    -- then fix them (e.g. with an earlier version)
    getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)



    ------------------
    --[ Debug info ]--
    ------------------


getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
             => Excepts
                  '[PlatformResultError , NoCompatibleArch , DistroNotFound]
                  m
                  DebugInfo
getDebugInfo = do
  diBaseDir   <- liftIO $ ghcupBaseDir
  diBinDir    <- liftIO $ ghcupBinDir
  diGHCDir    <- liftIO $ ghcupGHCBaseDir
  diCacheDir  <- liftIO $ ghcupCacheDir
  diURLSource <- lift $ getUrlSource
  diArch      <- lE getArchitecture
  diPlatform  <- liftE $ getPlatform
  pure $ DebugInfo { .. }



    ---------------
    --[ Compile ]--
    ---------------


-- TODO: build config
compileGHC :: ( MonadReader Settings m
              , MonadThrow m
              , MonadResource m
              , MonadLogger m
              , MonadIO m
              , MonadFail m
              )
           => SourceDownloads
           -> Version          -- ^ version to install
           -> Version          -- ^ version to bootstrap with
           -> Maybe Int        -- ^ jobs
           -> Maybe (Path Abs) -- ^ build config
           -> Excepts
                '[ AlreadyInstalled
                 , NotInstalled
                 , GHCNotFound
                 , ArchiveError
                 , ProcessError
                 , URLException
                 , DigestError
                 , BuildConfigNotFound
                 ]
                m
                ()
compileGHC dls tver bver jobs mbuildConfig = do
  let treq = ToolRequest GHC tver
  lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
  alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
  when alreadyInstalled $ (throwE $ AlreadyInstalled treq)

  -- download source tarball
  dlInfo    <- preview (ix tver) dls ?? GHCNotFound
  dl        <- liftE $ downloadCached dlInfo Nothing

  -- unpack
  tmpUnpack <- lift mkGhcupTmpDir
  liftE $ unpackToDir tmpUnpack dl

  bghc <- parseRel ([s|ghc-|] <> verToBS bver)
  let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack

  ghcdir <- liftIO $ ghcupGHCDir tver
  if
    | tver >= [vver|8.8.0|] -> do
      cEnv     <- liftIO $ getEnvironment
      spaths   <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
      bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
      let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
      lEM $ liftIO $ exec [s|./configure|]
                          False
                          [[s|--prefix=|] <> toFilePath ghcdir]
                          (Just workdir)
                          (Just newEnv)
    | otherwise -> do
      lEM $ liftIO $ exec
        [s|./configure|]
        False
        [ [s|--prefix=|] <> toFilePath ghcdir
        , [s|--with-ghc=|] <> toFilePath bghc
        ]
        (Just workdir)
        Nothing

  let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
  case mbuildConfig of
    Just bc -> liftIO $ copyFile bc build_mk Overwrite
    Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf

  lEM $ liftIO $ exec [s|make|]
                      True
                      (maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
                      (Just workdir)
                      Nothing

  lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing

  liftE $ postGHCInstall tver
  pure ()

 where
  defaultConf = [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES
GhcWithLlvmCodeGen = YES|]




    -------------
    --[ Other ]--
    -------------


-- | Creates ghc-x.y.z and ghc-x.y symlinks.
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
               => Version
               -> Excepts '[NotInstalled] m ()
postGHCInstall ver = do
  liftE $ setGHC ver SetGHCMinor

  -- Create ghc-x.y symlinks. This may not be the current
  -- version, create it regardless.
  (mj, mi) <- liftIO $ getGHCMajor ver
  getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)