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           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.String.QQ
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           System.Posix.Types
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
                      , FileDoesNotExistError
                      , JSONError
                      , NoCompatibleArch
                      , NoDownload
                      , PlatformResultError
                      , URLException
                      ]
                     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


-- | Same as `download'`, except uses URL type. As such, this might
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
download :: (MonadLogger m, MonadIO m)
         => DownloadInfo
         -> Path Abs          -- ^ destination dir
         -> Maybe (Path Rel)  -- ^ optional filename
         -> Excepts '[DigestError , URLException] m (Path Abs)
download dli dest mfn
  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
  | otherwise = throwE UnsupportedURL

 where
  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 path = view (dlUri % pathL') dli
    let port = preview
          (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
          dli
    p <- liftIO $ download' https host path port dest mfn
    -- TODO: verify md5 during download
    let p' = toFilePath p
    lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
    c <- liftIO $ readFile p
    let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
        eDigest = view dlHash dli
    when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
    pure p


-- | Download 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
          let cachfile' = toFilePath cachfile
          lift $ $(logInfo) [i|veryfing digest of: #{cachfile'}|]
          c <- liftIO $ readFile cachfile
          let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
              eDigest = view dlHash dli
          when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
          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


-- | 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' :: Bool             -- ^ https?
          -> ByteString       -- ^ host (e.g. "www.example.com")
          -> ByteString       -- ^ path (e.g. "/my/file")
          -> Maybe Int        -- ^ optional port (e.g. 3000)
          -> Path Abs         -- ^ destination directory to download into
          -> Maybe (Path Rel) -- ^ optionally provided filename
          -> IO (Path Abs)
download' https host path port dest mfn = do
  (fd, fp) <- getFile
  let stepper = fdWrite fd
  flip finally (closeFd fd) $ downloadInternal https host path port stepper
  pure fp
 where
  -- Manage to find a file we can write the body into.
  getFile :: IO (Fd, Path Abs)
  getFile = do
    -- destination dir must exist
    hideError AlreadyExists $ createDirRecursive newDirPerms dest
    case mfn of
      -- if a filename was provided, try that
      Just x ->
        let fp = dest </> x
        in  fmap (, fp) $ createRegularFileFd newFilePerms fp
      Nothing -> do
        -- ...otherwise try to infer the filename from the URL path
        fn' <- urlBaseName path
        let fp = dest </> fn'
        fmap (, fp) $ createRegularFileFd newFilePerms fp


-- | 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