diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 136 |
1 files changed, 76 insertions, 60 deletions
diff --git a/src/Main.hs b/src/Main.hs index 24f52c6..900891e 100644 --- a/src/Main.hs +++ b/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 |