[pkg-haskell-tools] 01/01: dht make: Make /tmp configurable

[Joachim Breitner]

This is an automated email from the git hooks/post-receive script.

nomeata pushed a commit to branch master
in repository pkg-haskell-tools.

commit 29a68cd3a9bab0da6cc633ac7b133f944f7b50b5
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Aug 19 09:04:59 2015 +0200

    dht make: Make /tmp configurable
    
    in case you want to bindmound something else.
---
 dht.cabal       |  5 ++++-
 src/Utils.hs    | 41 +++++++++++++++++++++++++++++++++++++++++
 src/make-all.hs | 15 ++++++++++++---
 3 files changed, 57 insertions(+), 4 deletions(-)

diff --git a/dht.cabal b/dht.cabal
index 698b034..24ab27d 100644
--- a/dht.cabal
+++ b/dht.cabal
@@ -13,11 +13,14 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 executable make-all
-  main-is:             make-all.hs
+  main-is:        make-all.hs
+  other-modules:  Utils
   build-depends:
     base >=4.6 && <4.8,
     containers,
     directory,
+    filepath,
+    time,
     parsec,
     text,
     shake == 0.15.*,
diff --git a/src/Utils.hs b/src/Utils.hs
new file mode 100644
index 0000000..1829cec
--- /dev/null
+++ b/src/Utils.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Utils where
+
+import System.IO
+import Control.Concurrent.Extra
+import Control.Exception.Extra as E
+import GHC.IO.Handle(hDuplicate,hDuplicateTo)
+import System.Directory.Extra
+import System.IO.Error
+import System.FilePath
+import Data.Char
+import Data.Time.Clock
+
+import Development.Shake hiding (withTempDir)
+
+
+-- This is copied from extra and shake sources, because they do not allow to
+-- specify the temp directory
+newTempDir :: FilePath -> IO (FilePath, IO ())
+newTempDir tmpdir = do
+        dir <- create
+        del <- once $ ignore $ removeDirectoryRecursive dir
+        return (dir, del)
+    where
+        create = do
+            -- get the number of seconds during today (including floating point), and grab some interesting digits
+            rand :: Integer <- fmap (read . take 20 . filter isDigit . show . utctDayTime) getCurrentTime
+            find tmpdir rand
+
+        find tmpdir x = do
+            let dir = tmpdir </> "dht-" ++ show x
+            catchBool isAlreadyExistsError
+                (createDirectoryPrivate dir >> return dir) $
+                \e -> find tmpdir (x+1)
+
+withTempDir :: FilePath -> (FilePath -> Action a) -> Action a
+withTempDir tmpdir act = do
+    (dir,del) <- liftIO $ newTempDir tmpdir
+    act dir `actionFinally` del
+
diff --git a/src/make-all.hs b/src/make-all.hs
index 5f2f342..7a2c410 100644
--- a/src/make-all.hs
+++ b/src/make-all.hs
@@ -19,7 +19,7 @@ import Options.Applicative hiding (many)
 import qualified Options.Applicative as O
 import Options.Applicative.Types (readerAsk)
 
-import Development.Shake
+import Development.Shake hiding (withTempDir)
 import Development.Shake.Classes
 import Development.Shake.FilePath
 
@@ -30,11 +30,14 @@ import Debian.Control.Policy
 import Text.Parsec hiding (option, oneOf)
 import Text.Parsec.String
 
+import Utils
+
 -- Option parsing
 data Conf = Conf
     { distribution :: String
     , excludedPackages :: [String]
     , targetDir :: FilePath
+    , baseTmpDir :: FilePath
     , jobs :: Int
     , schrootName :: String
     , shakeVerbosity' :: Verbosity
@@ -67,6 +70,13 @@ confSpec = Conf
     showDefault <>
     value "lab"
     )
+ <*> strOption (
+    long "tmpdir" <>
+    metavar "DIR" <>
+    help "temporary directory (assumed to be bind-mounted in the schroot)" <>
+    showDefault <>
+    value "/tmp"
+    )
  <*> option parseNat (
     long "jobs" <>
     short 'j' <>
@@ -392,7 +402,7 @@ shakeMain conf@(Conf {..}) = do
             liftIO (listFiles targetDir)
         let localDepPkgs = map debFileNameToPackage localDebs
 
-        withTempDir $ \tmpdir -> do
+        withTempDir baseTmpDir $ \tmpdir -> do
             -- Now monkey-patch dependencies out of the package lists
             let fixup = tmpdir </> "fixup.sh"
             liftIO $ writeFile fixup  $ fixupScript localDepPkgs
@@ -436,4 +446,3 @@ shakeMain conf@(Conf {..}) = do
         need [ "p" </> source </> f | f <- sourceFiles]
         unit $ cmd  (EchoStdout False) (Traced "debian2dsc") "dht" "debian2dsc" "-o" targetDir ("p" </> source </> "debian")
 
-

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/pkg-haskell-tools.git