ghcup-hs/lib/GHCup/Download.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}


module GHCup.Download where


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           GHCup.Utils.String.QQ

import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Class      ( lift )
import           Control.Monad.Trans.Resource
                                         hiding ( throwM )
import           Data.Aeson
import           Data.ByteString                ( ByteString )
import           Data.ByteString.Builder
import           Data.IORef
import           Data.Maybe
import           Data.String.Interpolate
import           Data.Versions
import           GHC.IO.Exception
import           HPath
import           HPath.IO
import           Haskus.Utils.Variant.Excepts
import           Network.Http.Client     hiding ( URL )
import           OpenSSL.Digest
import           Optics
import           Prelude                 hiding ( abs
                                                , readFile
                                                , writeFile
                                                )
import           System.IO.Error
import "unix"    System.Posix.IO.ByteString
                                         hiding ( fdWrite )
import "unix-bytestring" System.Posix.IO.ByteString
                                                ( fdWrite )
import           System.Posix.RawFilePath.Directory.Errors
                                                ( hideError )
import           URI.ByteString
import           URI.ByteString.QQ

import qualified Data.ByteString.Lazy          as L
import qualified Data.Text.Encoding            as E
import qualified System.IO.Streams             as Streams
import qualified System.Posix.RawFilePath.Directory
                                               as RD



ghcupURL :: URI
ghcupURL =
  [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]



-- | Downloads the download information!
getDownloads :: ( FromJSONKey Tool
                , FromJSONKey Version
                , FromJSON VersionInfo
                , MonadIO m
                , MonadCatch m
                , MonadReader Settings m
                , MonadLogger m
                )
             => Excepts
                  '[FileDoesNotExistError , URLException , JSONError]
                  m
                  GHCupDownloads
getDownloads = do
  urlSource <- lift getUrlSource
  lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
  case urlSource of
    GHCupURL -> do
      bs <- liftE $ downloadBS ghcupURL
      lE' JSONDecodeError $ eitherDecode' bs
    (OwnSource url) -> do
      bs <- liftE $ downloadBS url
      lE' JSONDecodeError $ eitherDecode' bs
    (OwnSpec av) -> pure $ av



getDownloadInfo :: ( MonadLogger m
                   , MonadCatch m
                   , MonadIO m
                   , MonadReader Settings m
                   )
                => BinaryDownloads
                -> ToolRequest
                -> Maybe PlatformRequest
                -> Excepts
                     '[ DistroNotFound
                      , PlatformResultError
                      , NoCompatibleArch
                      , NoDownload
                      ]
                     m
                     DownloadInfo
getDownloadInfo bDls (ToolRequest t v) mpfReq = do
  (PlatformRequest arch' plat ver) <- case mpfReq of
    Just x  -> pure x
    Nothing -> do
      (PlatformResult rp rv) <- liftE getPlatform
      ar                     <- lE getArchitecture
      pure $ PlatformRequest ar rp rv

  lE $ getDownloadInfo' t v arch' plat ver bDls


getDownloadInfo' :: Tool
                 -> Version
                -- ^ tool version
                 -> Architecture
                -- ^ user arch
                 -> Platform
                -- ^ user platform
                 -> Maybe Versioning
                -- ^ optional version of the platform
                 -> BinaryDownloads
                 -> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
  (Left NoDownload)
  Right
  (with_distro <|> without_distro_ver <|> without_distro)

 where
  with_distro        = distro_preview id id
  without_distro_ver = distro_preview id (const Nothing)
  without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)

  distro_preview f g =
    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls


-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
--   1. try to guess the filename from the url path
--   2. otherwise create a random file
--
-- The file must not exist.
download :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
         => DownloadInfo
         -> Path Abs          -- ^ destination dir
         -> Maybe (Path Rel)  -- ^ optional filename
         -> Excepts '[DigestError , URLException] m (Path Abs)
download dli dest mfn | scheme == [s|https|] = dl True
                      | scheme == [s|http|] = dl False
                      | scheme == [s|file|] = cp
                      | otherwise           = throwE UnsupportedURL

 where
  scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
  cp     = do
    -- destination dir must exist
    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
    destFile <- getDestFile
    fromFile <- parseAbs path
    liftIO $ copyFile fromFile destFile Strict
    pure destFile
  dl https = do
    let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
    lift $ $(logInfo) [i|downloading: #{uri'}|]

    host <-
      preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
        ?? UnsupportedURL
    let port = preview
          (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
          dli

    -- destination dir must exist
    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
    destFile <- getDestFile

    -- download
    fd       <- liftIO $ createRegularFileFd newFilePerms destFile
    let stepper = fdWrite fd
    liftIO $ flip finally (closeFd fd) $ downloadInternal https
                                                          host
                                                          path
                                                          port
                                                          stepper

    -- TODO: verify md5 during download
    liftE $ checkDigest dli destFile
    pure destFile

  -- Manage to find a file we can write the body into.
  getDestFile :: MonadThrow m => m (Path Abs)
  getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn

  path        = view (dlUri % pathL') dli


-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadResource m
                  , MonadThrow m
                  , MonadLogger m
                  , MonadIO m
                  , MonadReader Settings m
                  )
               => DownloadInfo
               -> Maybe (Path Rel)  -- ^ optional filename
               -> Excepts '[DigestError , URLException] m (Path Abs)
downloadCached dli mfn = do
  cache <- lift getCache
  case cache of
    True -> do
      cachedir <- liftIO $ ghcupCacheDir
      fn       <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
      let cachfile = cachedir </> fn
      fileExists <- liftIO $ doesFileExist cachfile
      if
        | fileExists -> do
          liftE $ checkDigest dli cachfile
          pure $ cachfile
        | otherwise -> liftE $ download dli cachedir mfn
    False -> do
      tmp <- lift withGHCupTmpDir
      liftE $ download dli tmp mfn


-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
           => URI
           -> Excepts
                '[FileDoesNotExistError , URLException]
                m
                L.ByteString
downloadBS uri'
  | scheme == [s|https|]
  = dl True
  | scheme == [s|http|]
  = dl False
  | scheme == [s|file|]
  = liftException doesNotExistErrorType (FileDoesNotExistError path)
    $ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
  | otherwise
  = throwE UnsupportedURL

 where
  scheme = view (uriSchemeL' % schemeBSL') uri'
  path   = view pathL' uri'
  dl https = do
    host <-
      preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
        ?? UnsupportedURL
    let port = preview
          (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
          uri'
    liftIO $ downloadBS' https host path port


-- | Load the result of this download into memory at once.
downloadBS' :: Bool             -- ^ https?
            -> ByteString       -- ^ host (e.g. "www.example.com")
            -> ByteString       -- ^ path (e.g. "/my/file")
            -> Maybe Int        -- ^ optional port (e.g. 3000)
            -> IO (L.ByteString)
downloadBS' https host path port = do
  bref <- newIORef (mempty :: Builder)
  let stepper bs = modifyIORef bref (<> byteString bs)
  downloadInternal https host path port stepper
  readIORef bref <&> toLazyByteString


downloadInternal :: Bool
                 -> ByteString
                 -> ByteString
                 -> Maybe Int
                 -> (ByteString -> IO a)        -- ^ the consuming step function
                 -> IO ()
downloadInternal https host path port consumer = do
  c <- case https of
    True -> do
      ctx <- baselineContextSSL
      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
    False -> openConnection host (fromIntegral $ fromMaybe 80 port)

  let q = buildRequest1 $ http GET path

  sendRequest c q emptyBody

  receiveResponse
    c
    (\_ i' -> do
      outStream <- Streams.makeOutputStream
        (\case
          Just bs -> void $ consumer bs
          Nothing -> pure ()
        )
      Streams.connect i' outStream
    )

  closeConnection c


checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
            => DownloadInfo
            -> Path Abs
            -> Excepts '[DigestError] m ()
checkDigest dli file = do
  verify <- lift ask <&> (not . noVerify)
  when verify $ do
    let p' = toFilePath file
    lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
    c <- liftIO $ readFile file
    let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
        eDigest = view dlHash dli
    when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)