Use consistent directory for cloning repositories

... with submodules.

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 :: Text -> FilePath -> Text -> SlackBuilderT ()
-cloneAndArchive repo nameVersion tarball tagPrefix = do
+cloneAndArchive repo tarballPath tagPrefix = do
-    let (_, version) = Text.breakOnEnd "-" nameVersion
+    let version = snd $ Text.breakOnEnd "-"
-        nameVersion' = Text.unpack nameVersion
+            $ Text.pack $ takeFileName tarballPath 
 
-    repository' <- SlackBuilderT $ asks repository
+    repositoryTarballPath <- relativeToRepository tarballPath
-    liftIO $ callProcess "rm" ["-rf", nameVersion']
+    repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
-
+    liftIO
-    liftIO $ callProcess "git" ["clone", Text.unpack repo, nameVersion']
+        $ callProcess "rm" ["-rf", repositoryTarballPath]
-    liftIO $ callProcess "git"
+        >> callProcess "git"
+            [ "clone"
+            , Text.unpack repo
+            , repositoryTarballPath
+            ]
+        >> callProcess "git"
             [ "-C"
-        , nameVersion'
+            , repositoryTarballPath
             , "checkout"
             , Text.unpack $ tagPrefix <> version
             ]
-    liftIO $ callProcess "git"
+        >> callProcess "git"
             [ "-C"
-        , nameVersion'
+            , repositoryTarballPath
             , "submodule"
             , "update"
             , "--init"
             , "--recursive"
             ]
-
+        >> callProcess "tar"
-    liftIO $ callProcess "tar"
             ["Jcvf"
-        , repository' </> tarball
+            , repositoryArchivePath
-        , nameVersion'
+            , repositoryTarballPath
             ]
-    liftIO $ callProcess "rm" ["-rf", nameVersion']
+        >> 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))
+cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (Maybe (URI, Digest MD5))
-clone repo tarball tagPrefix = do
+cloneAndUpload repo tarballPath tagPrefix = do
-    repository' <- SlackBuilderT $ asks repository
+    localPath <- relativeToRepository $ tarballPath <.> "tar.xz"
-    let tarballPath = Text.unpack tarball
+    let packageName = takeFileName $ takeDirectory tarballPath
-        nameVersion = Text.pack $ takeBaseName tarballPath
+        remoteArchivePath = Text.cons '/' $ Text.pack
-        remotePath = Text.pack $ joinPath $ ("/" :) $ drop 1 $ splitPath tarballPath
+            $ packageName </> takeFileName tarballPath <.> "tar.xz"
-        localPath = repository' </> tarballPath
+    remoteResultURI <- hostedSources remoteArchivePath
-    remoteFileExists' <- remoteFileExists remotePath
+    remoteFileExists' <- remoteFileExists remoteArchivePath
 
     if remoteFileExists'
-    then
+    then fmap (remoteResultURI,) <$> download remoteResultURI localPath
-        hostedSources remotePath >>= flip download localPath
     else
         let go = sourceFile localPath .| sinkHash
-         in cloneAndArchive repo nameVersion tarballPath tagPrefix
+         in cloneAndArchive repo tarballPath tagPrefix
-            >> uploadCommand tarball remotePath
+            >> uploadCommand localPath remoteArchivePath
-            >> liftIO (runConduitRes go) <&> Just
+            >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)

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

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
+                latestDub = latestGitHub dubArguments stableTagTransform
-                latestDscanner = latestGitHub dscannerArguments pure
+                latestDscanner = latestGitHub dscannerArguments stableTagTransform
-                latestDcd = latestGitHub dcdArguments pure
+                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
+    (uri', checksum) <- fromJust <$> cloneAndUpload (URI.render repo) relativeTarball tagPrefix
-        name' = Text.pack (takeBaseName $ Text.unpack packagePath)
+    pure $ Package.Download
-    checksum <- clone (URI.render repo) (Text.pack tarball) tagPrefix
+        { md5sum = checksum
-    uploadCommand (Text.pack relativeTarball) ("/" <> name')
+        , is64 = False
-    (flip . flip Package.Download) (fromJust checksum) False
+        , download = uri'
-        <$> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
+        }
 
 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

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