Find the package category automatically

lib/SlackBuilder/Package.hs

@@ -6,7 +6,8 @@ module SlackBuilder.Package
     ( DownloadPlaceholder(..)
     , Download(..)
     , DownloadTemplate(..)
-    , Package(..)
+    , PackageDescription(..)
+    , PackageUpdateData(..)
     , Maintainer(..)
     , Updater(..)
     , renderDownloadWithVersion
@@ -23,13 +24,18 @@ 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

src/Main.hs

@@ -12,7 +12,7 @@ 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 Data.Maybe (fromJust, listToMaybe)
 import qualified Data.Map as Map
 import Options.Applicative (execParser)
 import SlackBuilder.CommandLine
@@ -26,7 +26,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.IO as Text.IO
 import Control.Monad.Trans.Reader (ReaderT(..), asks)
 import SlackBuilder.Download
-import SlackBuilder.Package (Package(..))
+import SlackBuilder.Package (PackageDescription(..), PackageUpdateData(..))
 import qualified SlackBuilder.Package as Package
 import Text.URI (URI(..), mkURI)
 import Text.URI.QQ (uri)
@@ -56,9 +56,9 @@ import Control.Monad (filterM)
 import Data.List (isPrefixOf, isSuffixOf, partition)
 import Conduit (runConduitRes, (.|), sourceFile)
 
-autoUpdatable :: [Package]
+autoUpdatable :: [PackageDescription]
 autoUpdatable =
-    [ Package
+    [ PackageDescription
         { latest =
             let ghArguments = PackageOwner{ owner = "universal-ctags", name = "ctags" }
                 templateTail =
@@ -75,11 +75,10 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = False
                 }
-        , category = "development"
         , name = "universal-ctags"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let packagistArguments = PackageOwner{ owner = "composer", name = "composer" }
                 template = Package.DownloadTemplate
@@ -90,11 +89,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = False
                 }
-        , category = "development"
         , name = "composer"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "jitsi"
@@ -109,11 +107,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = True
                 }
-        , category = "network"
         , name = "jitsi-meet-desktop"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "php"
@@ -132,11 +129,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = False
                 }
-        , category = "development"
         , name = "php82"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "kovidgoyal"
@@ -156,11 +152,10 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template [RawCommand "go" ["mod", "vendor"]]
                 , is64 = False
                 }
-        , category = "system"
         , name = "kitty"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "rdiff-backup"
@@ -177,11 +172,10 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = False
                 }
-        , category = "system"
         , name = "rdiff-backup"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let needle = "Linux—"
                 textArguments = TextArguments
@@ -199,11 +193,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = True
                 }
-        , category = "network"
         , name = "webex"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "librsync"
@@ -220,11 +213,10 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = True
                 }
-        , category = "libraries"
         , name = "librsync"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let textArguments = TextArguments
                     { textURL = "https://downloads.dlang.org/releases/LATEST"
@@ -241,11 +233,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = False
                 }
-        , category = "development"
         , name = "dmd"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let textArguments = TextArguments
                     { textURL = "https://downloads.dlang.org/releases/LATEST"
@@ -259,7 +250,6 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = False
                 }
-        , category = "development"
         , name = "d-tools"
         , downloaders =
             let dubArguments = PackageOwner{ owner = "dlang", name = "dub" }
@@ -302,24 +292,31 @@ up2Date = \case
         | otherwise -> throwM $ UpdaterNotFound packageName
   where
     go package = getAndLogLatest package
-        >>= mapM_ (updatePackageIfRequired package)
+        >>= mapM_ updatePackageIfRequired
         >> liftIO (putStrLn "")
 
 check :: SlackBuilderT ()
 check = for_ autoUpdatable go
   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
+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 <- liftIO $ fmap Text.pack . listToMaybe
+        <$> findCategory (Text.unpack name)
+    pure $ PackageUpdateData description
+        <$> category
+        <*> detectedVersion
 
-checkUpdateAvailability :: Package -> Text -> SlackBuilderT (Maybe PackageInfo)
-checkUpdateAvailability Package{..} version = do
-    let packagePath = Text.unpack category </> Text.unpack name </> (Text.unpack name <.> "info")
+checkUpdateAvailability :: PackageUpdateData -> SlackBuilderT (Maybe PackageInfo)
+checkUpdateAvailability PackageUpdateData{..} = do
+    let name' = Text.unpack $ getField @"name" description
+        packagePath = Text.unpack category </> name' </> (name' <.> "info")
     repository' <- SlackBuilderT $ asks repository
     infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
 
@@ -329,7 +326,7 @@ checkUpdateAvailability Package{..} version = do
                 liftIO $ do
                     setSGR [SetColor Foreground Dull Green]
                     Text.IO.putStrLn
-                        $ name <> " is up to date (Version " <> version <> ")."
+                        $ getField @"name" description <> " is up to date (Version " <> version <> ")."
                     setSGR [Reset]
                     pure Nothing
             | otherwise ->
@@ -337,7 +334,8 @@ checkUpdateAvailability Package{..} version = do
                     setSGR [SetColor Foreground Dull Yellow]
                     Text.IO.putStr
                         $ "A new version of "
-                        <> name <> " " <> getField @"version" parsedInfoFile
+                        <> getField @"name" description
+                        <> " " <> getField @"version" parsedInfoFile
                         <> " is available (" <> version <> ")."
                     setSGR [Reset]
                     putStrLn ""
@@ -345,10 +343,10 @@ checkUpdateAvailability Package{..} version = do
         Left errorBundle -> liftIO (putStr $ errorBundlePretty errorBundle)
             >> pure Nothing
 
-updatePackageIfRequired :: Package -> Text -> SlackBuilderT ()
-updatePackageIfRequired package version
-    = checkUpdateAvailability package version
-    >>= mapM_ (updatePackage package version)
+updatePackageIfRequired :: PackageUpdateData -> SlackBuilderT ()
+updatePackageIfRequired updateData
+    = checkUpdateAvailability updateData
+    >>= mapM_ (updatePackage updateData)
 
 data DownloadUpdated = DownloadUpdated
     { result :: Package.Download
@@ -443,19 +441,21 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
             , child_group = Nothing
             }
 
-updatePackage :: Package -> Text -> PackageInfo -> SlackBuilderT ()
-updatePackage Package{..} version info = do
-    let packagePath = category <> "/" <> name
+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) downloaders
+    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 name <.> "info")
+            </> (Text.unpack (getField @"name" description) <.> "info")
         package' = info
             { version = version
             , downloads = getField @"download" . fst <$> allDownloads