Support modifying reuploaded tarballs

1 files changed, 76 insertions, 24 deletions

diff --git a/app/Main.hs b/app/Main.hs
index faf350c..ec9f310 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -15,19 +15,26 @@ import qualified Toml
 import qualified Data.ByteString as ByteString
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text.Encoding
 import qualified Data.Text.IO as Text.IO
 import Control.Monad.Trans.Reader (ReaderT(..), asks)
 import SlackBuilder.Download
 import SlackBuilder.Package (Package(..))
 import qualified SlackBuilder.Package as Package
 import Text.URI (mkURI)
-import Text.URI.QQ (uri)
 import Data.Foldable (for_)
 import qualified Text.URI as URI
-import System.FilePath ((</>), (<.>))
+import System.FilePath ((</>), (<.>), dropExtension, takeBaseName)
 import SlackBuilder.Info
 import Text.Megaparsec (parse, errorBundlePretty)
+import GHC.Records (HasField(..))
+import System.Process
+    ( CmdSpec(..)
+    , CreateProcess(..)
+    , StdStream(..)
+    , callProcess
+    , withCreateProcess
+    , waitForProcess
+    )
 
 autoUpdatable :: [Package]
 autoUpdatable =
@@ -47,9 +54,7 @@ autoUpdatable =
              in Package.Updater latest' template
         , category = "development"
         , name = "universal-ctags"
-        , homepage = [uri|https://ctags.io/|]
-        , requires = pure "%README%"
-        , reupload = True
+        , reupload = Just []
         }
     , Package
         { latest =
@@ -61,9 +66,7 @@ autoUpdatable =
              in Package.Updater latest' template
         , category = "development"
         , name = "composer"
-        , homepage = [uri|https://getcomposer.org/|]
-        , requires = mempty
-        , reupload = False
+        , reupload = Nothing
         }
     , Package
         { latest =
@@ -80,9 +83,7 @@ autoUpdatable =
              in Package.Updater latest' template
         , category = "network"
         , name = "jitsi-meet-desktop"
-        , homepage = [uri|https://jitsi.org/|]
-        , requires = mempty
-        , reupload = False
+        , reupload = Nothing
         }
     , Package
         { latest =
@@ -102,9 +103,29 @@ autoUpdatable =
              in Package.Updater latest' template
         , category = "development"
         , name = "php82"
-        , homepage = [uri|https://www.php.net/|]
-        , requires = ["postgresql"]
-        , reupload = False
+        , reupload = Nothing
+        }
+    , 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' template
+        , category = "system"
+        , name = "kitty"
+        , reupload = Just [RawCommand "go" ["mod", "vendor"]]
         }
     ]
 
@@ -123,7 +144,11 @@ updatePackageIfRequired package@Package{..} version = do
     infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
 
     case parse parseInfoFile packagePath infoContents of
-        Right parsedInfoFile -> updatePackage package parsedInfoFile version
+        Right parsedInfoFile
+            | version == getField @"version" parsedInfoFile ->
+                liftIO $ Text.IO.putStrLn
+                    $ name <> " is up to date (Version " <> version <> ")."
+            | otherwise -> updatePackage package parsedInfoFile version
         Left errorBundle -> liftIO $ putStr $ errorBundlePretty errorBundle
 
 updatePackage :: Package -> PackageInfo -> Text -> SlackBuilderT ()
@@ -145,8 +170,6 @@ updatePackage Package{..} info version = do
             </> (Text.unpack name <.> "info")
         package' = info
             { version = version
-            , requires = Text.Encoding.encodeUtf8 <$> requires
-            , homepage = URI.render homepage
             , downloads = [download']
             , checksums = [checksum]
             }
@@ -156,12 +179,41 @@ updatePackage Package{..} info version = do
 
     commit packagePath version
   where
-    handleReupload uri' relativeTarball downloadFileName
-        | reupload = 
-            liftIO (putStrLn $ "Upload the source tarball " <> Text.unpack relativeTarball)
-            >> uploadCommand relativeTarball ("/" <> name)
-            >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name <> "/" <> downloadFileName)
-        | otherwise = pure uri'
+    handleReupload uri' relativeTarball downloadFileName = do
+        repository' <- SlackBuilderT $ asks repository
+        case reupload of
+            Just [] -> uploadTarball relativeTarball downloadFileName
+            Just commands ->
+                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
+            Nothing -> pure uri'
+    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
+            }
 
 main :: IO ()
 main = do