Prefetch.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}

module GHCup.OptParse.Prefetch where


import           GHCup.Command.Prefetch
import           GHCup.Errors
import           GHCup.Types
import           GHCup.Input.Parsers (resolveVersion, toolParser)
import           GHCup.Types.Optics
import           GHCup.Prelude.File
import           GHCup.Prelude.Logger
import           GHCup.Prelude.String.QQ
import           GHCup.OptParse.Common

#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             ( MonadFail )
#endif
import           Control.Monad (forM_)
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.Functor
import           Data.Maybe
import           Data.Variant.Excepts
import           Options.Applicative     hiding ( style, ParseError )
import           Prelude                 hiding ( appendFile )
import           System.Exit

import qualified Data.Text                     as T
import Control.Exception.Safe (MonadMask)
import GHCup.Download (getDownloadsF)




    ----------------
    --[ Commands ]--
    ----------------


data PrefetchCommand = PrefetchGHC PrefetchGHCOptions (Maybe ToolVersion)
                     | PrefetchCabal PrefetchOptions (Maybe ToolVersion)
                     | PrefetchHLS PrefetchOptions (Maybe ToolVersion)
                     | PrefetchStack PrefetchOptions (Maybe ToolVersion)
                     | PrefetchTool PrefetchOptions (Maybe ToolVersion) Tool
                     | PrefetchMetadata





    ---------------
    --[ Options ]--
    ---------------


data PrefetchOptions = PrefetchOptions {
    pfSrc :: Bool
  , pfCacheDir :: Maybe FilePath
}

data PrefetchGHCOptions = PrefetchGHCOptions {
    pfGHCSrc :: Bool
  , pfGHCCacheDir :: Maybe FilePath
}



    ---------------
    --[ Parsers ]--
    ---------------


prefetchP :: Parser PrefetchCommand
prefetchP = subparser
  (  command
      "ghc"
      (info
        (PrefetchGHC
          <$> (PrefetchGHCOptions
                <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
                <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))
          <*>  optional (toolVersionTagArgument [] (Just ghc)) )
        ( progDesc "Download GHC assets for installation")
      )
      <>
     command
      "cabal"
      (info
        (PrefetchCabal
           <$> (PrefetchOptions
                 <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
                 <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))
               )
          <*> ( optional (toolVersionTagArgument [] (Just cabal)) <**> helper ))
        ( progDesc "Download cabal assets for installation")
      )
      <>
     command
      "hls"
      (info
        (PrefetchHLS
           <$> (PrefetchOptions
                 <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
                 <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))
               )
          <*> ( optional (toolVersionTagArgument [] (Just hls)) <**> helper ))
        ( progDesc "Download HLS assets for installation")
      )
      <>
     command
      "stack"
      (info
        (PrefetchStack
           <$> (PrefetchOptions
                 <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
                 <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))
               )
          <*> ( optional (toolVersionTagArgument [] (Just stack)) <**> helper ))
        ( progDesc "Download stack assets for installation")
      )
      <>
     command
      "metadata"
      (PrefetchMetadata <$ info
        helper
        ( progDesc "Download ghcup's metadata, needed for various operations")
      )
  ) <|>
  ( (\o t v -> PrefetchTool o v t)
    <$> (PrefetchOptions
          <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
          <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory")))
        )
    <*> argument (eitherReader toolParser) (metavar "TOOL" <> help "Which tool to prefetch")
    <*> optional (toolVersionTagArgument [] Nothing)
  )



    --------------
    --[ Footer ]--
    --------------


prefetchFooter :: String
prefetchFooter = [s|Discussion:
  Prefetches tools or assets into "~/.ghcup/cache" directory. This can
  be then combined later with '--offline' flag, ensuring all assets that
  are required for offline use have been prefetched.

Examples:
  ghcup prefetch metadata
  ghcup prefetch ghc 8.10.5
  ghcup --offline install ghc 8.10.5|]



    ---------------------------
    --[ Effect interpreters ]--
    ---------------------------


type PrefetchEffects = '[ TagNotFound
                        , DayNotFound
                        , NextVerNotFound
                        , NoToolVersionSet
                        , NoDownload
                        , DigestError
                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , JSONError
                        , FileDoesNotExistError
                        , StackPlatformDetectError
                        , UnsupportedMetadataFormat
                        , URIParseError
                        , ParseError
                        ]



    ------------------
    --[ Entrypoint ]--
    ------------------



prefetch :: ( Monad m
            , MonadMask m
            , MonadUnliftIO m
            , MonadFail m
            )
         => PrefetchCommand
         -> Settings
         -> (IO (AppState, IO ()), LeanAppState)
         -> m ExitCode
prefetch prefetchCommand settings (getAppState', leanAppstate) =
  run (do
    case prefetchCommand of
      PrefetchGHC
        (PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do
          forM_ pfCacheDir (liftIO . createDirRecursive')
          v <- liftE $ resolveVersion mt guessMode ghc
          if pfGHCSrc
          then liftE $ fetchToolSrc ghc v pfCacheDir
          else liftE $ fetchToolBindist v ghc pfCacheDir
      PrefetchCabal PrefetchOptions {pfSrc, pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        v <- liftE $ resolveVersion mt guessMode cabal
        if pfSrc
        then liftE $ fetchToolSrc cabal v pfCacheDir
        else liftE $ fetchToolBindist v cabal pfCacheDir
      PrefetchHLS PrefetchOptions {pfSrc, pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        v <- liftE $ resolveVersion mt guessMode hls
        if pfSrc
        then liftE $ fetchToolSrc hls v pfCacheDir
        else liftE $ fetchToolBindist v hls pfCacheDir
      PrefetchStack PrefetchOptions {pfSrc, pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        v <- liftE $ resolveVersion mt guessMode stack
        if pfSrc
        then liftE $ fetchToolSrc stack v pfCacheDir
        else liftE $ fetchToolBindist v stack pfCacheDir
      PrefetchTool PrefetchOptions {pfCacheDir} mt tool -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        v <- liftE $ resolveVersion mt guessMode tool
        liftE $ fetchToolBindist v tool pfCacheDir
      PrefetchMetadata -> do
        pfreq <- lift getPlatformReq
        _ <- liftE $ getDownloadsF pfreq
        pure ""
       ) >>= \case
                (VRight _, up) -> do
                  liftIO up
                  pure ExitSuccess
                (VLeft e, _) -> do
                  runLogger $ logError $ T.pack $ prettyHFError e
                  pure $ ExitFailure 15

 where
  guessMode = if guessVersion settings then GLaxWithInstalled else GStrict

  run action' = do
    (appstate', up) <- liftIO getAppState'
    r <- flip runReaderT appstate'
                  . runResourceT
                  . runE
                    @PrefetchEffects
                  $ action'
    pure (r, up)
  runLogger = flip runReaderT leanAppstate