Remove the source directory after repackaing

lib/SlackBuilder/Download.hs

@@ -4,7 +4,7 @@
 
 module SlackBuilder.Download
     ( cloneAndUpload
-    , cloneAndArchive
+    , extractRemote
     , commit
     , download
     , hostedSources
@@ -17,6 +17,8 @@ module SlackBuilder.Download
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Char8 as Char8
+import Data.Foldable (traverse_)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
@@ -26,6 +28,7 @@ import SlackBuilder.Config
 import SlackBuilder.Trans
 import Control.Monad.Trans.Reader (asks)
 import Control.Monad.IO.Class (MonadIO(liftIO))
+import System.Directory (createDirectory)
 import System.IO (IOMode(..), withFile)
 import System.FilePath ((</>), (<.>), takeFileName, takeDirectory)
 import System.Process
@@ -63,8 +66,10 @@ import Conduit
     , await
     , sourceFile
     )
+import Data.Conduit.Tar (untar, FileInfo(..))
 import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
 import Data.Void (Void)
+import qualified Data.Conduit.Lzma as Lzma
 
 updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT ()
 updateSlackBuildVersion packagePath version additionalDownloads = do
@@ -215,3 +220,21 @@ cloneAndUpload repo tarballPath tagPrefix = do
          in cloneAndArchive repo tarballPath tagPrefix
             >> uploadCommand localPath remoteArchivePath
             >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)
+
+extractRemote :: URI -> Text -> SlackBuilderT ()
+extractRemote uri' packagePath = do
+    repository' <- SlackBuilderT $ asks repository
+    let localToRepository = repository' </> Text.unpack packagePath
+    traverse_ (runReq defaultHttpConfig . go localToRepository . fst)
+        $ useHttpsURI uri'
+  where
+    go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget
+    readResponse :: FilePath -> Response BodyReader -> IO ()
+    readResponse toTarget response = runConduitRes
+        $ responseBodySource response
+        .| Lzma.decompress Nothing
+        .| untar (withDecompressedFile toTarget)
+    withDecompressedFile toTarget FileInfo{..}
+        | Char8.last filePath /= '/' =
+            sinkFile (toTarget </> Char8.unpack filePath)
+        | otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))

src/Main.hs

@@ -6,7 +6,6 @@ module Main
     ( main
     ) where
 
-import qualified Data.ByteString.Char8 as Char8
 import Data.Char (isNumber)
 import Control.Applicative (Applicative(liftA2))
 import Data.List.NonEmpty (NonEmpty(..))
@@ -31,9 +30,9 @@ import SlackBuilder.Package (Package(..))
 import qualified SlackBuilder.Package as Package
 import Text.URI (URI(..), mkURI)
 import Text.URI.QQ (uri)
-import Data.Foldable (Foldable(..), for_, find, traverse_)
+import Data.Foldable (Foldable(..), for_, find)
 import qualified Text.URI as URI
-import System.FilePath ((</>), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName)
+import System.FilePath ((</>), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName, takeDirectory, takeFileName)
 import SlackBuilder.Info
 import Text.Megaparsec (parse, errorBundlePretty)
 import GHC.Records (HasField(..))
@@ -52,21 +51,10 @@ import System.Console.ANSI
     , Color(..)
     , ConsoleLayer(..)
     )
-import System.Directory (listDirectory, doesDirectoryExist, createDirectory)
+import System.Directory (listDirectory, doesDirectoryExist, withCurrentDirectory, removeDirectoryRecursive)
 import Control.Monad (filterM)
 import Data.List (isPrefixOf, isSuffixOf, partition)
-import Network.HTTP.Client (Response, BodyReader)
-import Network.HTTP.Req
-    ( runReq
-    , defaultHttpConfig
-    , useHttpsURI
-    , GET(..)
-    , reqBr
-    , NoReqBody(..)
-    )
-import Conduit (runConduitRes, (.|), sinkFile, sourceFile)
-import Data.Conduit.Tar (untar, FileInfo(..))
-import qualified Data.Conduit.Lzma as Lzma
+import Conduit (runConduitRes, (.|), sourceFile)
 
 autoUpdatable :: [Package]
 autoUpdatable =
@@ -407,11 +395,11 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
     uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
     let downloadFileName = URI.unRText
             $ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
-        relativeTarball = packagePath <> "/" <> downloadFileName
-        tarball = repository' </> Text.unpack relativeTarball
+        relativeTarball = Text.unpack $ packagePath <> "/" <> downloadFileName
+        tarball = repository' </> relativeTarball
 
-    extractRemote uri'
-    download' <- handleReupload (Text.unpack relativeTarball) downloadFileName
+    extractRemote uri' packagePath
+    download' <- handleReupload relativeTarball downloadFileName
     checksum <- liftIO $ runConduitRes $ sourceFile tarball .| sinkHash
 
     pure $ Package.Download download' checksum
@@ -419,18 +407,22 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
     name' = Text.pack $ takeBaseName $ Text.unpack packagePath
     handleReupload relativeTarball downloadFileName = do
         repository' <- SlackBuilderT $ asks repository
+        downloadURL' <- SlackBuilderT $ asks downloadURL
+
+        liftIO $ putStrLn $ "Upload the source tarball " <> relativeTarball
         case commands of
-            [] -> uploadTarball relativeTarball downloadFileName
+            [] -> uploadCommand relativeTarball ("/" <> name')
             _ ->
                 let tarballPath = repository' </> relativeTarball
-                    packedDirectory = takeBaseName $ dropExtension tarballPath
+                    packedDirectory = dropExtension $ dropExtension tarballPath
                  in liftIO (traverse (defaultCreateProcess packedDirectory) commands)
-                >> liftIO (callProcess "tar" ["Jcvf", tarballPath, packedDirectory])
-                >> uploadTarball relativeTarball downloadFileName
-    uploadTarball relativeTarball downloadFileName
-        = liftIO (putStrLn $ "Upload the source tarball " <> relativeTarball)
-        >> uploadCommand relativeTarball ("/" <> name')
-        >> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
+                >> liftIO
+                    ( withCurrentDirectory (takeDirectory tarballPath)
+                    $ callProcess "tar" ["Jcvf", takeFileName tarballPath, takeFileName packedDirectory]
+                    )
+                >> liftIO (removeDirectoryRecursive packedDirectory)
+                >> uploadCommand relativeTarball ("/" <> name')
+        liftIO $ mkURI $ downloadURL' <> "/" <> name' <> "/" <> downloadFileName
     defaultCreateProcess cwd' cmdSpec
         = flip withCreateProcess (const . const . const waitForProcess)
         $ CreateProcess
@@ -450,19 +442,6 @@ reuploadWithTemplate downloadTemplate commands packagePath version = do
             , child_user = Nothing
             , child_group = Nothing
             }
-    extractRemote :: URI -> SlackBuilderT ()
-    extractRemote uri' = traverse_ (runReq defaultHttpConfig . go . fst)
-        $ useHttpsURI uri'
-    go uri' = reqBr GET uri' NoReqBody mempty readResponse
-    readResponse :: Response BodyReader -> IO ()
-    readResponse response = runConduitRes
-        $ responseBodySource response
-        .| Lzma.decompress Nothing
-        .| untar withDecompressedFile
-    withDecompressedFile FileInfo{..}
-        | Char8.last filePath /= '/' =
-            sinkFile (Char8.unpack filePath)
-        | otherwise = liftIO (createDirectory (Char8.unpack filePath))
 
 updatePackage :: Package -> Text -> PackageInfo -> SlackBuilderT ()
 updatePackage Package{..} version info = do