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

@@ -26,13 +26,22 @@ 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)
 import Data.Foldable (Foldable(..), for_, find)
 import qualified Text.URI as URI
-import System.FilePath ((</>), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName, takeDirectory, takeFileName)
+import System.FilePath
+    ( (</>)
+    , (<.>)
+    , dropExtension
+    , takeBaseName
+    , splitFileName
+    , takeDirectory
+    , takeFileName
+    , dropTrailingPathSeparator
+    )
 import SlackBuilder.Info
 import Text.Megaparsec (parse, errorBundlePretty)
 import GHC.Records (HasField(..))
@@ -55,10 +64,12 @@ import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory
 import Control.Monad (filterM)
 import Data.List (isPrefixOf, isSuffixOf, partition)
 import Conduit (runConduitRes, (.|), sourceFile)
+import Data.Functor ((<&>))
+import Data.Bifunctor (Bifunctor(..))
 
-autoUpdatable :: [Package]
+autoUpdatable :: [PackageDescription]
 autoUpdatable =
-    [ Package
+    [ PackageDescription
         { latest =
             let ghArguments = PackageOwner{ owner = "universal-ctags", name = "ctags" }
                 templateTail =
@@ -75,11 +86,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 +100,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = False
                 }
-        , category = "development"
         , name = "composer"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "jitsi"
@@ -109,11 +118,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 +140,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = False
                 }
-        , category = "development"
         , name = "php82"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "kovidgoyal"
@@ -156,11 +163,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 +183,10 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = False
                 }
-        , category = "system"
         , name = "rdiff-backup"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let needle = "Linux—"
                 textArguments = TextArguments
@@ -199,11 +204,10 @@ autoUpdatable =
                 , getVersion = downloadWithTemplate template
                 , is64 = True
                 }
-        , category = "network"
         , name = "webex"
         , downloaders = mempty
         }
-    , Package
+    , PackageDescription
         { latest =
             let ghArguments = PackageOwner
                     { owner = "librsync"
@@ -220,11 +224,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 +244,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 +261,6 @@ autoUpdatable =
                 , getVersion = reuploadWithTemplate template []
                 , is64 = False
                 }
-        , category = "development"
         , name = "d-tools"
         , downloaders =
             let dubArguments = PackageOwner{ owner = "dlang", name = "dub" }
@@ -302,24 +303,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 <- fmap Text.pack
+        <$> 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 +337,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 +345,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 +354,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 +452,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
@@ -469,16 +480,26 @@ updatePackage Package{..} version info = do
 
     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
+findCategory :: FilePath -> SlackBuilderT (Maybe FilePath)
+findCategory packageName = do
+    repository' <- SlackBuilderT $ asks repository
+    go repository' [] "" <&> fmap fst . find ((packageName ==) . snd)
+  where
+    go currentDirectory found accumulatedDirectory = do
+        let fullDirectory = currentDirectory </> accumulatedDirectory
+        contents <- liftIO $ listDirectory fullDirectory
+        case find (isSuffixOf ".info") contents of
+            Just _ ->
+                let result = first dropTrailingPathSeparator
+                        $ splitFileName accumulatedDirectory
+                 in pure $ result : found
+            Nothing ->
+                let accumulatedDirectories = (accumulatedDirectory </>)
+                        <$> filter (not . isPrefixOf ".") contents
+                    directoryFilter = liftIO . doesDirectoryExist
+                        . (currentDirectory </>)
+                 in filterM directoryFilter accumulatedDirectories
+                    >>= traverse (go currentDirectory found) <&> concat
 
 main :: IO ()
 main = do
@@ -491,10 +512,5 @@ main = do
     maybe (pure ()) Text.IO.putStrLn latestVersion
   where
     executeCommand = \case
-        CategoryCommand -> do
-            repository' <- SlackBuilderT $ asks repository
-            categories <- liftIO $ findCategory repository'
-            liftIO $ print $ splitFileName . makeRelative repository' <$> categories
-            pure Nothing
         CheckCommand -> check >> pure Nothing
         Up2DateCommand packageName -> up2Date packageName >> pure Nothing

src/SlackBuilder/CommandLine.hs

@@ -23,8 +23,7 @@ import Options.Applicative
     )
 
 data SlackBuilderCommand
-    = CategoryCommand
-    | CheckCommand
+    = CheckCommand
     | Up2DateCommand (Maybe Text)
 
 slackBuilderParser :: ParserInfo SlackBuilderCommand
@@ -32,11 +31,9 @@ slackBuilderParser = info slackBuilderCommand fullDesc
 
 slackBuilderCommand :: Parser SlackBuilderCommand
 slackBuilderCommand = subparser
-    $ command "category" (info categoryCommand mempty)
-    <> command "check" (info checkCommand mempty)
+    $ command "check" (info checkCommand mempty)
     <> command "up2date" (info up2DateCommand mempty)
   where
-    categoryCommand = pure CategoryCommand
     checkCommand = pure CheckCommand
     up2DateCommand = Up2DateCommand
         <$> optional (argument str (metavar "PKGNAM"))