path: root/src/SlackBuilder/Update.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

module SlackBuilder.Update
    ( checkUpdateAvailability
    , cloneFromGit
    , downloadWithTemplate
    , getAndLogLatest
    , handleExceptions
    , listRepository
    , repackageWithTemplate
    , reuploadWithTemplate
    , updatePackageIfRequired
    ) where

import Control.Exception (Exception(..), SomeException(..))
import Control.Monad.Catch (MonadCatch(..), catches, Handler(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Reader (asks)
import qualified Data.ByteString.Char8 as Char8
import Data.Foldable (Foldable(..), find)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromJust, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import GHC.Records (HasField(..))
import qualified Network.HTTP.Req as Req
import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..), responseStatus)
import System.FilePath
    ( (</>)
    , (<.>)
    , dropExtension
    , takeBaseName
    , splitFileName
    , takeDirectory
    , takeFileName
    , dropTrailingPathSeparator
    )
import System.Process
    ( CmdSpec(..)
    , CreateProcess(..)
    , StdStream(..)
    , withCreateProcess
    , waitForProcess
    )
import SlackBuilder.Config
import SlackBuilder.Download
import SlackBuilder.Info
import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..))
import qualified SlackBuilder.Package as Package
import SlackBuilder.Trans
import Text.URI (URI(..))
import qualified Text.URI as URI
import System.Directory
    ( listDirectory
    , doesDirectoryExist
    , withCurrentDirectory
    , removeDirectoryRecursive
    )
import System.Console.ANSI
    ( setSGR
    , SGR(..)
    , ColorIntensity(..)
    , Color(..)
    , ConsoleLayer(..)
    )
import Control.Monad (filterM, void)
import Data.List (isPrefixOf, isSuffixOf, partition)
import Data.Functor ((<&>))
import Data.Bifunctor (Bifunctor(..))
import Network.HTTP.Types (Status(..))

getAndLogLatest :: PackageDescription -> SlackBuilderT (Maybe PackageUpdateData)
getAndLogLatest description = do
    let PackageDescription{ latest = Package.Updater{ detectLatest }, name } = description
    liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
    detectedVersion <- detectLatest
    category <- HashMap.lookup name <$> listRepository
    pure $ PackageUpdateData description
        <$> category
        <*> detectedVersion

checkUpdateAvailability :: PackageUpdateData -> SlackBuilderT (Maybe PackageInfo)
checkUpdateAvailability PackageUpdateData{..} = do
    parsedInfoFile <- readInfoFile category $ getField @"name" description

    if version == getField @"version" parsedInfoFile
    then liftIO $ do
        setSGR [SetColor Foreground Dull Green]
        Text.IO.putStrLn
            $ getField @"name" description <> " is up to date (Version " <> version <> ")."
        setSGR [Reset]
        pure Nothing
    else liftIO $ do
        setSGR [SetColor Foreground Dull Yellow]
        Text.IO.putStr
            $ "A new version of "
            <> getField @"name" description
            <> " " <> getField @"version" parsedInfoFile
            <> " is available (" <> version <> ")."
        setSGR [Reset]
        putStrLn ""
        pure $ Just parsedInfoFile

updatePackageIfRequired :: PackageUpdateData -> SlackBuilderT ()
updatePackageIfRequired updateData
    = checkUpdateAvailability updateData
    >>= mapM_ (updatePackage updateData)

data DownloadUpdated = DownloadUpdated
    { result :: Package.Download
    , version :: Text
    , is64 :: Bool
    } deriving (Eq, Show)

updateDownload :: Text -> Package.Updater -> SlackBuilderT DownloadUpdated
updateDownload packagePath Package.Updater{..} = do
    latestDownloadVersion <- fromJust <$> detectLatest
    result <- getVersion packagePath latestDownloadVersion
    pure $ DownloadUpdated
        { result = result
        , version = latestDownloadVersion
        , is64 = is64
        }

cloneFromGit :: URI -> Text -> Text -> Text -> SlackBuilderT Package.Download
cloneFromGit repo tagPrefix packagePath version = do
    let downloadFileName = URI.unRText
            $ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo
        relativeTarball = Text.unpack packagePath
            </> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version)
    (uri', checksum) <- cloneAndUpload (URI.render repo) relativeTarball tagPrefix
    pure $ Package.Download
        { md5sum = checksum
        , download = uri'
        }

repackageWithTemplate :: Maybe [String] -> Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
repackageWithTemplate Nothing template' = downloadWithTemplate template'
repackageWithTemplate (Just (cmd : arguments)) template' =
    reuploadWithTemplate' template' (RawCommand cmd arguments)
repackageWithTemplate (Just []) template' = reuploadWithTemplate template'

downloadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
downloadWithTemplate downloadTemplate packagePath version = do
    repository' <- SlackBuilderT $ asks repository
    uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
    checksum <- download uri' $ repository' </> Text.unpack packagePath
    pure $ Package.Download uri' $ snd checksum

reuploadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
reuploadWithTemplate downloadTemplate packagePath version = do
    repository' <- SlackBuilderT $ asks repository
    uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
    let packagePathRelativeToCurrent = repository' </> Text.unpack packagePath
    (downloadedFileName, checksum) <- download uri' packagePathRelativeToCurrent

    download' <- handleReupload packagePath
        $ packagePathRelativeToCurrent </> downloadedFileName
    pure $ Package.Download download' checksum

reuploadWithTemplate' :: Package.DownloadTemplate -> CmdSpec -> Text -> Text -> SlackBuilderT Package.Download
reuploadWithTemplate' downloadTemplate commands packagePath version = do
    repository' <- SlackBuilderT $ asks repository
    uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
    let downloadFileName = Text.unpack
            $ URI.unRText
            $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
        packagePathRelativeToCurrent = repository' </> Text.unpack packagePath

    changedArchiveRootName <- extractRemote uri' packagePathRelativeToCurrent
    let relativeTarball = packagePathRelativeToCurrent
            </> fromMaybe downloadFileName changedArchiveRootName
    (relativeTarball', checksum) <- prepareSource relativeTarball

    download' <- handleReupload packagePath relativeTarball'
    pure $ Package.Download download' checksum
  where
    prepareSource tarballPath =
        liftIO (defaultCreateProcess tarballPath commands)
            >> liftIO (tarCompress tarballPath)
            <* liftIO (removeDirectoryRecursive tarballPath)
    tarCompress tarballPath =
        let archiveBaseFilename = takeFileName tarballPath
            appendTarExtension = (<.> "tar.xz")
         in fmap (appendTarExtension tarballPath,)
            $ withCurrentDirectory (takeDirectory tarballPath)
            $ createLzmaTarball archiveBaseFilename (appendTarExtension archiveBaseFilename)
    defaultCreateProcess cwd' cmdSpec
        = flip withCreateProcess (const . const . const waitForProcess)
        $ CreateProcess
            { use_process_jobs = False
            , std_out = Inherit
            , std_in = NoStream
            , std_err = Inherit
            , new_session = False
            , env = Nothing
            , detach_console = False
            , delegate_ctlc = False
            , cwd = Just cwd'
            , create_new_console = False
            , create_group = False
            , cmdspec = cmdSpec
            , close_fds = True
            , child_user = Nothing
            , child_group = Nothing
            }

handleReupload :: Text -> String -> SlackBuilderT URI
handleReupload packagePath relativeTarball = do
    liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball
    uploadSource relativeTarball category'

    hostedSources $ NonEmpty.cons category'
        $ pure $ Text.pack $ takeFileName relativeTarball
  where
    category' = Text.pack $ takeBaseName $ Text.unpack packagePath

updatePackage :: PackageUpdateData -> PackageInfo -> SlackBuilderT ()
updatePackage PackageUpdateData{..} info = do
    let packagePath = category <> "/" <> getField @"name" description
        latest' = getField @"latest" description

    repository' <- SlackBuilderT $ asks repository
    mainDownload <- (, getField @"is64" latest')
        <$> getField @"getVersion" latest' packagePath version
    moreDownloads <- traverse (updateDownload packagePath)
        $ getField @"downloaders" description
    let (downloads64, allDownloads) = partition snd
            $ mainDownload
            : (liftA2 (,) (getField @"result") (getField @"is64") <$> toList moreDownloads)
    let infoFilePath = repository' </> Text.unpack packagePath
            </> (Text.unpack (getField @"name" description) <.> "info")
        package' = info
            { version = version
            , downloads = getField @"download" . fst <$> allDownloads
            , checksums = getField @"md5sum" . fst <$> allDownloads
            , downloadX64 = getField @"download" . fst <$> downloads64
            , checksumX64 = getField @"md5sum" . fst <$> downloads64
            }
    liftIO $ Text.IO.writeFile infoFilePath $ generate package'
    updateSlackBuildVersion packagePath version
        $ getField @"version" <$> moreDownloads

    commit packagePath version

listRepository :: SlackBuilderT (HashMap Text Text)
listRepository = do
    repository' <- SlackBuilderT $ asks repository
    listing <- go repository' [] ""
    pure $ HashMap.fromList $ bimap Text.pack Text.pack <$> listing
  where
    go currentDirectory found accumulatedDirectory = do
        let fullDirectory = currentDirectory </> accumulatedDirectory
        contents <- liftIO $ listDirectory fullDirectory
        case find (isSuffixOf ".info") contents of
            Just _ ->
                let (category, packageName) = first dropTrailingPathSeparator
                        $ splitFileName accumulatedDirectory
                 in pure $ (packageName, category) : found
            Nothing ->
                let accumulatedDirectories = (accumulatedDirectory </>)
                        <$> filter (not . isPrefixOf ".") contents
                    directoryFilter = liftIO . doesDirectoryExist
                        . (currentDirectory </>)
                 in filterM directoryFilter accumulatedDirectories
                    >>= traverse (go currentDirectory found) <&> concat

handleExceptions :: (MonadIO m, MonadCatch m) => forall a. m a -> m ()
handleExceptions action = catches (void action)
    [ Handler handleHttp
    , Handler handleSome
    ]
  where
    printException e
        = liftIO (setSGR [SetColor Foreground Dull Red])
        >> liftIO (putStrLn e)
        >> liftIO (setSGR [Reset])
    showStatus (Status code message) =
        Char8.pack (show code) <> " \"" <> message <> "\""
    showHttpExceptionContent (StatusCodeException response _) = Char8.unpack
        $ "The server returned "
        <> showStatus (responseStatus response)
        <> " response status code."
    showHttpExceptionContent (TooManyRedirects _) =
        "The server responded with too many redirects for a request."
    showHttpExceptionContent OverlongHeaders = "Too many total bytes in the HTTP header were returned by the server."
    showHttpExceptionContent TooManyHeaderFields = "Too many HTTP header fields were returned by the server."
    showHttpExceptionContent ResponseTimeout = "The server took too long to return a response."
    showHttpExceptionContent ConnectionTimeout = "Attempting to connect to the server timed out"
    showHttpExceptionContent (ConnectionFailure connectionException) = displayException connectionException
    showHttpExceptionContent (InvalidStatusLine statusLine) = Char8.unpack
        $ "The status line returned by the server could not be parsed: "
        <> statusLine <> "."
    showHttpExceptionContent (InvalidHeader headerLine) = Char8.unpack 
        $ "The given response header line could not be parsed: "
        <> headerLine <> "."
    showHttpExceptionContent (InvalidRequestHeader headerLine) = Char8.unpack
        $ "The given request header is not compliant: "
        <> headerLine <> "."
    showHttpExceptionContent (InternalException interalException) = displayException interalException
    showHttpExceptionContent (ProxyConnectException _ _ status) = Char8.unpack
        $ showStatus status
        <> " status code was returned when trying to connect to the proxy server on the given host and port."
    showHttpExceptionContent NoResponseDataReceived = "No response data was received from the server at all."
    showHttpExceptionContent TlsNotSupported = "This HTTP client does not have support for secure connections."
    showHttpExceptionContent (WrongRequestBodyStreamSize _ _)
        = "The request body provided did not match the expected size."
    showHttpExceptionContent (ResponseBodyTooShort _ _) =
        "The returned response body is too short. Provides the expected size and actual size."
    showHttpExceptionContent InvalidChunkHeaders = "A chunked response body had invalid headers."
    showHttpExceptionContent IncompleteHeaders = "An incomplete set of response headers were returned."
    showHttpExceptionContent (InvalidDestinationHost hostLine) = Char8.unpack
        $ "The host we tried to connect to is invalid"
        <> hostLine <> "."
    showHttpExceptionContent (HttpZlibException zlibException) = displayException zlibException
    showHttpExceptionContent (InvalidProxyEnvironmentVariable environmentName environmentValue) = Text.unpack
        $ "Values in the proxy environment variable were invalid: "
        <> environmentName <> "=\"" <> environmentValue <> "\"."
    showHttpExceptionContent ConnectionClosed = "Attempted to use a Connection which was already closed"
    showHttpExceptionContent (InvalidProxySettings _) = "Proxy settings are not valid."
    handleHttp :: (MonadIO m, MonadCatch m) => Req.HttpException -> m ()
    handleHttp (Req.VanillaHttpException e)
        | HttpExceptionRequest _ exceptionContent <- e = printException
            $ showHttpExceptionContent exceptionContent
        | InvalidUrlException url reason <- e = printException $ url <> ": " <> reason
    handleHttp (Req.JsonHttpException e) = printException e
    handleSome :: (MonadIO m, MonadCatch m) => SomeException -> m ()
    handleSome = printException . show