Use consistent directory for cloning repositories

... with submodules.

2 files changed, 57 insertions, 48 deletions

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
-
-    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"
-        ]
+cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT ()
+cloneAndArchive repo tarballPath tagPrefix = do
+    let version = snd $ Text.breakOnEnd "-"
+            $ Text.pack $ takeFileName tarballPath 
 
-    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