slackbuilder/src/Main.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 Main
    ( main
    ) where

import Control.Monad.Catch (MonadThrow(..), handle)
import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.Map as Map
import Options.Applicative (execParser)
import SlackBuilder.CommandLine
import SlackBuilder.Config
import SlackBuilder.Trans
import SlackBuilder.LatestVersionCheck
import SlackBuilder.Update
import qualified Toml
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Control.Monad.Trans.Reader (ReaderT(..), asks)
import SlackBuilder.Package (PackageDescription(..), renderTextWithVersion)
import qualified SlackBuilder.Package as Package
import Data.Foldable (find, traverse_)
import GHC.Records (HasField(..))
import System.Console.ANSI
    ( setSGR
    , SGR(..)
    , ColorIntensity(..)
    , Color(..)
    , ConsoleLayer(..)
    )
import Data.Maybe (mapMaybe)
import qualified Text.URI as URI
import System.Directory (listDirectory)
import qualified Data.HashMap.Strict as HashMap
import SlackBuilder.Info (readInfoFile)

autoUpdatable :: [PackageSettings] -> [PackageDescription]
autoUpdatable = mapMaybe go
  where
    go PackageSettings{ downloader = setting, downloaders } = do
        latest' <- packageUpdaterFromSettings setting
        pure $ PackageDescription
                { latest = latest'
                , name = getField @"name" setting
                , downloaders = Map.fromList $ mapMaybe forDownloader downloaders
                }
    forDownloader downloaderSettings@DownloaderSettings{ name } =
        (name,) <$> packageUpdaterFromSettings downloaderSettings

packageUpdaterFromSettings :: DownloaderSettings -> Maybe Package.Updater
packageUpdaterFromSettings DownloaderSettings{..} = do
    getVersion' <- getVersionSettings
    detectLatest' <- detectLatestSettings
    Just Package.Updater
        { detectLatest = detectLatest'
        , getVersion = getVersion'
        , is64 = is64
        }
  where
    detectLatestSettings
        | Just githubSettings <- github =
            let ghArguments = uncurry PackageOwner githubSettings
             in Just $ latestGitHub ghArguments version
        | Just packagistSettings <- packagist =
            let packagistArguments = uncurry PackageOwner packagistSettings
             in Just $ latestPackagist packagistArguments
        | Just textSettings <- text =
            let textArguments = uncurry TextArguments textSettings
             in Just $ latestText textArguments version
        | otherwise = Nothing
    getVersionSettings
        | Just template' <- template =
            Just $ repackageWithTemplate repackage $ Package.DownloadTemplate template'
        | Just CloneSettings{..} <- clone
            = flip cloneFromGit (renderTextWithVersion tagTemplate version)
            <$> URI.mkURI remote
        | otherwise = Nothing

up2Date :: Maybe Text -> SlackBuilderT ()
up2Date selectedPackage = do
    packages' <- SlackBuilderT $ asks (getField @"packages")
    case selectedPackage of
        Nothing -> traverse_ (handle handleException . go) $ autoUpdatable packages'
        Just packageName
            | Just foundPackage <- find ((packageName ==) . getField @"name") (autoUpdatable packages') ->
                go foundPackage
            | otherwise -> throwM $ UpdaterNotFound packageName
  where
    go package = getAndLogLatest package
        >>= mapM_ updatePackageIfRequired
        >> liftIO (putStrLn "")

check :: SlackBuilderT ()
check = SlackBuilderT (asks (getField @"packages"))
    >>= traverse_ (handle handleException . go) . autoUpdatable
  where
    go package = getAndLogLatest package
        >>= mapM_ checkUpdateAvailability
        >> liftIO (putStrLn "")

installed :: SlackBuilderT ()
installed = do
    listing <- listRepository
    database <- foldr createDataBase HashMap.empty . mapMaybe createEntry
        <$> liftIO (listDirectory "/var/lib/pkgtools/packages")
    traverse_ findInfo $ HashMap.intersectionWith (,) database listing
  where
    findInfo (installed'@Package.DataBaseEntry{ name }, fromRepository) = do
        _ <- readInfoFile fromRepository name
        liftIO $ print installed'
    createDataBase entry@Package.DataBaseEntry{ name } =
        HashMap.insert name entry
    createEntry filename = createEntryFromChunks
        $ Text.split (== '-')
        $ Text.reverse
        $ Text.pack filename
    createEntryFromChunks (build : arch : version : name) = Just
        Package.DataBaseEntry
            { arch = Text.reverse arch
            , build = Text.reverse build
            , version = Text.reverse version
            , name =  Text.reverse (Text.intercalate "-" name)
            }
    createEntryFromChunks _ = Nothing

main :: IO ()
main = execParser slackBuilderParser
    >>= handle handleException . withCommandLine
  where
    withCommandLine programCommand = do
        settingsResult <- Toml.decodeFileEither settingsCodec configurationFile
        case settingsResult of
            Right settings -> flip runReaderT settings
                $ runSlackBuilderT
                $ executeCommand programCommand
            Left settingsErrors
                -> setSGR [SetColor Foreground Dull Red]
                >> putStrLn (configurationFile <> " parsing failed.")
                >> setSGR [Reset]
                >> Text.putStr (Toml.prettyTomlDecodeErrors settingsErrors)
    configurationFile = "config/config.toml"
    executeCommand = \case
        CheckCommand -> check
        Up2DateCommand packageName -> up2Date packageName
        InstalledCommand -> installed