Remove the installed command

Since it is out of scope for this project.

.gitea/workflows/build.yml

@@ -7,43 +7,31 @@ on:
 
 jobs:
   audit:
-    runs-on: alpine
+    runs-on: buildenv
     steps:
-      - name: Set up environment
-        shell: ash {0}
-        run: |
-          apk add --no-cache git bash curl build-base readline-dev openssl-dev zlib-dev libpq-dev gmp-dev
-      - name: Prepare system
-        run: |
-          curl --create-dirs --output-dir \
-            ~/.ghcup/bin https://downloads.haskell.org/~ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 -o ghcup
-          chmod +x ~/.ghcup/bin/ghcup
-          ~/.ghcup/bin/ghcup install ghc 9.4.8
-          ~/.ghcup/bin/ghcup install cabal 3.6.2.0
       - uses: actions/checkout@v4
-      - name: Install dependencies
-        run: |
-          ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal update
-          ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal install hlint --constraint="hlint ==3.6.1"
-      - run: ~/.cabal/bin/hlint -- src lib tests
+      - run: hlint src lib tests
 
   test:
-    runs-on: alpine
+    runs-on: buildenv
     steps:
       - name: Set up environment
-        shell: ash {0}
         run: |
-          apk add --no-cache git bash curl build-base readline-dev openssl-dev zlib-dev libpq-dev gmp-dev
-      - name: Prepare system
-        run: |
-          curl --create-dirs --output-dir \
-            ~/.ghcup/bin https://downloads.haskell.org/~ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 -o ghcup
-          chmod +x ~/.ghcup/bin/ghcup
-          ~/.ghcup/bin/ghcup install ghc 9.4.8
-          ~/.ghcup/bin/ghcup install cabal 3.6.2.0
+          apt-get update -y
+          apt-get upgrade -y
+          apt-get install -y pkg-config liblzma-dev
       - uses: actions/checkout@v4
-      - name: Install dependencies
+      - run: cabal update
+      - run: cabal test --test-show-details=streaming
+
+  release:
+    runs-on: buildenv
+    steps:
+      - name: Set up environment
         run: |
-          ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal update
-          ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal build slackbuilder-test
-      - run: ~/.ghcup/bin/ghcup run --ghc 9.4.8 --cabal 3.6.2.0 -- cabal test --test-show-details=direct
+          apt-get update -y
+          apt-get upgrade -y
+          apt-get install -y pkg-config liblzma-dev
+      - uses: actions/checkout@v4
+      - run: cabal update
+      - run: cabal build

.gitea/workflows/deploy.yaml

@@ -0,0 +1,29 @@
+name: Deploy
+
+on:
+  push:
+    tags:
+      - '**'
+
+jobs:
+  release:
+    runs-on: buildenv
+    steps:
+      - name: Set up environment
+        run: |
+          apt-get update -y
+          apt-get upgrade -y
+          apt-get install -y pkg-config liblzma-dev
+      - uses: actions/checkout@v4
+      - run: cabal update
+      - run: cabal build
+      - name: Archive
+        run: |
+          DISTRIBUTION=$(echo $GITHUB_REF_NAME | awk '{ gsub(/^v/, "slackbuilder-"); print $0 }')
+          cabal install --installdir=$DISTRIBUTION/bin --install-method=copy
+          strip $DISTRIBUTION/bin/slackbuilder
+          tar Jcvf $DISTRIBUTION.tar.xz $DISTRIBUTION
+      - uses: akkuman/gitea-release-action@v1
+        with:
+          files: "*.tar.xz"
+          token: ${{ secrets.API_KEY }}

README.md

@@ -0,0 +1,79 @@
+# SlackBuilder
+
+SlackBuilder is a tool which aims to help to update Slackware packages.
+It checks for the latest version of an upstream package and can modify
+SlackBuild meta information accordingly.
+
+## Features
+
+- Querying various sources (like registries) for the latest upstream version.
+  Currently supported sources are:
+  - GitHub
+  - Packagist
+  - Remote text file containing a version number (like the LATEST file).
+- Updating package version and checksum in the .info file;
+  Updating version variables in the .SlackBuild
+- Updating packages with multiple sources. One source is assumed to be the main
+  source and match the version of the package. Other sources are just updated to
+  the latest version available for them.
+- Modifying or just reuploading source tarballs to a different destination.
+  SlackBuilder can download the original source tarball, optionally extract and
+  modify its contents, and upload it to another server. It can be used for
+  example to download package dependencies to ship them all within a single
+  archive, so the package can be built offline.
+
+## Build instructions
+
+SlackBuilder is a Haskell program and can be built and run using the
+Cabal build tool and package manager:
+
+```sh
+cabal build
+```
+
+After that you can run slackbuilder using Cabal and `cabal run slackbuilder`.
+Or you can install the program locally with `cabal install` and run it just
+as `slackbuilder` assuming `~/.cabal/bin` is on your PATH.
+
+# Usage
+
+## Configuration
+
+There is a sample configuration file under `config/config.toml.example`.
+The sample contains comments describing each supported option.
+Just copy this file to `config/config.toml` and modify as needed.
+
+Each package that should be updated automatically needs a special
+description which contains links to the upstream repositories and
+instructions how the sources should be prepared.
+
+Unfortunately the only format currently supported for the package
+descriptions is Haskell source code. But I'm planning to make it
+possible to describe the packages without recompiling the slackbuilder
+itself.
+
+For the time being `src/Main.hs` contains descriptions of my
+slackbuilds, that can be used as an example and a start point.
+
+## Command line options
+
+SlackBuilder is called with a command as its first argument:
+
+```sh
+slackbuilder COMMAND
+```
+
+Currently supported commands are listed below.
+
+### check
+
+`check` checks whether there are updates available. It prints the name of each
+known package together with its version. If the package version is not the
+latest known version, the version the package can be updated to is printed as
+well.
+
+### up2date
+
+Performs the package updates for packages the can be updated. `up2date` accepts
+an optional argument specifying the package that should be updated if only one
+package should be updated and not all.

config/config.toml.example

@@ -1,8 +1,35 @@
-gh_token = ""
-repository = "./slackbuilds"
-branch = "user/nick/updates"
-download_url = "https://example.com/some/path"
-remote_path = "example.com:/srv/httpd/some/path"
+## Global options
 
+# Accessing GitHub APIs is only possible using a personal access token. The
+# token doesn't need any scopes set since it is used to query public
+# repositories.
+gh_token = ""
+
+# Relative path to a cloned SBo repository.
+repository = "./slackbuilds"
+
+# After one package is updated a commit is created on this branch. The branch is
+# not pushed or reset automatically.
+branch = "user/nick/updates"
+
+# If some packages use custom sources and these sources a generated during the
+# update, this option specifies the base URL where the sources can be downloaded
+# afterwads. The full URL written into the .info file contains download_url,
+# followed by the package name and source file name. This option should probably
+# be configured consistently with the remote_path.
+download_url = "https://example.com/some/path"
+
+# If a package updater generates a source tarball, the tarball is uploaded with
+# a command given in this parameter. The parameter is a array where the first
+# element is the command with the following elements being the command
+# arguments. The command supports 2 placeholders:
+# %s - Path to the source archive.
+# %c - Package category.
+upload_command = ["scp", "%s", "example.com:/srv/httpd/some/path/%c"]
+
+## Maintainer specific options
 [maintainer]
+
+# Whether the git commits should be signed with a GPG signature using the
+# default key.
 signature = false

lib/SlackBuilder/Config.hs

@@ -1,35 +1,95 @@
+{- 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/. -}
+
+-- | Configuration file.
 module SlackBuilder.Config
-    ( Settings(..)
+    ( CloneSettings(..)
+    , DownloaderSettings(..)
+    , Settings(..)
     , MaintainerSettings(..)
+    , PackageSettings(..)
     , settingsCodec
     ) where
 
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import Toml ((.=))
 import qualified Toml
+import GHC.Records (HasField(..))
 
 data Settings = Settings
     { ghToken :: !Text
     , repository :: !FilePath
     , branch :: Text
     , downloadURL :: Text
-    , remotePath :: Text
+    , uploadCommand :: NonEmpty Text
     , maintainer :: MaintainerSettings
+    , packages :: [PackageSettings]
     } deriving (Eq, Show)
 
 newtype MaintainerSettings = MaintainerSettings
     { signature :: Bool
     } deriving (Eq, Show)
 
+data DownloaderSettings = DownloaderSettings
+    { name :: Text
+    , is64 :: Bool
+    , version :: Text
+    , template :: Maybe Text
+    , clone :: Maybe CloneSettings
+    , github :: Maybe (Text, Text)
+    , packagist :: Maybe (Text, Text)
+    , text :: Maybe (Text, [String])
+    , repackage :: Maybe [String]
+    } deriving (Eq, Show)
+
+data PackageSettings = PackageSettings
+    { downloader :: DownloaderSettings
+    , downloaders :: [DownloaderSettings]
+    } deriving (Eq, Show)
+
+data CloneSettings = CloneSettings
+    { remote :: Text
+    , tagTemplate :: Text
+    } deriving (Eq, Show)
+
 settingsCodec :: Toml.TomlCodec Settings
 settingsCodec = Settings
     <$> Toml.text "gh_token" .= ghToken
     <*> Toml.string "repository" .= repository
     <*> Toml.text "branch" .= branch
     <*> Toml.text "download_url" .= downloadURL
-    <*> Toml.text "remote_path" .= remotePath
+    <*> Toml.arrayNonEmptyOf Toml._Text "upload_command" .= uploadCommand
     <*> Toml.table maintainerSettingsCodec "maintainer" .= maintainer
+    <*> Toml.list packageSettingsCodec "package" .= packages
 
 maintainerSettingsCodec :: Toml.TomlCodec MaintainerSettings
 maintainerSettingsCodec = MaintainerSettings
     <$> Toml.bool "signature" .= signature
+
+downloaderSettingsCodec :: Toml.TomlCodec DownloaderSettings
+downloaderSettingsCodec = DownloaderSettings
+    <$> Toml.text "name" .= name
+    <*> Toml.bool "is64" .= is64
+    <*> Toml.text "version" .= version
+    <*> Toml.dioptional (Toml.text "template") .= template
+    <*> Toml.dioptional (Toml.table cloneSettingsCodec "clone") .= clone
+    <*> Toml.dioptional (Toml.table githubCodec "github") .= github
+    <*> Toml.dioptional (Toml.table packagistCodec "packagist") .= packagist
+    <*> Toml.dioptional (Toml.table textCodec "text") .= text
+    <*> Toml.dioptional (Toml.arrayOf Toml._String "repackage") .= repackage
+  where
+    githubCodec = Toml.pair (Toml.text "owner") (Toml.text "name")
+    packagistCodec = Toml.pair (Toml.text "owner") (Toml.text "name")
+    textCodec = Toml.pair (Toml.text "url") (Toml.arrayOf Toml._String "picker")
+
+packageSettingsCodec :: Toml.TomlCodec PackageSettings
+packageSettingsCodec = PackageSettings
+    <$> downloaderSettingsCodec .= getField @"downloader" 
+    <*> Toml.list downloaderSettingsCodec "downloader" .= downloaders
+
+cloneSettingsCodec :: Toml.TomlCodec CloneSettings
+cloneSettingsCodec = CloneSettings
+    <$> Toml.text "remote" .= remote
+    <*> Toml.text "tag_template" .= tagTemplate

lib/SlackBuilder/Download.hs

@@ -1,16 +1,32 @@
+{- 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/. -}
+
+-- | Contains routines for downloading, cloning and uploading sources.
 module SlackBuilder.Download
-    ( clone
-    , cloneAndArchive
+    ( cloneAndUpload
+    , extractRemote
     , commit
+    , createLzmaTarball
     , download
     , hostedSources
     , remoteFileExists
+    , responseBodySource
+    , reqGet
+    , sinkFileAndHash
+    , sinkHash
     , updateSlackBuildVersion
-    , uploadCommand
+    , uploadSource
     ) where
 
+import qualified Codec.Compression.Lzma as Lzma
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Char8 as Char8
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.NonNull (toNullable)
+import Data.Foldable (find)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
@@ -20,8 +36,9 @@ import SlackBuilder.Config
 import SlackBuilder.Trans
 import Control.Monad.Trans.Reader (asks)
 import Control.Monad.IO.Class (MonadIO(liftIO))
+import System.Directory (createDirectory, removePathForcibly)
 import System.IO (IOMode(..), withFile)
-import System.FilePath ((</>), (<.>), takeBaseName, splitPath, joinPath)
+import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, stripExtension)
 import System.Process
     ( CreateProcess(..)
     , StdStream(..)
@@ -30,10 +47,12 @@ import System.Process
     , callProcess
     )
 import System.Exit (ExitCode(..))
-import Control.Monad (unless)
-import Text.URI (URI(..), mkURI)
+import Control.Monad (unless, void)
+import Text.URI (URI(..))
+import qualified Text.URI as URI
 import Network.HTTP.Req
     ( useHttpsURI
+    , useURI
     , HEAD(..)
     , NoReqBody(..)
     , req
@@ -41,6 +60,7 @@ import Network.HTTP.Req
     , defaultHttpConfig
     , ignoreResponse
     , responseStatusCode
+    , MonadHttp
     , HttpConfig(..)
     , GET(..)
     , reqBr
@@ -49,6 +69,7 @@ import Data.Functor ((<&>))
 import Network.HTTP.Client (BodyReader, Response(..), brRead)
 import Conduit
     ( ConduitT
+    , MonadResource
     , yield
     , runConduitRes
     , sinkFile
@@ -56,9 +77,15 @@ import Conduit
     , ZipSink(..)
     , await
     , sourceFile
+    , leftover
+    , awaitNonNull
     )
+import Data.Conduit.Tar (FileInfo(..), tarFilePath, untar)
 import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
 import Data.Void (Void)
+import qualified Data.Conduit.Zlib as Zlib
+import Control.Monad.Catch (MonadThrow(..))
+import Data.Maybe (fromMaybe)
 
 updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT ()
 updateSlackBuildVersion packagePath version additionalDownloads = do
@@ -112,12 +139,19 @@ commit packagePath version = do
                 }
          in readCreateProcessWithExitCode createCheckoutProcess ""
 
-hostedSources :: Text -> SlackBuilderT URI
-hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
-    >>= liftIO . mkURI . (<> absoluteURL)
+hostedSources :: NonEmpty Text -> SlackBuilderT URI
+hostedSources urlPathPieces = do
+        downloadURL' <- SlackBuilderT (asks downloadURL) >>= URI.mkURI
+        urlPathPieces' <- traverse URI.mkPathPiece urlPathPieces
 
-remoteFileExists :: Text -> SlackBuilderT Bool
-remoteFileExists url = hostedSources url
+        let updatedPath = case URI.uriPath downloadURL' of
+                Just (_, existingPath) ->
+                    NonEmpty.append existingPath urlPathPieces'
+                Nothing -> urlPathPieces'
+        pure $ downloadURL'{ uriPath = Just (False, updatedPath) }
+
+remoteFileExists :: NonEmpty Text -> SlackBuilderT Bool
+remoteFileExists urlPathPieces = hostedSources urlPathPieces
     >>= traverse (runReq httpConfig . go . fst) . useHttpsURI
     <&> maybe False ((== 200) . responseStatusCode)
   where
@@ -126,46 +160,44 @@ remoteFileExists url = hostedSources url
         }
     go uri = req HEAD uri NoReqBody ignoreResponse mempty
 
-uploadCommand :: Text -> Text -> SlackBuilderT ()
-uploadCommand localPath remotePath' = do
-    remoteRoot <- SlackBuilderT $ asks remotePath
-    repository' <- SlackBuilderT $ asks repository
+cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT ()
+cloneAndArchive repo tarballPath tagPrefix = do
+    let version = snd $ Text.breakOnEnd "-"
+            $ Text.pack $ takeFileName tarballPath 
 
-    liftIO $ callProcess "scp"
-        [ repository' </> Text.unpack localPath
-        , Text.unpack $ remoteRoot <> remotePath'
+    repositoryTarballPath <- relativeToRepository tarballPath
+    repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
+    liftIO
+        $ removePathForcibly repositoryTarballPath
+        >> callProcess "git"
+            [ "clone"
+            , Text.unpack repo
+            , repositoryTarballPath
             ]
-
-cloneAndArchive :: Text -> Text -> FilePath -> Text -> SlackBuilderT ()
-cloneAndArchive repo nameVersion tarball tagPrefix = do
-    let (_, version) = Text.breakOnEnd "-" nameVersion
-        nameVersion' = Text.unpack nameVersion
-
-    repository' <- SlackBuilderT $ asks repository
-    liftIO $ callProcess "rm" ["-rf", nameVersion']
-
-    liftIO $ callProcess "git" ["clone", Text.unpack repo, nameVersion']
-    liftIO $ callProcess "git"
+        >> callProcess "git"
             [ "-C"
-        , nameVersion'
+            , repositoryTarballPath
             , "checkout"
             , Text.unpack $ tagPrefix <> version
             ]
-    liftIO $ callProcess "git"
+        >> callProcess "git"
             [ "-C"
-        , nameVersion'
+            , repositoryTarballPath
             , "submodule"
             , "update"
             , "--init"
             , "--recursive"
             ]
+        >> createLzmaTarball repositoryTarballPath repositoryArchivePath
+        >> removePathForcibly repositoryTarballPath
 
-    liftIO $ callProcess "tar"
-        [ "Jcvf"
-        , repository' </> tarball
-        , nameVersion'
-        ]
-    liftIO $ callProcess "rm" ["-rf", nameVersion']
+-- | Takes a directory as input and a file name as output and creates a tar.xz
+-- archive from the given directory.
+createLzmaTarball :: FilePath -> FilePath -> IO (Digest MD5)
+createLzmaTarball input output = runConduitRes $ yield input
+    .| void tarFilePath
+    .| compressLzma
+    .| sinkFileAndHash output
 
 responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m ()
 responseBodySource = bodyReaderSource . responseBody
@@ -179,30 +211,150 @@ sinkHash = sink hashInit
     sink ctx = await
         >>= maybe (pure $ hashFinalize ctx) (sink . hashUpdate ctx)
 
-download :: URI -> FilePath -> SlackBuilderT (Maybe (Digest MD5))
-download uri target = traverse (runReq defaultHttpConfig . go . fst)
-    $ useHttpsURI uri
-  where
-    go uri' = reqBr GET uri' NoReqBody mempty readResponse
-    readResponse :: Response BodyReader -> IO (Digest MD5)
-    readResponse response = runConduitRes
-        $ responseBodySource response
-        .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)
+cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (URI, Digest MD5)
+cloneAndUpload repo tarballPath tagPrefix = do
+    let tarballFileName = takeFileName tarballPath <.> "tar.xz"
+        packageName = takeFileName $ takeDirectory tarballPath
+        remoteArchivePath = Text.pack $ packageName </> tarballFileName
+        urlPathPieces = Text.pack <$> packageName :| [tarballFileName]
 
-clone :: Text -> Text -> Text -> SlackBuilderT (Maybe (Digest MD5))
-clone repo tarball tagPrefix = do
-    repository' <- SlackBuilderT $ asks repository
-    let tarballPath = Text.unpack tarball
-        nameVersion = Text.pack $ takeBaseName tarballPath
-        remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
-        localPath = repository' </> tarballPath
-    remoteFileExists' <- remoteFileExists remotePath
+    localPath <- relativeToRepository tarballFileName
+    remoteResultURI <- hostedSources urlPathPieces
+    remoteFileExists' <- remoteFileExists urlPathPieces
 
     if remoteFileExists'
-    then
-        hostedSources remotePath >>= flip download localPath
+    then (remoteResultURI,) . snd
+        <$> download remoteResultURI (takeDirectory localPath)
     else
         let go = sourceFile localPath .| sinkHash
-         in cloneAndArchive repo nameVersion tarballPath tagPrefix
-            >> uploadCommand tarball remotePath
-            >> liftIO (runConduitRes go) <&> Just
+         in cloneAndArchive repo tarballPath tagPrefix
+            >> uploadSource localPath remoteArchivePath
+            >> liftIO (runConduitRes go) <&> (remoteResultURI,)
+
+-- | Given a path to a local file and a remote path uploads the file using
+-- the settings given in the configuration file.
+--
+-- The remote path is given relative to the path in the configuration.
+uploadSource :: FilePath -> Text -> SlackBuilderT ()
+uploadSource localPath remotePath' = do
+    uploadCommand' :| uploadArguments <- SlackBuilderT $ asks uploadCommand
+    let uploadArguments' = Text.unpack
+            . Text.replace "%s" (Text.pack localPath)
+            . Text.replace "%c" remotePath'
+            <$> uploadArguments
+
+    liftIO $ callProcess (Text.unpack uploadCommand') uploadArguments'
+
+-- | Downlaods a file into the directory. Returns name of the downloaded file
+-- and checksum.
+--
+-- The filename is read from the disposition header or from the URL if the
+-- Content-Disposition is missing.
+download :: URI -> FilePath -> SlackBuilderT (FilePath, Digest MD5)
+download uri packagePath = runReq defaultHttpConfig go
+  where
+    go
+        | Just uriPath <- URI.uriPath uri =
+            reqGet uri
+                $ readResponse
+                $ Text.unpack
+                $ URI.unRText
+                $ NonEmpty.last
+                $ snd uriPath
+        | otherwise = throwM $ UnsupportedUrlType uri
+    readResponse :: FilePath -> Response BodyReader -> IO (FilePath, Digest MD5)
+    readResponse downloadFileName response = do
+        let attachmentName = dispositionAttachment response
+            targetFileName = fromMaybe downloadFileName attachmentName
+            target = packagePath </> fromMaybe downloadFileName attachmentName
+        digest <- runConduitRes
+            $ responseBodySource response
+            .| sinkFileAndHash target
+        pure (targetFileName, digest)
+
+-- | Writes a file to the destination path and accumulates its MD5 checksum.
+sinkFileAndHash :: MonadResource m => FilePath -> ConduitT ByteString Void m (Digest MD5)
+sinkFileAndHash target = getZipSink
+    $ ZipSink (sinkFile target) *> ZipSink sinkHash
+
+compressLzma :: MonadIO m => ConduitT ByteString ByteString m ()
+compressLzma = liftIO (Lzma.compressIO Lzma.defaultCompressParams) >>= go
+  where
+    go (Lzma.CompressInputRequired flush supplyInput) = do
+        next <- await
+        result <- case next of
+            Just input
+                | ByteString.null input -> liftIO flush
+                | otherwise -> liftIO $ supplyInput input
+            Nothing -> liftIO $ supplyInput mempty
+        go result
+    go (Lzma.CompressOutputAvailable output stream) = yield output
+        >> liftIO stream >>= go
+    go Lzma.CompressStreamEnd = pure ()
+
+decompressLzma :: (MonadThrow m, MonadIO m) => ConduitT ByteString ByteString m ()
+decompressLzma = liftIO (Lzma.decompressIO Lzma.defaultDecompressParams) >>= go
+  where
+    go (Lzma.DecompressInputRequired processor) = do
+        next <- awaitNonNull
+        result <- case next of
+            Just input -> liftIO $ processor (toNullable input)
+            Nothing -> liftIO $ processor mempty
+        go result
+    go (Lzma.DecompressOutputAvailable output stream) = yield output
+        >> liftIO stream
+        >>= go
+    go (Lzma.DecompressStreamEnd output) = leftover output
+    go (Lzma.DecompressStreamError lzmaReturn) = throwM
+        $ LzmaDecompressionFailed lzmaReturn
+
+-- | Downloads a compressed tar archive and extracts its contents on the fly to
+-- a directory.
+--
+-- If the download contains the disposition header and the attachment type was
+-- recognized as tar archive, returns the attachment name from the
+-- disposition header without the extension. So if the disposition header
+-- is "attachment; filename=package-1.2.3.tar.gz", returns "package-1.2.3".
+extractRemote :: URI -> FilePath -> SlackBuilderT (Maybe FilePath)
+extractRemote uri' packagePath =
+    runReq defaultHttpConfig $ go packagePath
+  where
+    go toTarget = reqGet uri' $ readResponse toTarget
+    readResponse :: FilePath -> Response BodyReader -> IO (Maybe FilePath)
+    readResponse toTarget response = do
+        let attachmentName = dispositionAttachment response
+            (decompress, attachmentDirectory) =
+                case attachmentName of
+                    Just attachmentName'
+                        | Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
+                            (Zlib.ungzip, Just directoryName')
+                        | Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
+                            (decompressLzma, Just directoryName')
+                    _ -> (pure (), Nothing)
+        runConduitRes $ responseBodySource response
+            .| decompress
+            .| untar (withDecompressedFile toTarget)
+        pure attachmentDirectory
+    withDecompressedFile toTarget FileInfo{..}
+        | Char8.last filePath /= '/' =
+            sinkFile (toTarget </> Char8.unpack filePath)
+        | otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))
+
+dispositionAttachment :: Response BodyReader -> Maybe FilePath
+dispositionAttachment response
+    = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
+    $ find ((== "Content-Disposition") . fst)
+    $ responseHeaders response
+
+reqGet :: (MonadThrow m, MonadHttp m)
+    => URI
+    -> (Response BodyReader -> IO a)
+    -> m a
+reqGet uri bodyReader =
+    case useURI uri of
+        Just urlWithOptions
+            | Left (httpsURI, httpsOptions) <- urlWithOptions ->
+                reqBr GET httpsURI NoReqBody httpsOptions bodyReader
+            | Right (httpsURI, httpsOptions) <- urlWithOptions ->
+                reqBr GET httpsURI NoReqBody httpsOptions bodyReader
+        _ -> throwM $ UnsupportedUrlType uri

lib/SlackBuilder/Info.hs

@@ -1,9 +1,13 @@
+{- 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/. -}
+
+-- | Info file parsing and printing.
 module SlackBuilder.Info
     ( PackageInfo(..)
     , generate
     , parseInfoFile
-    , update
-    , updateDownloadVersion
+    , readInfoFile
     ) where
 
 import Control.Applicative (Alternative(..))
@@ -12,7 +16,6 @@ import qualified Data.ByteArray as ByteArray
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Char8 as Char8
-import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -24,20 +27,27 @@ import Crypto.Hash (Digest, MD5, digestFromByteString)
 import Data.Void (Void)
 import Data.Word (Word8)
 import Numeric (readHex, showHex)
-import Text.Megaparsec (Parsec, count, eof, takeWhile1P)
-import Text.Megaparsec.Byte (space, string, hexDigitChar)
+import Text.Megaparsec (Parsec, count, eof, parse, takeWhile1P)
+import Text.Megaparsec.Byte (hspace1, space, string, hexDigitChar)
 import Text.URI
-    ( Authority(..)
-    , URI(..)
-    , mkPathPiece
+    ( URI(..)
     , parserBs
     , render
-    , unRText
     )
 import qualified Data.Word8 as Word8
+import SlackBuilder.Trans
+    ( SlackBuilderT(..)
+    , SlackBuilderException(..)
+    , relativeToRepository
+    )
+import System.FilePath ((</>), (<.>))
+import Control.Monad.IO.Class (MonadIO(..))
+import Conduit (MonadThrow(throwM))
+import Control.Monad (void)
 
 type GenParser = Parsec Void ByteString
 
+-- | Data used to generate an .info file.
 data PackageInfo = PackageInfo
     { pkgname :: String
     , version :: Text
@@ -57,7 +67,7 @@ variableEntry variable = string (Char8.append variable "=\"")
     <* string "\"\n"
 
 variableSeparator :: GenParser ()
-variableSeparator = string " \\" *> space
+variableSeparator = void $ some $ hspace1 <|> void (string "\\\n")
 
 packageDownloads :: ByteString -> GenParser [URI]
 packageDownloads variableName = string (variableName <> "=\"")
@@ -65,9 +75,11 @@ packageDownloads variableName = string (variableName <> "=\"")
     <* string "\"\n"
 
 hexDigit :: GenParser Word8
-hexDigit =
-    let digitPair = count 2 hexDigitChar
-     in fst . head . readHex . fmap (toEnum . fromIntegral) <$> digitPair
+hexDigit = count 2 hexDigitChar
+    >>= extractNumber . readHex . fmap (toEnum . fromIntegral)
+  where
+    extractNumber [(number, "")] = pure number
+    extractNumber _ = fail "Unable to convert a 2-digit hexadecimal number"
 
 packageChecksum :: GenParser ByteString
 packageChecksum = ByteString.pack <$> count 16 hexDigit
@@ -88,10 +100,11 @@ packageName = takeWhile1P Nothing isNameToken
     isNameToken x = Word8.isAlphaNum x
         || x == Word8._hyphen
         || x == Word8._underscore
+        || x == Word8._period
 
 parseInfoFile :: GenParser PackageInfo
-parseInfoFile = PackageInfo
-    <$> (Char8.unpack <$> packagePrgnam)
+parseInfoFile = PackageInfo . Char8.unpack
+    <$> packagePrgnam
     <*> (Text.decodeUtf8 <$> variableEntry "VERSION")
     <*> (Text.decodeUtf8 <$> variableEntry "HOMEPAGE")
     <*> packageDownloads "DOWNLOAD"
@@ -108,59 +121,16 @@ parseInfoFile = PackageInfo
         *> packageName
         <* "\"\n"
 
-updateDownloadVersion :: PackageInfo -> Text -> Maybe String -> [URI]
-updateDownloadVersion package toVersion gnomeVersion
-    = updateDownload (version package) toVersion gnomeVersion
-    <$> downloads package
+readInfoFile :: Text -> Text -> SlackBuilderT PackageInfo
+readInfoFile category packageName' = do
+    let packageName'' = Text.unpack packageName'
 
-updateDownload :: Text -> Text -> Maybe String -> URI -> URI
-updateDownload fromVersion toVersion gnomeVersion
-    = updateCoreVersion fromVersion toVersion gnomeVersion
-    . updatePackageVersion fromVersion toVersion gnomeVersion
+    infoPath <- relativeToRepository
+        $ Text.unpack category </> packageName'' </> packageName'' <.> "info"
+    infoContents <- liftIO $ ByteString.readFile infoPath
 
-updatePackageVersion :: Text -> Text -> Maybe String -> URI -> URI
-updatePackageVersion fromVersion toVersion _gnomeVersion download = download
-    { uriPath = uriPath download >>= traverse (traverse updatePathPiece)
-    }
-  where
-    updatePathPiece = mkPathPiece
-        . Text.replace fromMajor toMajor
-        . Text.replace fromVersion toVersion
-        . unRText
-    fromMajor = major fromVersion
-    toMajor = major toVersion
-
-major :: Text -> Text
-major = Text.intercalate "." . take 2 . Text.splitOn "."
-
-updateCoreVersion :: Text -> Text -> Maybe String -> URI -> URI
-updateCoreVersion _fromVersion _toVersion (Just gnomeVersion) download
-    | Just (False, pathPieces) <- uriPath download
-    , (beforeCore, afterCore) <- NonEmpty.break (comparePathPiece "core") pathPieces
-    , _ : _ : _ : sources : afterSources <- afterCore
-    , comparePathPiece "sources" sources && not (null afterSources)
-    , Right Authority{..} <- uriAuthority download
-    , ".gnome.org" `Text.isSuffixOf` unRText authHost
-    , Nothing <- authPort =
-        download { uriPath = buildPath beforeCore afterSources }
-  where
-    comparePathPiece this that = Just that == mkPathPiece this
-    buildPath beforeCore afterSources = do
-        core <- mkPathPiece "core"
-        let textGnomeVersion = Text.pack gnomeVersion
-        minorGnomeVersion <- mkPathPiece $ major textGnomeVersion
-        patchGnomeVersion <- mkPathPiece textGnomeVersion
-        sources <- mkPathPiece "sources"
-        let afterCore = core : minorGnomeVersion : patchGnomeVersion : sources : afterSources
-        (False,) <$> NonEmpty.nonEmpty (beforeCore ++ afterCore)
-updateCoreVersion _ _ _ download = download            
-
-update :: PackageInfo -> Text -> [URI] -> [Digest MD5] -> PackageInfo
-update old toVersion downloads' checksums' = old
-    { version = toVersion
-    , downloads = downloads'
-    , checksums = checksums'
-    }
+    either (throwM . MalformedInfoFile) pure
+        $ parse parseInfoFile infoPath infoContents
 
 generate :: PackageInfo -> Text
 generate pkg = Lazy.Text.toStrict $ Text.Builder.toLazyText builder
@@ -172,7 +142,7 @@ generate pkg = Lazy.Text.toStrict $ Text.Builder.toLazyText builder
     builder = "PRGNAM=\"" <> Text.Builder.fromString (pkgname pkg) <> "\"\n"
         <> "VERSION=\"" <> Text.Builder.fromText (version pkg) <> "\"\n"
         <> "HOMEPAGE=\"" <> Text.Builder.fromText (homepage pkg) <> "\"\n"
-        <> generateMultiEntry "DOWNLOAD" (render <$> downloads pkg)
+        <> downloadEntry
         <> generateMultiEntry "MD5SUM" (digestToText <$> checksums pkg)
         <> generateMultiEntry "DOWNLOAD_x86_64" (render <$> downloadX64 pkg)
         <> generateMultiEntry "MD5SUM_x86_64" (digestToText <$> checksumX64 pkg)
@@ -181,6 +151,10 @@ generate pkg = Lazy.Text.toStrict $ Text.Builder.toLazyText builder
         <> "EMAIL=\"" <> Text.Builder.fromText (email pkg) <> "\"\n"
     fromByteStringWords = Text.Builder.fromText
         . Text.unwords . fmap Text.decodeUtf8
+    downloadEntry
+        | null $ downloads pkg
+        , not $ null $ downloadX64 pkg = "DOWNLOAD=\"UNSUPPORTED\"\n"
+        | otherwise = generateMultiEntry "DOWNLOAD" $ render <$> downloads pkg
 
 generateMultiEntry :: Text -> [Text] -> Text.Builder
 generateMultiEntry name entries = Text.Builder.fromText name

lib/SlackBuilder/LatestVersionCheck.hs

@@ -0,0 +1,307 @@
+{- 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/. -}
+
+-- | This module contains implementations to check the latest version of a
+-- package hosted by a specific service.
+module SlackBuilder.LatestVersionCheck
+    ( PackageOwner(..)
+    , TextArguments(..)
+    , latestGitHub
+    , latestPackagist
+    , latestText
+    , match
+    ) where
+
+import SlackBuilder.Config
+import qualified Data.Aeson as Aeson
+import Data.Aeson ((.:))
+import Data.Aeson.TH (defaultOptions, deriveJSON)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text.Encoding
+import Data.Vector (Vector, (!?))
+import qualified Data.Vector as Vector
+import Network.HTTP.Req
+    ( header
+    , runReq
+    , defaultHttpConfig
+    , req
+    , GET(..)
+    , https
+    , jsonResponse
+    , NoReqBody(..)
+    , (/:)
+    , responseBody
+    , POST(..)
+    , ReqBodyJson(..)
+    , JsonResponse
+    )
+import Text.URI (mkURI)
+import SlackBuilder.Trans
+import qualified Data.Aeson.KeyMap as KeyMap
+import GHC.Records (HasField(..))
+import Control.Monad.Trans.Reader (asks)
+import Data.Char (isAlpha)
+import SlackBuilder.Download (responseBodySource, reqGet)
+import Network.HTTP.Client (BodyReader, Response(..))
+import Conduit (decodeUtf8C, (.|), linesUnboundedC, sinkNull, runConduit)
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Process (sourceProcessWithStreams, proc)
+import Data.Maybe (listToMaybe, mapMaybe)
+
+data PackageOwner = PackageOwner
+    { owner :: Text
+    , name :: Text
+    } deriving (Eq, Show)
+
+data MatchState = MatchState
+    { ignoring :: !Bool
+    , matched :: !Text
+    , pattern' :: ![MatchToken]
+    } deriving (Eq, Show)
+
+data MatchToken
+    = OpenParenMatchToken
+    | CloseParenMatchToken
+    | SymbolMatchToken Char
+    | AtLeastMatchToken [Char]
+    | OneOfMatchToken [Char]
+    deriving (Eq, Show)
+
+-- | Matches a string (for example a version name or CVS tag) against a pattern.
+-- Returns the matched part of the string or 'Nothing' if there is not match.
+--
+-- The pattern is just a list of characters with some special characters and
+-- sequences.
+--
+--     * ( ) - The text in parentheses is matched but no saved in the resulting
+--     string.
+--     * \\d - Matches zero or more digits.
+--     * \\D - Matches one or more digits.
+--     * \\. - Matches zero or more digits or dots.
+--     * \\\\ - Matches a back slash.
+--     * * - Matches everything.
+--     * [ ] - Match one of the characters inbetween. The characters are
+--     matched verbatim.
+--
+-- For example the following expression matches tags like @v1.2.3@, but returns
+-- only @1.2.3@.
+--
+-- @
+-- (v)\\.
+-- @
+match :: Text -> Text -> Maybe Text
+match fullPattern = go startState
+  where
+    startState = MatchState
+        { ignoring = False
+        , matched = mempty
+        , pattern' = parsePattern fullPattern
+        }
+    go :: MatchState -> Text -> Maybe Text
+    -- There is no input, look at the remaining tokens.
+    go MatchState{ pattern' = [], matched } "" = Just matched
+    go state@MatchState{ pattern' = OpenParenMatchToken : tokens } input' =
+        go (state{ ignoring = True, pattern' = tokens }) input'
+    go state@MatchState{ pattern' = CloseParenMatchToken : tokens } input' =
+        go (state{ ignoring = False, pattern' = tokens }) input'
+    go state@MatchState{ pattern' = SymbolMatchToken patternCharacter : tokens } input'
+        | Just (nextCharacter, leftOver) <- Text.uncons input'
+        , patternCharacter == nextCharacter =
+            go (matchSymbolToken state{ pattern' = tokens } nextCharacter) leftOver
+        | otherwise = Nothing
+    go state@MatchState{ pattern' = OneOfMatchToken chars : tokens } input'
+        | Just (nextCharacter, leftOver) <- Text.uncons input'
+        , nextCharacter `elem` chars =
+            go (matchSymbolToken state nextCharacter) leftOver
+        | otherwise =
+            go (state{ pattern' = tokens }) input'
+    go state@MatchState{ pattern' = AtLeastMatchToken chars : tokens } input'
+        | Just (nextCharacter, leftOver) <- Text.uncons input'
+        , nextCharacter `elem` chars =
+            go (matchSymbolToken state{ pattern' = OneOfMatchToken chars : tokens } nextCharacter) leftOver
+        | otherwise = Nothing
+    -- All tokens are processed, but there is still some input left.
+    go MatchState{ pattern' = [] } _ = Nothing
+    matchSymbolToken state nextCharacter
+        | getField @"ignoring" state = state
+        | otherwise = state
+            { matched = Text.snoc (getField @"matched" state) nextCharacter
+            }
+
+parsePattern :: Text -> [MatchToken]
+parsePattern input'
+    | Just (firstChar, remaining) <- Text.uncons input'
+    , firstChar == '\\' =
+        case Text.uncons remaining of
+            Nothing -> []
+            Just ('d', remaining') -> OneOfMatchToken digits
+                : parsePattern remaining'
+            Just ('D', remaining') -> AtLeastMatchToken digits
+                : parsePattern remaining'
+            Just ('.', remaining') -> AtLeastMatchToken ('.' : digits)
+                : parsePattern remaining'
+            Just ('\\', remaining') -> SymbolMatchToken '\\'
+                : parsePattern remaining'
+            Just (_, remaining') -> parsePattern remaining'
+    | Just (firstChar, remaining) <- Text.uncons input'
+    , firstChar == '['
+    , Just lastBracket <- Text.findIndex (== ']') remaining
+        = OneOfMatchToken (Text.unpack $ Text.take lastBracket remaining)
+        : parsePattern (Text.drop (succ lastBracket) remaining)
+    | Just (firstChar, remaining) <- Text.uncons input' =
+        let token =
+                case firstChar of
+                    '*' -> OneOfMatchToken (toEnum <$> [32 .. 127])
+                    '(' -> OpenParenMatchToken
+                    ')' -> CloseParenMatchToken
+                    s -> SymbolMatchToken s
+         in token : parsePattern remaining
+    | otherwise = []
+  where
+    digits = toEnum <$> [fromEnum '0' .. fromEnum '9']
+
+-- * Packagist
+
+newtype PackagistPackage = PackagistPackage
+    { version :: Text
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''PackagistPackage)
+
+newtype PackagistResponse = PackagistResponse
+    { packages :: HashMap Text (Vector PackagistPackage)
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''PackagistResponse)
+
+latestPackagist :: PackageOwner -> SlackBuilderT (Maybe Text)
+latestPackagist PackageOwner{..} = do
+    packagistResponse <- runReq defaultHttpConfig $
+        let uri = https "repo.packagist.org" /: "p2"
+                /: owner
+                /: name <> ".json"
+         in req GET uri NoReqBody jsonResponse mempty
+    let packagistPackages = getField @"packages"
+            $ Network.HTTP.Req.responseBody (packagistResponse :: JsonResponse PackagistResponse)
+        fullName = Text.intercalate "/" [owner, name]
+
+    pure $ HashMap.lookup fullName packagistPackages
+        >>= fmap (getField @"version" . fst) . Vector.uncons
+
+-- * Remote text file
+
+data TextArguments = TextArguments
+    { textURL :: Text
+    , versionPicker :: [String]
+    }
+
+latestText :: TextArguments -> Text -> SlackBuilderT (Maybe Text)
+latestText TextArguments{..} pattern' = do
+    uri' <- mkURI textURL
+    versions <- case versionPicker of
+        (command : arguments) ->
+            runReq defaultHttpConfig $ reqGet uri' $ readResponse command arguments
+        [] -> runReq defaultHttpConfig $ reqGet uri' go
+    pure $ listToMaybe $ mapMaybe (match pattern') versions
+  where
+    readResponse :: String -> [String] -> Response BodyReader -> IO [Text]
+    readResponse command arguments response = do
+        let createProcess' = proc command arguments
+        (_, stdout', _) <- sourceProcessWithStreams createProcess' (responseBodySource response) stdoutReader sinkNull
+        pure stdout'
+    stdoutReader = decodeUtf8C .| linesUnboundedC .| CL.consume
+    go response = runConduit $ responseBodySource response .| stdoutReader
+
+-- * GitHub
+
+newtype GhRefNode = GhRefNode
+    { name :: Text
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''GhRefNode)
+
+newtype GhRef = GhRef
+    { nodes :: Vector GhRefNode
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''GhRef)
+
+newtype GhRepository = GhRepository
+    { refs :: GhRef
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''GhRepository)
+
+newtype GhData = GhData
+    { repository :: GhRepository
+    } deriving (Eq, Show)
+
+instance Aeson.FromJSON GhData where
+    parseJSON (Aeson.Object keyMap)
+        | Just data' <- KeyMap.lookup "data" keyMap =
+            GhData <$> Aeson.withObject "GhData" (.: "repository") data'
+    parseJSON _ = fail "data key not found in the response"
+
+data GhVariables = GhVariables
+    { name :: Text
+    , owner :: Text
+    , prefix :: Maybe Text
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''GhVariables)
+
+data GhQuery = GhQuery
+    { query :: Text
+    , variables :: GhVariables
+    } deriving (Eq, Show)
+
+$(deriveJSON defaultOptions ''GhQuery)
+
+latestGitHub
+    :: PackageOwner
+    -> Text
+    -> SlackBuilderT (Maybe Text)
+latestGitHub PackageOwner{..} pattern' = do
+    ghToken' <- SlackBuilderT $ asks ghToken
+    ghResponse <- runReq defaultHttpConfig $
+        let uri = https "api.github.com" /: "graphql"
+            prefix = Text.takeWhile isAlpha
+                $ Text.filter (liftA2 (&&) (/= ')') (/= '(')) pattern'
+            query = GhQuery
+                {  query = githubQuery
+                , variables = GhVariables
+                    { owner = owner
+                    , name = name
+                    , prefix = if Text.null prefix then Nothing else Just $ prefix <> "*"
+                    }
+                }
+            authorizationHeader = header "authorization"
+                $ Text.Encoding.encodeUtf8
+                $ "Bearer " <> ghToken'
+         in req POST uri (ReqBodyJson query) jsonResponse
+            $ authorizationHeader <> header "User-Agent" "SlackBuilder"
+    let ghNodes = nodes
+            $ refs
+            $ (getField @"repository" :: GhData -> GhRepository)
+            $ Network.HTTP.Req.responseBody ghResponse
+        refs' = Vector.catMaybes
+            $ match pattern' . getField @"name" <$> ghNodes
+    pure $ refs' !? 0
+  where
+    githubQuery =
+        "query ($name: String!, $owner: String!, $prefix: String) {\n\
+        \  repository(name: $name, owner: $owner) {\n\
+        \    refs(first: 10, query: $prefix, refPrefix: \"refs/tags/\", orderBy: {\n\
+        \      field: TAG_COMMIT_DATE, direction: DESC\n\
+        \    }) {\n\
+        \      nodes {\n\
+        \        id,\n\
+        \        name\n\
+        \      }\n\
+        \    }\n\
+        \  }\n\
+        \}"

lib/SlackBuilder/Package.hs

@@ -1,15 +1,20 @@
+{- 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/. -}
+
+-- | Contains data describing packages, methods to update them and to request
+-- information about them.
 module SlackBuilder.Package
-    ( DownloadPlaceholder(..)
+    ( DataBaseEntry(..)
     , Download(..)
     , DownloadTemplate(..)
-    , Package(..)
-    , PackageInfo(..)
-    , Maintainer(..)
+    , PackageDescription(..)
+    , PackageUpdateData(..)
     , Updater(..)
     , renderDownloadWithVersion
+    , renderTextWithVersion
     ) where
 
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Text.URI (URI(..))
@@ -20,65 +25,57 @@ import Control.Monad.Catch (MonadThrow)
 import Data.Map (Map)
 
 -- | Contains information how a package can be updated.
-data Package = Package
+data PackageDescription = PackageDescription
     { latest :: Updater
     , downloaders :: Map Text Updater
-    , category :: Text
     , name :: Text
     }
 
+data PackageUpdateData = PackageUpdateData
+    { description :: PackageDescription
+    , category :: Text
+    , version :: Text
+    }
+
 -- | Download URI with the MD5 checksum of the target.
 data Download = Download
     { download :: URI
     , md5sum :: Digest MD5
-    , is64 :: Bool
     } deriving (Eq, Show)
 
--- | Data used to generate an .info file.
-data PackageInfo = PackageInfo
-    { path :: FilePath
-    , version :: Text
-    , homepage :: Text
-    , requires :: [Text]
-    , maintainer :: Maintainer
-    } deriving (Eq, Show)
-
--- | Package maintainer information.
-data Maintainer = Maintainer
-    { name :: Text
-    , email :: Text
-    } deriving (Eq, Show)
-
--- | Appears in the download URI template and specifies which part of the URI
--- should be replaced with the package version.
-data DownloadPlaceholder
-    = StaticPlaceholder Text
-    | VersionPlaceholder
-    deriving Eq
-
-instance Show DownloadPlaceholder
-  where
-    show (StaticPlaceholder staticPlaceholder) = Text.unpack staticPlaceholder
-    show VersionPlaceholder = "{version}"
-
 -- | List of URI components, including version placeholders.
-newtype DownloadTemplate = DownloadTemplate (NonEmpty DownloadPlaceholder)
-    deriving Eq
+newtype DownloadTemplate = DownloadTemplate
+    { unDownloadTemplate :: Text
+    } deriving Eq
 
 instance Show DownloadTemplate
   where
-    show (DownloadTemplate components) = concatMap show components
+    show = Text.unpack . unDownloadTemplate
 
 -- | Replaces placeholders in the URL template with the given version.
 renderDownloadWithVersion :: MonadThrow m => DownloadTemplate -> Text -> m URI
-renderDownloadWithVersion (DownloadTemplate components) version =
-    URI.mkURI $ foldr f "" components
-  where
-    f (StaticPlaceholder staticPlaceholder) = (staticPlaceholder <>)
-    f VersionPlaceholder = (version <>)
+renderDownloadWithVersion (DownloadTemplate template) version =
+    URI.mkURI $ renderTextWithVersion template version
+
+-- | Replaces placeholders in the text with the given version.
+renderTextWithVersion :: Text -> Text -> Text
+renderTextWithVersion template version = Text.replace "{version}" version template
 
 -- | Function used to get the latest version of a source.
 data Updater = Updater
     { detectLatest :: SlackBuilderT (Maybe Text)
+    , is64 :: Bool
     , getVersion :: Text -> Text -> SlackBuilderT Download
     }
+
+data DataBaseEntry = DataBaseEntry
+    { name :: Text
+    , version :: Text
+    , arch :: Text
+    , build :: Text
+    } deriving Eq
+
+instance Show DataBaseEntry
+  where
+    show DataBaseEntry{..} = Text.unpack
+        $ Text.intercalate "-" [name, version, arch, build]

lib/SlackBuilder/Trans.hs

@@ -1,16 +1,75 @@
+{- 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/. -}
+
+-- | Transformers and exceptions.
 module SlackBuilder.Trans
-    ( SlackBuilderT(..)
+    ( SlackBuilderException(..)
+    , SlackBuilderT(..)
+    , relativeToRepository
     ) where
 
-import Control.Monad.Trans.Reader (ReaderT(..))
+import Control.Monad.Trans.Reader (ReaderT(..), asks)
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import qualified Data.Text as Text
 import SlackBuilder.Config
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
+import Control.Exception (Exception(..))
+import System.FilePath ((</>))
+import Text.URI (URI)
+import qualified Text.URI as URI
+import qualified Codec.Compression.Lzma as Lzma
+import Text.Megaparsec (ParseErrorBundle(..), errorBundlePretty)
+import Conduit (Void)
+
+data SlackBuilderException
+    = UpdaterNotFound Text
+    | UnsupportedUrlType URI
+    | LzmaDecompressionFailed Lzma.LzmaRet
+    | MalformedInfoFile (ParseErrorBundle ByteString Void)
+    deriving Show
+
+instance Exception SlackBuilderException
+  where
+    displayException (UpdaterNotFound updateName) = Text.unpack
+        $ Text.concat ["Requested package \"", updateName, "\" was not found"]
+    displayException (UnsupportedUrlType givenURI) = Text.unpack
+        $ "Only https URLs are supported, got: " <> URI.render givenURI
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetOK) =
+        "Operation completed successfully"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetStreamEnd) =
+        "End of stream was reached"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetUnsupportedCheck) =
+        "Cannot calculate the integrity check"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetGetCheck) =
+        "Integrity check type is now available"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetMemError) =
+        "Cannot allocate memory"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetMemlimitError) =
+        "Memory usage limit was reached"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetFormatError) =
+        "File format not recognized"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetOptionsError) =
+        "Invalid or unsupported options"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetDataError) =
+        "Data is corrupt"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetBufError) =
+        "No progress is possible"
+    displayException (LzmaDecompressionFailed Lzma.LzmaRetProgError) =
+        "Programming error"
+    displayException (MalformedInfoFile errorBundle) =
+        errorBundlePretty errorBundle
  
 newtype SlackBuilderT a = SlackBuilderT
     { runSlackBuilderT :: ReaderT Settings IO a
     }
 
+relativeToRepository :: FilePath -> SlackBuilderT FilePath
+relativeToRepository filePath =
+    (</> filePath) <$> SlackBuilderT (asks repository)
+
 instance Functor SlackBuilderT
   where
     fmap f (SlackBuilderT slackBuilderT) = SlackBuilderT $ f <$> slackBuilderT

slackbuilder.cabal

@@ -1,51 +1,62 @@
 cabal-version: 2.4
 name: slackbuilder
-version: 1.0.0
+version: 1.0
 
-synopsis: Slackware build scripts and configuration files.
+synopsis: Tool to automatically update Slackware build scripts.
 bug-reports: https://git.caraus.tech/OSS/slackbuilder/issues
 
 license: MPL-2.0
 license-files: LICENSE
-copyright: (c) 2023 Eugen Wissner
+copyright: (c) 2023-2025 Eugen Wissner
 
 author: Eugen Wissner
 maintainer: belka@caraus.de
 
 category: Build
-extra-source-files: CHANGELOG.md
+extra-source-files:
+  CHANGELOG.md
+  README.md
+
+source-repository head
+  type: git
+  location: https://git.caraus.tech/OSS/slackbuilder.git
 
 common dependencies
   build-depends:
+    aeson ^>= 2.2.0,
     base >= 4.16 && < 5,
-    bytestring ^>= 0.11.0,
-    containers ^>= 0.6,
-    cryptonite >= 0.30,
+    bytestring ^>= 0.12.0,
+    conduit ^>= 1.3.5,
+    conduit-extra ^>= 1.3,
+    http-client ^>= 0.7,
+    http-client-tls ^>= 0.3,
+    containers ^>= 0.7,
+    crypton ^>= 1.0,
     directory ^>= 1.3.8,
-    filepath ^>= 1.4.2,
-    megaparsec ^>= 9.5,
+    exceptions >= 0.10,
+    filepath ^>= 1.5,
+    http-types ^>= 0.12.4,
+    megaparsec ^>= 9.7,
     modern-uri ^>= 0.3.6,
     memory ^>= 0.18,
     parser-combinators ^>= 1.3,
     process ^>= 1.6.18,
     req ^>= 3.13,
-    text ^>= 2.0,
+    tar-conduit ^>= 0.4,
+    lzma ^>= 0.0.1,
+    text ^>= 2.1,
     tomland ^>= 1.3.3,
-    transformers ^>= 0.5.6,
+    transformers ^>= 0.6.1,
+    unordered-containers ^>= 0.2.20,
+    vector ^>= 0.13.0,
     word8 ^>= 0.1.3
-  default-language: Haskell2010
+  default-language: GHC2024
   default-extensions:
-    DataKinds
     DuplicateRecordFields
-    ExplicitForAll
-    LambdaCase
-    NamedFieldPuns
     OverloadedStrings
     RecordWildCards
     QuasiQuotes
     TemplateHaskell
-    TupleSections
-    TypeApplications
 
 library
   import: dependencies
@@ -53,15 +64,13 @@ library
     SlackBuilder.Config
     SlackBuilder.Download
     SlackBuilder.Info
+    SlackBuilder.LatestVersionCheck
     SlackBuilder.Package
     SlackBuilder.Trans
   hs-source-dirs: lib
-  build-depends:
-    conduit ^>= 1.3.5,
-    exceptions >= 0.10,
-    http-client ^>= 0.7
-
   ghc-options: -Wall
+  build-depends:
+    mono-traversable ^>= 1.0.17
 
 executable slackbuilder
   import: dependencies
@@ -69,14 +78,11 @@ executable slackbuilder
 
   other-modules:
     SlackBuilder.CommandLine
-    SlackBuilder.Updater
+    SlackBuilder.Update
   build-depends:
-    aeson ^>= 2.2.0,
-    ansi-terminal ^>= 1.0,
+    ansi-terminal ^>= 1.1,
     optparse-applicative ^>= 0.18.1,
-    slackbuilder,
-    unordered-containers ^>= 0.2.19,
-    vector ^>= 0.13.0
+    slackbuilder
   hs-source-dirs: src
 
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
@@ -88,6 +94,7 @@ test-suite slackbuilder-test
 
   other-modules:
     SlackBuilder.InfoSpec
+    SlackBuilder.LatestVersionCheckSpec
     SlackBuilder.PackageSpec
   hs-source-dirs: tests
   build-depends:

src/Main.hs

@@ -1,44 +1,28 @@
+{- 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 Data.Char (isNumber)
-import Control.Applicative (Applicative(liftA2))
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
+import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.IO.Class (MonadIO(..))
-import Data.Maybe (fromJust)
 import qualified Data.Map as Map
 import Options.Applicative (execParser)
 import SlackBuilder.CommandLine
 import SlackBuilder.Config
 import SlackBuilder.Trans
-import SlackBuilder.Updater
+import SlackBuilder.LatestVersionCheck
+import SlackBuilder.Update
 import qualified Toml
-import qualified Data.ByteString as ByteString
 import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.IO as Text
 import Control.Monad.Trans.Reader (ReaderT(..), asks)
-import SlackBuilder.Download
-import SlackBuilder.Package (Package(..))
+import SlackBuilder.Package (PackageDescription(..), renderTextWithVersion)
 import qualified SlackBuilder.Package as Package
-import Text.URI (URI(..), mkURI)
-import Text.URI.QQ (uri)
-import Data.Foldable (Foldable(..), for_, find)
-import qualified Text.URI as URI
-import System.FilePath ((</>), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName)
-import SlackBuilder.Info
-import Text.Megaparsec (parse, errorBundlePretty)
+import Data.Foldable (find, traverse_)
 import GHC.Records (HasField(..))
-import System.Process
-    ( CmdSpec(..)
-    , CreateProcess(..)
-    , StdStream(..)
-    , callProcess
-    , withCreateProcess
-    , waitForProcess
-    )
 import System.Console.ANSI
     ( setSGR
     , SGR(..)
@@ -46,391 +30,89 @@ import System.Console.ANSI
     , Color(..)
     , ConsoleLayer(..)
     )
-import System.Directory (listDirectory, doesDirectoryExist)
-import Control.Monad (filterM)
-import Data.List (isPrefixOf, isSuffixOf)
+import Data.Maybe (mapMaybe)
+import qualified Text.URI as URI
 
-autoUpdatable :: [Package]
-autoUpdatable =
-    [ Package
-        { latest =
-            let ghArguments = GhArguments{ owner = "universal-ctags", name = "ctags", transform = Nothing}
-                latest' = latestGitHub ghArguments pure
-                templateTail =
-                    [ Package.VersionPlaceholder
-                    , Package.StaticPlaceholder "/ctags-"
-                    , Package.VersionPlaceholder
-                    , Package.StaticPlaceholder ".tar.gz"
-                    ]
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://github.com/universal-ctags/ctags/archive/"
-                    :| templateTail
-             in Package.Updater latest' $ reuploadWithTemplate template []
-        , category = "development"
-        , name = "universal-ctags"
-        , downloaders = mempty
+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
                 }
-    , Package
-        { latest =
-            let packagistArguments = PackagistArguments{ vendor = "composer", name = "composer" }
-                latest' = latestPackagist packagistArguments
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://getcomposer.org/download/"
-                    :| [Package.VersionPlaceholder, Package.StaticPlaceholder "/composer.phar"]
-             in Package.Updater latest' $ downloadWithTemplate template
-        , category = "development"
-        , name = "composer"
-        , downloaders = mempty
+    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
         }
-    , Package
-        { latest =
-            let ghArguments = GhArguments
-                    { owner = "jitsi"
-                    , name = "jitsi-meet-electron"
-                    , transform = Nothing
-                    }
-                latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://github.com/jitsi/jitsi-meet-electron/releases/download/v"
-                    :| Package.VersionPlaceholder
-                    : [Package.StaticPlaceholder "/jitsi-meet-x86_64.AppImage"]
-             in Package.Updater latest' $ downloadWithTemplate template
-        , category = "network"
-        , name = "jitsi-meet-desktop"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let ghArguments = GhArguments
-                    { owner = "php"
-                    , name = "php-src"
-                    , transform = Nothing
-                    }
-                checkVersion x
-                    | not $ Text.isInfixOf "RC" x
-                    , Text.isPrefixOf "php-8.2." x = Text.stripPrefix "php-" x
+  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
-                latest' = latestGitHub ghArguments checkVersion
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://www.php.net/distributions/php-"
-                    :| Package.VersionPlaceholder
-                    : [Package.StaticPlaceholder ".tar.xz"]
-             in Package.Updater latest' $ downloadWithTemplate template
-        , category = "development"
-        , name = "php82"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let ghArguments = GhArguments
-                    { owner = "kovidgoyal"
-                    , name = "kitty"
-                    , transform = Nothing
-                    }
-                latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
-                templateTail =
-                    [ Package.StaticPlaceholder "/kitty-"
-                    , Package.VersionPlaceholder
-                    , Package.StaticPlaceholder ".tar.xz"
-                    ]
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://github.com/kovidgoyal/kitty/releases/download/v"
-                    :| Package.VersionPlaceholder
-                    : templateTail
-             in Package.Updater latest' $ reuploadWithTemplate template [RawCommand "go" ["mod", "vendor"]]
-        , category = "system"
-        , name = "kitty"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let ghArguments = GhArguments
-                    { owner = "rdiff-backup"
-                    , name = "rdiff-backup"
-                    , transform = Nothing
-                    }
-                latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://github.com/rdiff-backup/rdiff-backup/releases/download/v"
-                    :| Package.VersionPlaceholder
-                    : Package.StaticPlaceholder "/rdiff-backup-"
-                    : Package.VersionPlaceholder
-                    : [Package.StaticPlaceholder ".tar.gz"]
-             in Package.Updater latest' $ reuploadWithTemplate template []
-        , category = "system"
-        , name = "rdiff-backup"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let needle = "Linux—"
-                textArguments = TextArguments
-                    { textURL = "https://help.webex.com/en-us/article/mqkve8/Webex-App-%7C-Release-notes"
-                    , versionPicker = Text.takeWhile (liftA2 (||) (== '.') isNumber)
-                        . Text.drop (Text.length needle)
-                        . snd
-                        . Text.breakOn needle
-                    }
-                latest' = latestText textArguments
-                template = Package.DownloadTemplate $ pure
-                    $ Package.StaticPlaceholder
-                        "https://binaries.webex.com/WebexDesktop-Ubuntu-Official-Package/Webex.deb"
-             in Package.Updater latest' $ downloadWithTemplate template
-        , category = "network"
-        , name = "webex"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let ghArguments = GhArguments
-                    { owner = "librsync"
-                    , name = "librsync"
-                    , transform = Nothing
-                    }
-                latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://github.com/librsync/librsync/archive/v"
-                    :| Package.VersionPlaceholder
-                    : Package.StaticPlaceholder "/librsync-"
-                    : Package.VersionPlaceholder
-                    : [Package.StaticPlaceholder ".tar.gz"]
-             in Package.Updater latest' $ reuploadWithTemplate template []
-        , category = "libraries"
-        , name = "librsync"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let textArguments = TextArguments
-                    { textURL = "https://downloads.dlang.org/releases/LATEST"
-                    , versionPicker = Text.strip
-                    }
-                latest' = latestText textArguments
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://downloads.dlang.org/releases/2.x/"
-                    :| Package.VersionPlaceholder
-                    : Package.StaticPlaceholder "/dmd."
-                    : Package.VersionPlaceholder
-                    : [Package.StaticPlaceholder ".linux.tar.xz"]
-             in Package.Updater latest' $ downloadWithTemplate template
-        , category = "development"
-        , name = "dmd"
-        , downloaders = mempty
-        }
-    , Package
-        { latest =
-            let textArguments = TextArguments
-                    { textURL = "https://downloads.dlang.org/releases/LATEST"
-                    , versionPicker = Text.strip
-                    }
-                latest' = latestText textArguments
-                template = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://codeload.github.com/dlang/tools/tar.gz/v"
-                    :| [Package.VersionPlaceholder]
-             in Package.Updater latest' $ reuploadWithTemplate template []
-        , category = "development"
-        , name = "d-tools"
-        , downloaders =
-            let dubArguments = GhArguments{ owner = "dlang", name = "dub", transform = Nothing}
-                dscannerArguments = GhArguments{ owner = "dlang-community", name = "D-Scanner", transform = Nothing }
-                dcdArguments = GhArguments{ owner = "dlang-community", name = "DCD", transform = Nothing }
-                latestDub = latestGitHub dubArguments pure
-                latestDscanner = latestGitHub dscannerArguments pure
-                latestDcd = latestGitHub dcdArguments pure
-                dubTemplate = Package.DownloadTemplate
-                    $ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v"
-                    :| [Package.VersionPlaceholder]
-                dscannerURI = [uri|https://github.com/dlang-community/D-Scanner.git|]
-                dcdURI = [uri|https://github.com/dlang-community/DCD.git|]
-             in Map.fromList
-                [ ("DUB", Package.Updater latestDub $ downloadWithTemplate dubTemplate)
-                , ("DSCANNER", Package.Updater latestDscanner $ cloneFromGit dscannerURI "v")
-                , ("DCD", Package.Updater latestDcd $ cloneFromGit dcdURI "v")
-                ]
-        }
-    ]
 
-up2Date :: SlackBuilderT ()
-up2Date = for_ autoUpdatable go
+up2Date :: Maybe Text -> SlackBuilderT ()
+up2Date selectedPackage = do
+    packages' <- SlackBuilderT $ asks (getField @"packages")
+    case selectedPackage of
+        Nothing -> traverse_ (handleExceptions . 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 package)
+        >>= mapM_ updatePackageIfRequired
         >> liftIO (putStrLn "")
 
 check :: SlackBuilderT ()
-check = for_ autoUpdatable go
+check = SlackBuilderT (asks (getField @"packages"))
+    >>= traverse_ (handleExceptions . go) . autoUpdatable
   where
     go package = getAndLogLatest package
-        >>= mapM_ (checkUpdateAvailability package)
+        >>= mapM_ checkUpdateAvailability
         >> liftIO (putStrLn "")
 
-getAndLogLatest :: Package -> SlackBuilderT (Maybe Text)
-getAndLogLatest Package{ latest = Package.Updater{ detectLatest }, name }
-    = liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
-    >> detectLatest
-
-checkUpdateAvailability :: Package -> Text -> SlackBuilderT (Maybe PackageInfo)
-checkUpdateAvailability Package{..} version = do
-    let packagePath = Text.unpack category </> Text.unpack name </> (Text.unpack name <.> "info")
-    repository' <- SlackBuilderT $ asks repository
-    infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
-
-    case parse parseInfoFile packagePath infoContents of
-        Right parsedInfoFile
-            | version == getField @"version" parsedInfoFile ->
-                liftIO $ do
-                    setSGR [SetColor Foreground Dull Green]
-                    Text.IO.putStrLn
-                        $ name <> " is up to date (Version " <> version <> ")."
-                    setSGR [Reset]
-                    pure Nothing
-            | otherwise ->
-                liftIO $ do
-                    setSGR [SetColor Foreground Dull Yellow]
-                    Text.IO.putStrLn
-                        $ "A new version of "
-                        <> name <> " " <> getField @"version" parsedInfoFile
-                        <> " is available (" <> version <> ")."
-                    setSGR [Reset]
-                    pure $ Just parsedInfoFile
-        Left errorBundle -> liftIO (putStr $ errorBundlePretty errorBundle)
-            >> pure Nothing
-
-updatePackageIfRequired :: Package -> Text -> SlackBuilderT ()
-updatePackageIfRequired package version
-    = checkUpdateAvailability package version
-    >>= mapM_ (updatePackage package version)
-
-updateDownload :: Package -> Package.Updater -> SlackBuilderT (Package.Download, Text)
-updateDownload Package{..} Package.Updater{..} = do
-    latestDownloadVersion <- fromJust <$> detectLatest
-    result <- getVersion (Text.pack $ Text.unpack category </> Text.unpack name) latestDownloadVersion
-    pure (result, latestDownloadVersion)
-
-cloneFromGit :: URI -> Text -> Text -> Text -> SlackBuilderT Package.Download
-cloneFromGit repo tagPrefix packagePath version = do
-    repository' <- SlackBuilderT $ asks repository
-    let downloadFileName = URI.unRText
-            $ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo
-        relativeTarball = Text.unpack packagePath
-            </> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version)
-        tarball = repository' </> relativeTarball
-        name' = Text.pack (takeBaseName $ Text.unpack packagePath)
-    checksum <- clone (URI.render repo) (Text.pack tarball) tagPrefix
-    uploadCommand (Text.pack relativeTarball) ("/" <> name')
-    (flip . flip Package.Download) (fromJust checksum) False
-        <$> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
-
-downloadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
-downloadWithTemplate downloadTemplate packagePath version = do
-    repository' <- SlackBuilderT $ asks repository
-    uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
-    let downloadFileName = URI.unRText
-            $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
-        relativeTarball = packagePath <> "/" <> downloadFileName
-        tarball = repository' </> Text.unpack relativeTarball
-    checksum <- fromJust <$> download uri' tarball
-    pure $ Package.Download uri' checksum False
-
-reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download
-reuploadWithTemplate downloadTemplate commands packagePath version = do
-    Package.Download{ download = uri', md5sum = checksum } <- downloadWithTemplate downloadTemplate packagePath version
-    let downloadFileName = URI.unRText
-            $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
-        relativeTarball = packagePath <> "/" <> downloadFileName
-    download' <- handleReupload relativeTarball downloadFileName
-
-    pure $ Package.Download download' checksum False
-  where
-    name' = Text.pack $ takeBaseName $ Text.unpack packagePath
-    handleReupload relativeTarball downloadFileName = do
-        repository' <- SlackBuilderT $ asks repository
-        case commands of
-            [] -> uploadTarball relativeTarball downloadFileName
-            _ ->
-                let tarballPath = repository' </> Text.unpack relativeTarball
-                    packedDirectory = takeBaseName $ dropExtension tarballPath
-                 in liftIO (callProcess "tar" ["xvf", tarballPath])
-                >> liftIO (traverse (defaultCreateProcess packedDirectory) commands)
-                >> liftIO (callProcess "tar" ["Jcvf", tarballPath, packedDirectory])
-                >> uploadTarball relativeTarball downloadFileName
-    uploadTarball relativeTarball downloadFileName
-        = liftIO (putStrLn $ "Upload the source tarball " <> Text.unpack relativeTarball)
-        >> uploadCommand relativeTarball ("/" <> name')
-        >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
-    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
-            }
-
-renderAndDownload :: Package -> Text -> SlackBuilderT Package.Download
-renderAndDownload Package{..} version = do
-    let packagePath = category <> "/" <> name
-        Package.Updater _ getVersion = latest
-
-    getVersion packagePath version
-
-updatePackage :: Package -> Text -> PackageInfo -> SlackBuilderT ()
-updatePackage package@Package{..} version info = do
-    let packagePath = category <> "/" <> name
-
-    repository' <- SlackBuilderT $ asks repository
-    mainDownload <- renderAndDownload package version
-    moreDownloads <- traverse (updateDownload package) downloaders
-    let allDownloads = mainDownload : toList (fst <$> moreDownloads)
-    let infoFilePath = repository' </> Text.unpack packagePath
-            </> (Text.unpack name <.> "info")
-        package' = info
-            { version = version
-            , downloads = getField @"download" <$> allDownloads
-            , checksums = getField @"md5sum" <$> allDownloads
-            }
-    liftIO $ Text.IO.writeFile infoFilePath $ generate package'
-    updateSlackBuildVersion packagePath version $ snd <$> moreDownloads
-
-    commit packagePath version
-
-findCategory :: FilePath -> IO [FilePath]
-findCategory currentDirectory = do
-    contents <- liftIO $ listDirectory currentDirectory
-    case find (isSuffixOf ".info") contents of
-        Just _ -> pure [currentDirectory]
-        Nothing -> do
-            let contents' = (currentDirectory </>) <$> filter (not . isPrefixOf ".") contents
-            directories <- filterM doesDirectoryExist contents'
-            subCategories <- traverse findCategory directories
-            pure $ concat subCategories
-
 main :: IO ()
-main = do
-    programCommand <- execParser slackBuilderParser
-    settings <- Toml.decodeFile settingsCodec "config/config.toml"
-    latestVersion <- flip runReaderT settings
+main = execParser slackBuilderParser
+    >>= handleExceptions . withCommandLine
+  where
+    withCommandLine programCommand = do
+        settingsResult <- Toml.decodeFileEither settingsCodec configurationFile
+        case settingsResult of
+            Right settings -> flip runReaderT settings
                 $ runSlackBuilderT
                 $ executeCommand programCommand
-
-    maybe (pure ()) Text.IO.putStrLn latestVersion
-  where
+            Left settingsErrors
+                -> setSGR [SetColor Foreground Dull Red]
+                >> putStrLn (configurationFile <> " parsing failed.")
+                >> setSGR [Reset]
+                >> Text.putStr (Toml.prettyTomlDecodeErrors settingsErrors)
+    configurationFile = "config/config.toml"
     executeCommand = \case
-        CategoryCommand _packageName -> do
-            repository' <- SlackBuilderT $ asks repository
-            categories <- liftIO $ findCategory repository'
-            liftIO $ print $ splitFileName . makeRelative repository' <$> categories
-            pure Nothing
-        CheckCommand -> check >> pure Nothing
-        Up2DateCommand -> up2Date >> pure Nothing
+        CheckCommand -> check
+        Up2DateCommand packageName -> up2Date packageName

src/SlackBuilder/CommandLine.hs

@@ -1,8 +1,10 @@
+{- 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/. -}
+
+-- | Command line parser.
 module SlackBuilder.CommandLine
-    ( GhArguments(..)
-    , SlackBuilderCommand(..)
-    , PackagistArguments(..)
-    , TextArguments(..)
+    ( SlackBuilderCommand(..)
     , slackBuilderParser
     ) where
 
@@ -12,44 +14,30 @@ import Options.Applicative
     , ParserInfo(..)
     , metavar
     , argument
+    , helper
     , str
     , info
     , fullDesc
     , subparser
-    , command,
+    , command
+    , optional, progDesc
     )
 
 data SlackBuilderCommand
-    = CategoryCommand Text
-    | CheckCommand
-    | Up2DateCommand
-
-data PackagistArguments = PackagistArguments
-    { vendor :: Text
-    , name :: Text
-    } deriving (Eq, Show)
-
-data GhArguments = GhArguments
-    { owner :: Text
-    , name :: Text
-    , transform :: Maybe Text
-    } deriving (Eq, Show)
-
-data TextArguments = TextArguments
-    { versionPicker :: Text -> Text
-    , textURL :: Text
-    }
+    = CheckCommand
+    | Up2DateCommand (Maybe Text)
 
 slackBuilderParser :: ParserInfo SlackBuilderCommand
-slackBuilderParser = info slackBuilderCommand fullDesc
+slackBuilderParser = info (helper <*> slackBuilderCommand) fullDesc
 
 slackBuilderCommand :: Parser SlackBuilderCommand
 slackBuilderCommand = subparser
-    $ command "category" (info categoryCommand mempty)
-    <> command "check" (info checkCommand mempty)
-    <> command "up2date" (info up2DateCommand mempty)
+    $ command "check" checkCommand
+    <> command "up2date" up2DateCommand
   where
-    categoryCommand = CategoryCommand
-        <$> argument str (metavar "PKGNAM")
-    checkCommand = pure CheckCommand
-    up2DateCommand = pure Up2DateCommand
+    checkCommand = info checkP $ progDesc "Check all configured slackbuilds for updates"
+    checkP = pure CheckCommand
+    up2DateP = Up2DateCommand
+        <$> optional (argument str (metavar "PKGNAM"))
+    up2DateCommand = info up2DateP
+        $ progDesc "Update a single or multiple slackbuild in the configured repository"

src/SlackBuilder/Update.hs

@@ -0,0 +1,333 @@
+{- 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

src/SlackBuilder/Updater.hs

@@ -1,158 +0,0 @@
-module SlackBuilder.Updater
-    ( latestGitHub
-    , latestPackagist
-    , latestText
-    ) where
-
-import SlackBuilder.Config
-import qualified Data.Aeson as Aeson
-import Data.Aeson ((.:))
-import Data.Aeson.TH (defaultOptions, deriveJSON)
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text.Encoding
-import Data.Vector (Vector, (!?))
-import qualified Data.Vector as Vector
-import Network.HTTP.Req
-    ( header
-    , runReq
-    , defaultHttpConfig
-    , req
-    , GET(..)
-    , https
-    , jsonResponse
-    , NoReqBody(..)
-    , (/:)
-    , responseBody
-    , useHttpsURI
-    , bsResponse
-    , POST(..)
-    , ReqBodyJson(..)
-    )
-import Text.URI (mkURI)
-import SlackBuilder.CommandLine
-import SlackBuilder.Trans
-import qualified Data.Aeson.KeyMap as KeyMap
-import GHC.Records (HasField(..))
-import Control.Monad.Trans.Reader (asks)
-import Control.Monad.IO.Class (MonadIO(..))
-
-newtype PackagistPackage = PackagistPackage
-    { version :: Text
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''PackagistPackage)
-
-newtype PackagistResponse = PackagistResponse
-    { packages :: HashMap Text (Vector PackagistPackage)
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''PackagistResponse)
-
-newtype GhRefNode = GhRefNode
-    { name :: Text
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''GhRefNode)
-
-newtype GhRef = GhRef
-    { nodes :: Vector GhRefNode
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''GhRef)
-
-newtype GhRepository = GhRepository
-    { refs :: GhRef
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''GhRepository)
-
-newtype GhData = GhData
-    { repository :: GhRepository
-    } deriving (Eq, Show)
-
-instance Aeson.FromJSON GhData where
-    parseJSON (Aeson.Object keyMap)
-        | Just data' <- KeyMap.lookup "data" keyMap =
-            GhData <$> Aeson.withObject "GhData" (.: "repository") data'
-    parseJSON _ = fail "data key not found in the response"
-
-data GhVariables = GhVariables
-    { name :: Text
-    , owner :: Text
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''GhVariables)
-
-data GhQuery = GhQuery
-    { query :: Text
-    , variables :: GhVariables
-    } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''GhQuery)
-
-latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text)
-latestPackagist PackagistArguments{..} = do
-    packagistResponse <- runReq defaultHttpConfig $
-        let uri = https "repo.packagist.org" /: "p2"
-                /: vendor
-                /: name <> ".json"
-         in req GET uri NoReqBody jsonResponse mempty
-    let packagistPackages = packages $ responseBody packagistResponse
-        fullName = Text.intercalate "/" [vendor, name]
-
-    pure $ HashMap.lookup fullName packagistPackages
-        >>= fmap (version . fst) . Vector.uncons
-
-latestText :: TextArguments -> SlackBuilderT (Maybe Text)
-latestText TextArguments{..} = do
-    uri <- liftIO $ useHttpsURI <$> mkURI textURL
-    packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri
-
-    pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody
-        <$> packagistResponse
-  where
-    go uri = req GET uri NoReqBody bsResponse mempty
-
-latestGitHub
-    :: GhArguments
-    -> (Text -> Maybe Text)
-    -> SlackBuilderT (Maybe Text)
-latestGitHub GhArguments{..} versionTransform = do
-    ghToken' <- SlackBuilderT $ asks ghToken
-    ghResponse <- runReq defaultHttpConfig $
-        let uri = https "api.github.com" /: "graphql"
-            query = GhQuery
-                {  query = githubQuery
-                , variables = GhVariables
-                    { owner = owner
-                    , name = name
-                    }
-                }
-            authorizationHeader = header "authorization"
-                $ Text.Encoding.encodeUtf8
-                $ "Bearer " <> ghToken'
-         in req POST uri (ReqBodyJson query) jsonResponse
-            $ authorizationHeader <> header "User-Agent" "SlackBuilder"
-    let ghNodes = nodes
-            $ refs
-            $ (getField @"repository" :: GhData -> GhRepository)
-            $ responseBody ghResponse
-        refs' = Vector.reverse
-            $ Vector.catMaybes
-            $ versionTransform . getField @"name" <$> ghNodes
-    pure $ refs' !? 0
-  where
-    githubQuery =
-        "query ($name: String!, $owner: String!) {\n\
-        \  repository(name: $name, owner: $owner) {\n\
-        \    refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\
-        \      nodes {\n\
-        \        id,\n\
-        \        name\n\
-        \      }\n\
-        \    }\n\
-        \  }\n\
-        \}"

tests/SlackBuilder/InfoSpec.hs

@@ -1,3 +1,7 @@
+{- 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.InfoSpec
     ( spec
     ) where
@@ -61,13 +65,57 @@ spec = do
              in parseInfoFile' infoDownload1 `parseSatisfies` condition
 
         it "translates checksum characters into the binary format" $
-            let expected = "0102030405060708090a0b0c0d0e0f10"
-                condition = (== expected) . show . head . checksums
+            let expected = ["0102030405060708090a0b0c0d0e0f10"]
+                condition = (== expected) . fmap show . checksums
              in parseInfoFile' infoDownload1 `parseSatisfies` condition
 
         it "accepts an empty downloads list" $
             parseInfoFile' `shouldSucceedOn` infoDownload0
 
+        it "parses a package name with a dot" $
+            let given =
+                    "PRGNAM=\"pkgnam.yaml\"\n\
+                    \VERSION=\"1.2.3\"\n\
+                    \HOMEPAGE=\"homepage\"\n\
+                    \DOWNLOAD=\"https://dlackware.com/download.tar.gz\"\n\
+                    \MD5SUM=\"0102030405060708090a0b0c0d0e0f10\"\n\
+                    \DOWNLOAD_x86_64=\"\"\n\
+                    \MD5SUM_x86_64=\"\"\n\
+                    \REQUIRES=\"\"\n\
+                    \MAINTAINER=\"Z\"\n\
+                    \EMAIL=\"test@example.com\"\n"
+             in parseInfoFile' `shouldSucceedOn` given
+
+        it "parses to downloads in a single line" $
+            let given =
+                    "PRGNAM=\"pkgnam.yaml\"\n\
+                    \VERSION=\"1.2.3\"\n\
+                    \HOMEPAGE=\"homepage\"\n\
+                    \DOWNLOAD=\"https://dlackware.com/download1.tar.gz https://dlackware.com/download2.tar.gz\"\n\
+                    \MD5SUM=\"0102030405060708090a0b0c0d0e0f10 0102030405060708090a0b0c0d0e0f11\"\n\
+                    \DOWNLOAD_x86_64=\"\"\n\
+                    \MD5SUM_x86_64=\"\"\n\
+                    \REQUIRES=\"\"\n\
+                    \MAINTAINER=\"Z\"\n\
+                    \EMAIL=\"test@example.com\"\n"
+             in parseInfoFile' `shouldSucceedOn` given
+
+        it "parses downloads continuing on the next line" $
+            let given =
+                    "PRGNAM=\"pkgnam.yaml\"\n\
+                    \VERSION=\"1.2.3\"\n\
+                    \HOMEPAGE=\"homepage\"\n\
+                    \DOWNLOAD=\"https://dlackware.com/download1.tar.gz \\\n\
+                    \           https://dlackware.com/download2.tar.gz\"\n\
+                    \MD5SUM=\"0102030405060708090a0b0c0d0e0f10 \\\n\
+                    \         0102030405060708090a0b0c0d0e0f11\"\n\
+                    \DOWNLOAD_x86_64=\"\"\n\
+                    \MD5SUM_x86_64=\"\"\n\
+                    \REQUIRES=\"\"\n\
+                    \MAINTAINER=\"Z\"\n\
+                    \EMAIL=\"test@example.com\"\n"
+             in parseInfoFile' `shouldSucceedOn` given
+
     describe "generate" $ do
         it "generates an .info file without downloads" $
             let given =  PackageInfo "pkgnam" "1.2.3" "homepage" [] [] [] [] [] "Z" "test@example.com"
@@ -100,55 +148,3 @@ spec = do
                 given = PackageInfo
                     "pkgnam" "1.2.3" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
              in generate given `shouldBe` Text.decodeUtf8 infoDownload1
-
-    describe "updateDownloadVersion" $ do
-        it "replaces the version" $
-            let downloads' = maybeToList
-                    $ mkURI "https://dlackware.com/download-1.2.3.tar.gz"
-                testPackage = PackageInfo
-                    "pkgnam" "1.2.3" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
-                expected = maybeToList
-                    $ mkURI "https://dlackware.com/download-2.3.4.tar.gz"
-                actual = updateDownloadVersion testPackage "2.3.4" Nothing
-             in actual `shouldBe` expected
-
-        it "updates the major version" $
-            let downloads' = maybeToList
-                    $ mkURI "https://dlackware.com/1.2/download.tar.gz"
-                testPackage = PackageInfo
-                    "pkgnam" "1.2.3" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
-                expected = maybeToList
-                    $ mkURI "https://dlackware.com/2.3/download.tar.gz"
-                actual = updateDownloadVersion testPackage "2.3.4" Nothing
-             in actual `shouldBe` expected
-
-        it "updates gnome version" $
-            let downloads' = maybeToList
-                    $ mkURI "https://download.gnome.org/core/3.36/3.36.0/sources/gnome-calendar-3.36.0.tar.xz"
-                testPackage = PackageInfo "gnome-calendar" "3.36.0" "https://wiki.gnome.org/Core/Calendar"
-                    downloads' checksumSample [] [] [] "Z" "test@example.com"
-                expected = maybeToList
-                    $ mkURI "https://download.gnome.org/core/3.36/3.36.4/sources/gnome-calendar-3.36.2.tar.xz"
-                actual = updateDownloadVersion testPackage "3.36.2" $ Just "3.36.4"
-             in actual `shouldBe` expected
-
-        it "updates versions without a patch number" $
-            let downloads' = maybeToList
-                    $ mkURI "https://dlackware.com/gnome-contacts-3.36.tar.xz"
-                testPackage = PackageInfo
-                    "gnome-contacts" "3.36" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
-                expected = maybeToList
-                    $ mkURI "https://dlackware.com/gnome-contacts-3.36.2.tar.xz"
-                actual = updateDownloadVersion testPackage "3.36.2" Nothing
-             in actual `shouldBe` expected
-
-    describe "update" $
-        it "replaces the version" $
-            let downloads' = maybeToList
-                    $ mkURI "https://dlackware.com/1.2/download.tar.gz"
-                testPackage = PackageInfo
-                    "pkgnam" "1.2.3" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
-                expected = PackageInfo
-                    "pkgnam" "2.3.4" "homepage" downloads' checksumSample [] [] [] "Z" "test@example.com"
-                given = update testPackage "2.3.4" downloads' checksumSample
-             in given `shouldBe` expected

tests/SlackBuilder/LatestVersionCheckSpec.hs

@@ -0,0 +1,53 @@
+{- 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.LatestVersionCheckSpec
+    ( spec
+    ) where
+
+import SlackBuilder.LatestVersionCheck
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec = do
+    describe "match" $ do
+        it "matches an exact tag prefixed with v" $
+            let expected = Just "2.6.0"
+                actual = match "(v)2.6.0" "v2.6.0"
+             in actual `shouldBe` expected
+
+        it "matches a glob pattern prefixed with v" $
+            let expected = Just "2.6.0"
+                actual = match "(v)*" "v2.6.0"
+             in actual `shouldBe` expected
+
+        it "matches digits" $
+            let expected = Just "2.6.0"
+                actual = match "(v)2.6.\\d" "v2.6.0"
+             in actual `shouldBe` expected
+
+        it "matches digits and dots" $
+            let expected = Just "2.6.0"
+                actual = match "(v)\\." "v2.6.0"
+             in actual `shouldBe` expected
+
+        it "rejects unexpected suffix" $
+            let expected = Nothing
+                actual = match "(v)\\." "v2.6.0-rc1"
+             in actual `shouldBe` expected
+
+        it "rejects remaining umatched characters" $
+            let expected = Nothing
+                actual = match "2.6.0-rc1" "2.6.0"
+             in actual `shouldBe` expected
+
+        it "consumes the last token matching nothing" $
+            let expected = Just "abc"
+                actual = match "abc\\d\\d" "abc"
+             in actual `shouldBe` expected
+
+        it "matches at least one digit" $
+            let expected = Nothing
+                actual = match "1.\\D.3" "1..3"
+             in actual `shouldBe` expected

tests/SlackBuilder/PackageSpec.hs

@@ -1,8 +1,11 @@
+{- 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.PackageSpec
     ( spec
     ) where 
 
-import Data.List.NonEmpty (NonEmpty(..))
 import SlackBuilder.Package
 import Test.Hspec (Spec, describe, it, shouldBe)
 import Text.URI.QQ (uri)
@@ -11,17 +14,13 @@ spec :: Spec
 spec = do
     describe "renderDownloadWithVersion" $ do
         it "renders text as URL" $
-            let given = DownloadTemplate
-                    $ pure
-                    $ StaticPlaceholder "https://example.com"
+            let given = DownloadTemplate "https://example.com"
                 actual = renderDownloadWithVersion given "1.2"
                 expected = Just [uri|https://example.com|]
              in actual `shouldBe` expected
 
         it "renders the components in order" $
-            let given = DownloadTemplate
-                    $ StaticPlaceholder "https://example.com/"
-                    :| [VersionPlaceholder, StaticPlaceholder "/segment"]
+            let given = DownloadTemplate "https://example.com/{version}/segment"
                 actual = renderDownloadWithVersion given "1.2"
                 expected = Just [uri|https://example.com/1.2/segment|]
              in actual `shouldBe` expected