diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs index efea720..470ce5a 100644 --- a/lib/SlackBuilder/Download.hs +++ b/lib/SlackBuilder/Download.hs @@ -3,7 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} module SlackBuilder.Download - ( clone + ( cloneAndUpload , cloneAndArchive , commit , download @@ -25,7 +25,7 @@ import SlackBuilder.Trans import Control.Monad.Trans.Reader (asks) import Control.Monad.IO.Class (MonadIO(liftIO)) import System.IO (IOMode(..), withFile) -import System.FilePath ((), (<.>), takeBaseName, splitPath, joinPath) +import System.FilePath ((), (<.>), takeFileName, takeDirectory) import System.Process ( CreateProcess(..) , StdStream(..) @@ -130,46 +130,50 @@ remoteFileExists url = hostedSources url } go uri = req HEAD uri NoReqBody ignoreResponse mempty -uploadCommand :: Text -> Text -> SlackBuilderT () +uploadCommand :: FilePath -> Text -> SlackBuilderT () uploadCommand localPath remotePath' = do remoteRoot <- SlackBuilderT $ asks remotePath - repository' <- SlackBuilderT $ asks repository + localPathFromRepository <- relativeToRepository localPath liftIO $ callProcess "scp" - [ repository' Text.unpack localPath + [ localPathFromRepository , Text.unpack $ remoteRoot <> remotePath' ] -cloneAndArchive :: Text -> Text -> FilePath -> Text -> SlackBuilderT () -cloneAndArchive repo nameVersion tarball tagPrefix = do - let (_, version) = Text.breakOnEnd "-" nameVersion - nameVersion' = Text.unpack nameVersion +cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT () +cloneAndArchive repo tarballPath tagPrefix = do + let version = snd $ Text.breakOnEnd "-" + $ Text.pack $ takeFileName tarballPath - repository' <- SlackBuilderT $ asks repository - liftIO $ callProcess "rm" ["-rf", nameVersion'] - - liftIO $ callProcess "git" ["clone", Text.unpack repo, nameVersion'] - liftIO $ callProcess "git" - [ "-C" - , nameVersion' - , "checkout" - , Text.unpack $ tagPrefix <> version - ] - liftIO $ callProcess "git" - [ "-C" - , nameVersion' - , "submodule" - , "update" - , "--init" - , "--recursive" - ] - - liftIO $ callProcess "tar" - [ "Jcvf" - , repository' tarball - , nameVersion' - ] - liftIO $ callProcess "rm" ["-rf", nameVersion'] + repositoryTarballPath <- relativeToRepository tarballPath + repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz" + liftIO + $ callProcess "rm" ["-rf", repositoryTarballPath] + >> callProcess "git" + [ "clone" + , Text.unpack repo + , repositoryTarballPath + ] + >> callProcess "git" + [ "-C" + , repositoryTarballPath + , "checkout" + , Text.unpack $ tagPrefix <> version + ] + >> callProcess "git" + [ "-C" + , repositoryTarballPath + , "submodule" + , "update" + , "--init" + , "--recursive" + ] + >> callProcess "tar" + ["Jcvf" + , repositoryArchivePath + , repositoryTarballPath + ] + >> callProcess "rm" ["-rf", repositoryTarballPath] responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m () responseBodySource = bodyReaderSource . responseBody @@ -193,20 +197,19 @@ download uri target = traverse (runReq defaultHttpConfig . go . fst) $ responseBodySource response .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash) -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 +cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (Maybe (URI, Digest MD5)) +cloneAndUpload repo tarballPath tagPrefix = do + localPath <- relativeToRepository $ tarballPath <.> "tar.xz" + let packageName = takeFileName $ takeDirectory tarballPath + remoteArchivePath = Text.cons '/' $ Text.pack + $ packageName takeFileName tarballPath <.> "tar.xz" + remoteResultURI <- hostedSources remoteArchivePath + remoteFileExists' <- remoteFileExists remoteArchivePath if remoteFileExists' - then - hostedSources remotePath >>= flip download localPath + then fmap (remoteResultURI,) <$> download remoteResultURI 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 + >> uploadCommand localPath remoteArchivePath + >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,) diff --git a/lib/SlackBuilder/Trans.hs b/lib/SlackBuilder/Trans.hs index 6186c41..4ee3668 100644 --- a/lib/SlackBuilder/Trans.hs +++ b/lib/SlackBuilder/Trans.hs @@ -6,14 +6,16 @@ module SlackBuilder.Trans ( SlackBuilderException(..) , SlackBuilderT(..) + , relativeToRepository ) where -import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.Reader (ReaderT(..), asks) import Data.Text (Text) import SlackBuilder.Config import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Exception (Exception(..)) +import System.FilePath (()) newtype SlackBuilderException = UpdaterNotFound Text deriving Show @@ -24,6 +26,10 @@ 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 diff --git a/src/Main.hs b/src/Main.hs index e59cae7..a177b00 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -234,9 +234,9 @@ autoUpdatable = let dubArguments = PackageOwner{ owner = "dlang", name = "dub" } dscannerArguments = PackageOwner{ owner = "dlang-community", name = "D-Scanner" } dcdArguments = PackageOwner{ owner = "dlang-community", name = "DCD" } - latestDub = latestGitHub dubArguments pure - latestDscanner = latestGitHub dscannerArguments pure - latestDcd = latestGitHub dcdArguments pure + latestDub = latestGitHub dubArguments stableTagTransform + latestDscanner = latestGitHub dscannerArguments stableTagTransform + latestDcd = latestGitHub dcdArguments stableTagTransform dubTemplate = Package.DownloadTemplate $ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v" :| [Package.VersionPlaceholder] @@ -315,17 +315,16 @@ updateDownload Package{..} Package.Updater{..} = do 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) + (uri', checksum) <- fromJust <$> cloneAndUpload (URI.render repo) relativeTarball tagPrefix + pure $ Package.Download + { md5sum = checksum + , is64 = False + , download = uri' + } downloadWithTemplate :: Package.DownloadTemplate -> Bool -> Text -> Text -> SlackBuilderT Package.Download downloadWithTemplate downloadTemplate is64' packagePath version = do @@ -345,7 +344,7 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do let downloadFileName = URI.unRText $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri' relativeTarball = packagePath <> "/" <> downloadFileName - download' <- handleReupload relativeTarball downloadFileName + download' <- handleReupload (Text.unpack relativeTarball) downloadFileName pure $ Package.Download download' checksum False where @@ -355,14 +354,14 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do case commands of [] -> uploadTarball relativeTarball downloadFileName _ -> - let tarballPath = repository' Text.unpack relativeTarball + let tarballPath = repository' 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) + = liftIO (putStrLn $ "Upload the source tarball " <> relativeTarball) >> uploadCommand relativeTarball ("/" <> name') >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName) defaultCreateProcess cwd' cmdSpec diff --git a/src/SlackBuilder/LatestVersionCheck.hs b/src/SlackBuilder/LatestVersionCheck.hs index a66d2c7..233ea3c 100644 --- a/src/SlackBuilder/LatestVersionCheck.hs +++ b/src/SlackBuilder/LatestVersionCheck.hs @@ -46,6 +46,7 @@ import qualified Data.Aeson.KeyMap as KeyMap import GHC.Records (HasField(..)) import Control.Monad.Trans.Reader (asks) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad ((>=>)) data PackageOwner = PackageOwner { owner :: Text @@ -55,7 +56,11 @@ data PackageOwner = PackageOwner -- | Removes the leading "v" from the version string and returns the result if -- it looks like a version. stableTagTransform :: Text -> Maybe Text -stableTagTransform = Text.stripPrefix "v" +stableTagTransform = Text.stripPrefix "v" >=> checkForStable + where + checkForStable tag + | '-' `Text.elem` tag = Nothing + | otherwise = Just tag -- * Packagist