diff options
| author |  Joey Hess <joeyh@joeyh.name> | 2017-12-31 16:08:31 -0400 |
|---|---|---|
| committer | Joey Hess <joeyh@joeyh.name> | 2017-12-31 16:36:39 -0400 |
| commit | 8f3134e5408ea1ea6207028ae17f2b5fb84e0c65 (patch) | |
| tree | 99739954cd6b8a3c229a230f005d69f6ed74fb8c | |
| parent | 6f83a6c8f45d7aa325d315654c4fd28de9feb4a6 (diff) | |
finally really add back custom-setup stanza
Fourth or fifth try at this and finally found a way to make it work.
Absurd amount of busy-work forced on me by change in cabal's behavior.
Split up Utility modules that need posix stuff out of ones used by
Setup. Various other hacks around inability for Setup to use anything
that ifdefs a use of unix.
Probably lost a full day of my life to this.
This is how build systems make their users hate them. Just saying.
48 files changed, 492 insertions, 345 deletions
diff --git a/Annex/Action.hs b/Annex/Action.hs index fc8be6c91..273c62fa8 100644 --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -12,6 +12,8 @@ module Annex.Action where import qualified Data.Map as M #ifndef mingw32_HOST_OS import System.Posix.Signals +import System.Posix.Process (getAnyProcessStatus) +import Utility.Exception #endif import Annex.Common @@ -46,3 +48,19 @@ stopCoProcesses = do checkAttrStop hashObjectStop checkIgnoreStop + +{- Reaps any zombie processes that may be hanging around. + - + - Warning: Not thread safe. Anything that was expecting to wait + - on a process and get back an exit status is going to be confused + - if this reap gets there first. -} +reapZombies :: IO () +#ifndef mingw32_HOST_OS +reapZombies = + -- throws an exception when there are no child processes + catchDefaultIO Nothing (getAnyProcessStatus False True) + >>= maybe (return ()) (const reapZombies) + +#else +reapZombies = return () +#endif diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index 1ffc54f66..4bf1b631b 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -50,7 +50,7 @@ import Annex.AutoMerge import Annex.Content import Annex.Perms import Annex.GitOverlay -import Utility.Tmp +import Utility.Tmp.Dir import Utility.CopyFile import qualified Database.Keys import Config diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 0dc360c54..6cb279702 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -65,6 +65,7 @@ import Annex.Branch.Transitions import qualified Annex import Annex.Hook import Utility.FileSystemEncoding +import Utility.Directory.Stream {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref diff --git a/Annex/Common.hs b/Annex/Common.hs index 52a545a59..bb277df7d 100644 --- a/Annex/Common.hs +++ b/Annex/Common.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Annex.Common (module X) where import Common as X @@ -7,3 +9,6 @@ import Types.UUID as X import Annex as X (gitRepo, inRepo, fromRepo, calcRepo) import Annex.Locations as X import Messages as X +#ifndef mingw32_HOST_OS +import System.Posix.IO as X hiding (createPipe) +#endif diff --git a/Annex/Environment.hs b/Annex/Environment.hs index 4f0fda986..6fdac1e49 100644 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -13,7 +13,7 @@ import Annex.Common import Utility.UserInfo import qualified Git.Config import Config -import Utility.Env +import Utility.Env.Set {- Checks that the system's environment allows git to function. - Git requires a GECOS username, or suitable git configuration, or diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 184bb0ab0..0ff95ffe5 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -17,6 +17,7 @@ import Annex.Common import qualified Git import Annex.Perms import Annex.LockFile +import Utility.Directory.Stream {- Records content for a file in the branch to the journal. - diff --git a/Annex/MakeRepo.hs b/Annex/MakeRepo.hs index ac25c013d..189e98c7d 100644 --- a/Annex/MakeRepo.hs +++ b/Annex/MakeRepo.hs @@ -20,6 +20,7 @@ import Annex.Action import Types.StandardGroups import Logs.PreferredContent import qualified Annex.Branch +import Utility.Process.Transcript {- Makes a new git repository. Or, if a git repository already - exists, returns False. -} diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs index 7cb4fbdea..06dfdf59e 100644 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -11,7 +11,8 @@ module Annex.ReplaceFile where import Annex.Common import Annex.Perms -import Utility.Tmp +import Utility.Tmp.Dir +import Utility.Path.Max {- Replaces a possibly already existing file with a new version, - atomically, by running an action. diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 5154a50a4..7280b58a4 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -34,6 +34,7 @@ import Annex.Path import Utility.Env import Utility.FileSystemEncoding import Utility.Hash +import Utility.Process.Transcript import Types.CleanupActions import Types.Concurrency import Git.Env diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 95b6bf762..f49fb3307 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -21,6 +21,7 @@ import Annex.Url import Utility.Url (URLString) import Utility.DiskFree import Utility.HtmlDetect +import Utility.Process.Transcript import Logs.Transfer import Network.URI diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index fb4a39a17..852844616 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -9,12 +9,14 @@ module Assistant.Ssh where import Annex.Common import Utility.Tmp +import Utility.Tmp.Dir import Utility.Shell import Utility.Rsync import Utility.FileMode import Utility.SshConfig import Git.Remote import Utility.SshHost +import Utility.Process.Transcript import Data.Text (Text) import qualified Data.Text as T diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 3b7b48833..a100e23b5 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -15,6 +15,7 @@ import qualified Annex import Assistant.Alert import Assistant.DaemonStatus import Utility.Env +import Utility.Env.Set import Types.Distribution import Types.Transfer import Logs.Web @@ -31,7 +32,7 @@ import Remote (remoteFromUUID) import Annex.Path import Config.Files import Utility.ThreadScheduler -import Utility.Tmp +import Utility.Tmp.Dir import Utility.UserInfo import Utility.Gpg import Utility.FileMode diff --git a/Build/Configure.hs b/Build/Configure.hs index b40ca9250..a0ddf4dbd 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -4,22 +4,23 @@ module Build.Configure where -import Control.Applicative -import Control.Monad.IfElse -import Control.Monad - import Build.TestConfig import Build.Version import Utility.PartialPrelude import Utility.Process import Utility.SafeCommand import Utility.ExternalSHA -import Utility.Env +import Utility.Env.Basic import Utility.Exception import qualified Git.Version import Utility.DottedVersion import Utility.Directory +import Control.Monad.IfElse +import Control.Monad +import Control.Applicative +import Prelude + tests :: [TestCase] tests = [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index 0203c02a6..a54f45d33 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -22,9 +22,7 @@ import Assistant.Install.AutoStart import Assistant.Install.Menu import System.Environment -#ifndef mingw32_HOST_OS -import System.Posix.User -#endif +import System.PosixCompat.User import Data.Maybe import Control.Applicative import Prelude @@ -10,6 +10,7 @@ git-annex (6.20171215) UNRELEASED; urgency=medium nothing, like it used to when quvi was used. * addurl: Fix encoding of filename queried from youtube-dl when in --fast mode. + * git-annex.cabal: Add back custom-setup stanza, so cabal new-build works. -- Joey Hess <id@joeyh.name> Wed, 20 Dec 2017 12:11:46 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 65d25859b..995848ed2 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -30,6 +30,7 @@ import Logs.Location import Utility.Metered import Utility.FileSystemEncoding import Utility.HtmlDetect +import Utility.Path.Max import qualified Annex.Transfer as Transfer cmd :: Command diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 9a518a18f..55792a2bc 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -25,6 +25,8 @@ import Types.FileMatcher import qualified Git.LsFiles as LsFiles import Utility.Hash import Utility.Tmp +import Utility.Tmp.Dir +import Utility.Process.Transcript import Config import Data.Char diff --git a/Command/P2P.hs b/Command/P2P.hs index 40a49b49f..1b5418499 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -19,7 +19,7 @@ import qualified Annex import Annex.UUID import Config import Utility.AuthToken -import Utility.Tmp +import Utility.Tmp.Dir import Utility.FileMode import Utility.ThreadScheduler import qualified Utility.MagicWormhole as Wormhole diff --git a/Command/Proxy.hs b/Command/Proxy.hs index dba0300b8..553d826f4 100644 --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -9,7 +9,7 @@ module Command.Proxy where import Command import Config -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Env import Annex.Direct import qualified Git diff --git a/Command/Sync.hs b/Command/Sync.hs index f63260ed4..75752f4ff 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -63,6 +63,7 @@ import Annex.TaggedPush import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse +import Utility.Process.Transcript import Control.Concurrent.MVar import qualified Data.Map as M @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports, CPP #-} +{-# LANGUAGE PackageImports #-} module Common (module X) where @@ -14,9 +14,6 @@ import Data.Default as X import System.FilePath as X import System.IO as X hiding (FilePath) -#ifndef mingw32_HOST_OS -import System.Posix.IO as X hiding (createPipe) -#endif import System.Exit as X import System.PosixCompat.Files as X hiding (fileSize) diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 69a679ee3..df074cf8b 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -12,6 +12,7 @@ import Git.Types import Git.Construct import qualified Git.Config import Utility.Env +import Utility.Env.Set {- Gets the current git repository. - diff --git a/Git/Index.hs b/Git/Index.hs index 85ea480b5..0898569b4 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -10,6 +10,7 @@ module Git.Index where import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" diff --git a/Git/LockFile.hs b/Git/LockFile.hs index a7a144114..e3d59009e 100644 --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -13,6 +13,7 @@ import Common #ifndef mingw32_HOST_OS import System.Posix.Types +import System.Posix.IO #else import System.Win32.Types import System.Win32.File diff --git a/Git/Repair.hs b/Git/Repair.hs index 8e4324858..d4f8e0bf9 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -36,7 +36,7 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode import Utility.Tuple diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 79aebad6b..dfac61542 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -38,7 +38,7 @@ import Utility.Metered import Types.Transfer import Types.Creds import Annex.DirHashes -import Utility.Tmp +import Utility.Tmp.Dir import Utility.SshHost import qualified Data.Map as M @@ -83,6 +83,7 @@ import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache import qualified Utility.Env +import qualified Utility.Env.Set import qualified Utility.Matcher import qualified Utility.Exception import qualified Utility.Hash @@ -91,7 +92,7 @@ import qualified Utility.Scheduled.QuickCheck import qualified Utility.HumanTime import qualified Utility.ThreadScheduler import qualified Utility.Base64 -import qualified Utility.Tmp +import qualified Utility.Tmp.Dir import qualified Utility.FileSystemEncoding import qualified Command.Uninit import qualified CmdLine.GitAnnex as GitAnnex @@ -130,7 +131,7 @@ runner = Just go subenv = "GIT_ANNEX_TEST_SUBPROCESS" runsubprocesstests opts Nothing = do pp <- Annex.Path.programPath - Utility.Env.setEnv subenv "1" True + Utility.Env.Set.setEnv subenv "1" True ps <- getArgs (Nothing, Nothing, Nothing, pid) <-createProcess (proc pp ps) exitcode <- waitForProcess pid @@ -356,7 +357,7 @@ test_log = intmpclonerepo $ do git_annex "log" [annexedfile] @? "log failed" test_import :: Assertion -test_import = intmpclonerepo $ Utility.Tmp.withTmpDir "importtest" $ \importdir -> do +test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do (toimport1, importf1, imported1) <- mktoimport importdir "import1" git_annex "import" [toimport1] @? "import failed" annexed_present_imported imported1 @@ -1917,11 +1918,11 @@ ensuretmpdir = do {- Prevent global git configs from affecting the test suite. -} isolateGitConfig :: IO a -> IO a -isolateGitConfig a = Utility.Tmp.withTmpDir "testhome" $ \tmphome -> do +isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do tmphomeabs <- absPath tmphome - Utility.Env.setEnv "HOME" tmphomeabs True - Utility.Env.setEnv "XDG_CONFIG_HOME" tmphomeabs True - Utility.Env.setEnv "GIT_CONFIG_NOSYSTEM" "1" True + Utility.Env.Set.setEnv "HOME" tmphomeabs True + Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True + Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True a cleanup :: FilePath -> IO () @@ -1933,7 +1934,7 @@ cleanup dir = whenM (doesDirectoryExist dir) $ do finalCleanup :: IO () finalCleanup = whenM (doesDirectoryExist tmpdir) $ do - Utility.Misc.reapZombies + Annex.Action.reapZombies Command.Uninit.prepareRemoveAnnexDir' tmpdir catchIO (removeDirectoryRecursive tmpdir) $ \e -> do print e @@ -1941,7 +1942,7 @@ finalCleanup = whenM (doesDirectoryExist tmpdir) $ do Utility.ThreadScheduler.threadDelaySeconds $ Utility.ThreadScheduler.Seconds 10 whenM (doesDirectoryExist tmpdir) $ do - Utility.Misc.reapZombies + Annex.Action.reapZombies removeDirectoryRecursive tmpdir checklink :: FilePath -> Assertion @@ -2107,7 +2108,7 @@ setTestMode testmode = do currdir <- getCurrentDirectory p <- Utility.Env.getEnvDefault "PATH" "" - mapM_ (\(var, val) -> Utility.Env.setEnv var val True) + mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True) -- Ensure that the just-built git annex is used. [ ("PATH", currdir ++ [searchPathSeparator] ++ p) , ("TOPDIR", currdir) diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 895581dff..e2c6a9462 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -18,15 +18,11 @@ import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative -import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS -import qualified System.Win32 as Win32 -#else -import qualified System.Posix as Posix +#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif @@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif - -#ifndef mingw32_HOST_OS -data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream -#else -data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ()) -#endif - -type IsOpen = MVar () -- full when the handle is open - -openDirectory :: FilePath -> IO DirectoryHandle -openDirectory path = do -#ifndef mingw32_HOST_OS - dirp <- Posix.openDirStream path - isopen <- newMVar () - return (DirectoryHandle isopen dirp) -#else - (h, fdat) <- Win32.findFirstFile (path </> "*") - -- Indicate that the fdat contains a filename that readDirectory - -- has not yet returned, by making the MVar be full. - -- (There's always at least a "." entry.) - alreadyhave <- newMVar () - isopen <- newMVar () - return (DirectoryHandle isopen h fdat alreadyhave) -#endif - -closeDirectory :: DirectoryHandle -> IO () -#ifndef mingw32_HOST_OS -closeDirectory (DirectoryHandle isopen dirp) = - whenOpen isopen $ - Posix.closeDirStream dirp -#else -closeDirectory (DirectoryHandle isopen h _ alreadyhave) = - whenOpen isopen $ do - _ <- tryTakeMVar alreadyhave - Win32.findClose h -#endif - where - whenOpen :: IsOpen -> IO () -> IO () - whenOpen mv f = do - v <- tryTakeMVar mv - when (isJust v) f - -{- |Reads the next entry from the handle. Once the end of the directory -is reached, returns Nothing and automatically closes the handle. --} -readDirectory :: DirectoryHandle -> IO (Maybe FilePath) -#ifndef mingw32_HOST_OS -readDirectory hdl@(DirectoryHandle _ dirp) = do - e <- Posix.readDirStream dirp - if null e - then do - closeDirectory hdl - return Nothing - else return (Just e) -#else -readDirectory hdl@(DirectoryHandle _ h fdat mv) = do - -- If the MVar is full, then the filename in fdat has - -- not yet been returned. Otherwise, need to find the next - -- file. - r <- tryTakeMVar mv - case r of - Just () -> getfn - Nothing -> do - more <- Win32.findNextFile h fdat - if more - then getfn - else do - closeDirectory hdl - return Nothing - where - getfn = do - filename <- Win32.getFindDataFileName fdat - return (Just filename) -#endif - --- True only when directory exists and contains nothing. --- Throws exception if directory does not exist. -isDirectoryEmpty :: FilePath -> IO Bool -isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check - where - check h = do - v <- readDirectory h - case v of - Nothing -> return True - Just f - | not (dirCruft f) -> return False - | otherwise -> check h diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs new file mode 100644 index 000000000..ac62263a8 --- /dev/null +++ b/Utility/Directory/Stream.hs @@ -0,0 +1,113 @@ +{- streaming directory traversal + - + - Copyright 2011-2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Directory.Stream where + +import Control.Monad +import System.FilePath +import Control.Concurrent +import Data.Maybe +import Prelude + +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix +#endif + +import Utility.Directory +import Utility.Exception + +#ifndef mingw32_HOST_OS +data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream +#else +data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ()) +#endif + +type IsOpen = MVar () -- full when the handle is open + +openDirectory :: FilePath -> IO DirectoryHandle +openDirectory path = do +#ifndef mingw32_HOST_OS + dirp <- Posix.openDirStream path + isopen <- newMVar () + return (DirectoryHandle isopen dirp) +#else + (h, fdat) <- Win32.findFirstFile (path </> "*") + -- Indicate that the fdat contains a filename that readDirectory + -- has not yet returned, by making the MVar be full. + -- (There's always at least a "." entry.) + alreadyhave <- newMVar () + isopen <- newMVar () + return (DirectoryHandle isopen h fdat alreadyhave) +#endif + +closeDirectory :: DirectoryHandle -> IO () +#ifndef mingw32_HOST_OS +closeDirectory (DirectoryHandle isopen dirp) = + whenOpen isopen $ + Posix.closeDirStream dirp +#else +closeDirectory (DirectoryHandle isopen h _ alreadyhave) = + whenOpen isopen $ do + _ <- tryTakeMVar alreadyhave + Win32.findClose h +#endif + where + whenOpen :: IsOpen -> IO () -> IO () + whenOpen mv f = do + v <- tryTakeMVar mv + when (isJust v) f + +{- |Reads the next entry from the handle. Once the end of the directory +is reached, returns Nothing and automatically closes the handle. +-} +readDirectory :: DirectoryHandle -> IO (Maybe FilePath) +#ifndef mingw32_HOST_OS +readDirectory hdl@(DirectoryHandle _ dirp) = do + e <- Posix.readDirStream dirp + if null e + then do + closeDirectory hdl + return Nothing + else return (Just e) +#else +readDirectory hdl@(DirectoryHandle _ h fdat mv) = do + -- If the MVar is full, then the filename in fdat has + -- not yet been returned. Otherwise, need to find the next + -- file. + r <- tryTakeMVar mv + case r of + Just () -> getfn + Nothing -> do + more <- Win32.findNextFile h fdat + if more + then getfn + else do + closeDirectory hdl + return Nothing + where + getfn = do + filename <- Win32.getFindDataFileName fdat + return (Just filename) +#endif + +-- True only when directory exists and contains nothing. +-- Throws exception if directory does not exist. +isDirectoryEmpty :: FilePath -> IO Bool +isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check + where + check h = do + v <- readDirectory h + case v of + Nothing -> return True + Just f + | not (dirCruft f) -> return False + | otherwise -> check h diff --git a/Utility/Env.hs b/Utility/Env.hs index c56f4ec23..dfebd9868 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -16,7 +16,6 @@ import Control.Applicative import Data.Maybe import Prelude import qualified System.Environment as E -import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -42,29 +41,6 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Sets an environment variable. To overwrite an existing variable, - - overwrite must be True. - - - - On Windows, setting a variable to "" unsets it. -} -setEnv :: String -> String -> Bool -> IO () -#ifndef mingw32_HOST_OS -setEnv var val overwrite = PE.setEnv var val overwrite -#else -setEnv var val True = System.SetEnv.setEnv var val -setEnv var val False = do - r <- getEnv var - case r of - Nothing -> setEnv var val True - Just _ -> return () -#endif - -unsetEnv :: String -> IO () -#ifndef mingw32_HOST_OS -unsetEnv = PE.unsetEnv -#else -unsetEnv = System.SetEnv.unsetEnv -#endif - {- Adds the environment variable to the input environment. If already - present in the list, removes the old value. - diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs new file mode 100644 index 000000000..38295bea0 --- /dev/null +++ b/Utility/Env/Basic.hs @@ -0,0 +1,22 @@ +{- portable environment variables, without any dependencies + - + - Copyright 2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Env.Basic where + +import Utility.Exception +import Control.Applicative +import Data.Maybe +import Prelude +import qualified System.Environment as E + +getEnv :: String -> IO (Maybe String) +getEnv = catchMaybeIO . E.getEnv + +getEnvDefault :: String -> String -> IO String +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs new file mode 100644 index 000000000..fd8d5140d --- /dev/null +++ b/Utility/Env/Set.hs @@ -0,0 +1,40 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Env.Set where + +#ifdef mingw32_HOST_OS +import qualified System.Environment as E +import qualified System.SetEnv +#else +import qualified System.Posix.Env as PE +#endif + +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. + - + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () +#ifndef mingw32_HOST_OS +setEnv var val overwrite = PE.setEnv var val overwrite +#else +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () +#endif + +unsetEnv :: String -> IO () +#ifndef mingw32_HOST_OS +unsetEnv = PE.unsetEnv +#else +unsetEnv = System.SetEnv.unsetEnv +#endif diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 4af0067bb..2c643b45f 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -13,10 +13,11 @@ import Common import qualified BuildInfo #ifndef mingw32_HOST_OS import System.Posix.Types -import qualified System.Posix.IO +import System.Posix.IO import Utility.Env +import Utility.Env.Set #endif -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Format (decode_c) import Control.Concurrent diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index bc6d92ca9..4e08e9b9f 100644 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -13,6 +13,7 @@ import Common #ifndef mingw32_HOST_OS import System.Posix.Types +import System.Posix.IO #endif openLog :: FilePath -> IO Handle diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index ab80258b7..7cab8d98a 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -11,7 +11,7 @@ module Utility.Lsof where import Common import BuildInfo -import Utility.Env +import Utility.Env.Set import System.Posix.Types diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 2ae992874..48fcceb7e 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -5,7 +5,6 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc where @@ -16,10 +15,6 @@ import Foreign import Data.Char import Data.List import System.Exit -#ifndef mingw32_HOST_OS -import System.Posix.Process (getAnyProcessStatus) -import Utility.Exception -#endif import Control.Applicative import Prelude @@ -112,22 +107,6 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie processes that may be hanging around. - - - - Warning: Not thread safe. Anything that was expecting to wait - - on a process and get back an exit status is going to be confused - - if this reap gets there first. -} -reapZombies :: IO () -#ifndef mingw32_HOST_OS -reapZombies = - -- throws an exception when there are no child processes - catchDefaultIO Nothing (getAnyProcessStatus False True) - >>= maybe (return ()) (const reapZombies) - -#else -reapZombies = return () -#endif - exitBool :: Bool -> IO a exitBool False = exitFailure exitBool True = exitSuccess diff --git a/Utility/Path.hs b/Utility/Path.hs index dc91ce50c..f1302ae8c 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE PackageImports, CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path where @@ -17,13 +17,6 @@ import Data.Char import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS -import qualified System.FilePath.Posix as Posix -#else -import System.Posix.Files -import Utility.Exception -#endif - import Utility.Monad import Utility.UserInfo import Utility.Directory @@ -247,50 +240,6 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a msys2 style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i - - - - The virtual filesystem contains: - - /c, /d, ... mount points for Windows drives - -} -toMSYS2Path :: FilePath -> FilePath -#ifndef mingw32_HOST_OS -toMSYS2Path = id -#else -toMSYS2Path p - | null drive = recombine parts - | otherwise = recombine $ "/" : driveletter drive : parts - where - (drive, p') = splitDrive p - parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') - recombine = fixtrailing . Posix.joinPath - fixtrailing s - | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s - | otherwise = s -#endif - -{- Maximum size to use for a file in a specified directory. - - - - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no - - limit. - -} -fileNameLengthLimit :: FilePath -> IO Int -#ifdef mingw32_HOST_OS -fileNameLengthLimit _ = return 255 -#else -fileNameLengthLimit dir = do - -- getPathVar can fail due to statfs(2) overflow - l <- catchDefaultIO 0 $ - fromIntegral <$> getPathVar dir FileNameLimit - if l <= 0 - then return 255 - else return $ minimum [l, 255] -#endif - {- Given a string that we'd like to use as the basis for FilePath, but that - was provided by a third party and is not to be trusted, returns the closest - sane FilePath. diff --git a/Utility/Path/Max.hs b/Utility/Path/Max.hs new file mode 100644 index 000000000..4a810e591 --- /dev/null +++ b/Utility/Path/Max.hs @@ -0,0 +1,40 @@ +{- path manipulation + - + - Copyright 2010-2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path.Max where + +import System.FilePath +import Data.List +import Control.Applicative +import Prelude + +#ifndef mingw32_HOST_OS +import Utility.Exception +import System.Posix.Files +#endif + +{- Maximum size to use for a file in a specified directory. + - + - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no + - limit. + -} +fileNameLengthLimit :: FilePath -> IO Int +#ifdef mingw32_HOST_OS +fileNameLengthLimit _ = return 255 +#else +fileNameLengthLimit dir = do + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit + if l <= 0 + then return 255 + else return $ minimum [l, 255] +#endif diff --git a/Utility/Process.hs b/Utility/Process.hs index 6d981cb51..ff454f799 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -24,8 +24,6 @@ module Utility.Process ( createProcessSuccess, createProcessChecked, createBackgroundProcess, - processTranscript, - processTranscript', withHandle, withIOHandles, withOEHandles, @@ -54,13 +52,6 @@ import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad -#ifndef mingw32_HOST_OS -import qualified System.Posix.IO -#else -import Control.Applicative -#endif -import Data.Maybe -import Prelude type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +161,6 @@ createProcessChecked checker p a = do createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and --- returns a transcript combining its stdout and stderr, and --- whether it succeeded or failed. -processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript cmd opts = processTranscript' (proc cmd opts) - -processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) -processTranscript' cp input = do -#ifndef mingw32_HOST_OS -{- This implementation interleves stdout and stderr in exactly the order - - the process writes them. -} - (readf, writef) <- System.Posix.IO.createPipe - readh <- System.Posix.IO.fdToHandle readf - writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } - hClose writeh - - get <- mkreader readh - writeinput input p - transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) -#else -{- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - - getout <- mkreader (stdoutHandle p) - geterr <- mkreader (stderrHandle p) - writeinput input p - transcript <- (++) <$> getout <*> geterr - - ok <- checkSuccessProcess pid - return (transcript, ok) -#endif - where - mkreader h = do - s <- hGetContents h - v <- newEmptyMVar - void $ forkIO $ do - void $ E.evaluate (length s) - putMVar v () - return $ do - takeMVar v - return s - - writeinput (Just s) p = do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - writeinput Nothing _ = return () - -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action. diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs new file mode 100644 index 000000000..0dbe428f7 --- /dev/null +++ b/Utility/Process/Transcript.hs @@ -0,0 +1,87 @@ +{- Process transcript + - + - Copyright 2012-2015 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process.Transcript where + +import Utility.Process + +import System.IO +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +#ifndef mingw32_HOST_OS +import qualified System.Posix.IO +#else +import Control.Applicative +#endif +import Data.Maybe +import Prelude + +-- | Runs a process, optionally feeding it some input, and +-- returns a transcript combining its stdout and stderr, and +-- whether it succeeded or failed. +processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +processTranscript cmd opts = processTranscript' (proc cmd opts) + +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do +#ifndef mingw32_HOST_OS +{- This implementation interleves stdout and stderr in exactly the order + - the process writes them. -} + (readf, writef) <- System.Posix.IO.createPipe + readh <- System.Posix.IO.fdToHandle readf + writeh <- System.Posix.IO.fdToHandle writef + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } + hClose writeh + + get <- mkreader readh + writeinput input p + transcript <- get + + ok <- checkSuccessProcess pid + return (transcript, ok) +#else +{- This implementation for Windows puts stderr after stdout. -} + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + + getout <- mkreader (stdoutHandle p) + geterr <- mkreader (stderrHandle p) + writeinput input p + transcript <- (++) <$> getout <*> geterr + + ok <- checkSuccessProcess pid + return (transcript, ok) +#endif + where + mkreader h = do + s <- hGetContents h + v <- newEmptyMVar + void $ forkIO $ do + void $ E.evaluate (length s) + putMVar v () + return $ do + takeMVar v + return s + + writeinput (Just s) p = do + let inh = stdinHandle p + unless (null s) $ do + hPutStr inh s + hFlush inh + hClose inh + writeinput Nothing _ = return () diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index f190b40de..25af52617 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -13,6 +13,10 @@ import Common import Utility.Metered import Utility.Tuple +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#endif + import Data.Char import System.Console.GetOpt @@ -139,3 +143,29 @@ filterRsyncSafeOptions = fst3 . getOpt Permute [ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ] where reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) "" + +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +toMSYS2Path :: FilePath -> FilePath +#ifndef mingw32_HOST_OS +toMSYS2Path = id +#else +toMSYS2Path p + | null drive = recombine parts + | otherwise = recombine $ "/" : driveletter drive : parts + where + (drive, p') = splitDrive p + parts = splitDirectories p' + driveletter = map toLower . takeWhile (/= ':') + recombine = fixtrailing . Posix.joinPath + fixtrailing s + | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | otherwise = s +#endif + diff --git a/Utility/Su.hs b/Utility/Su.hs index 84ea4c5da..a0500e483 100644 --- a/Utility/Su.hs +++ b/Utility/Su.hs @@ -13,6 +13,7 @@ import Common #ifndef mingw32_HOST_OS import Utility.Env +import System.Posix.IO import System.Posix.Terminal #endif diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 7255c141e..6e04b1076 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,4 +1,4 @@ -{- Temporary files and directories. +{- Temporary files. - - Copyright 2010-2013 Joey Hess <id@joeyh.name> - @@ -11,14 +11,10 @@ module Utility.Tmp where import System.IO -import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Temp (mkdtemp) -#endif import Utility.Exception import Utility.FileSystemEncoding @@ -62,51 +58,6 @@ withTmpFileIn tmpdir template a = bracket create remove use catchBoolIO (removeFile name >> return True) use (name, h) = a name h -{- Runs an action with a tmp directory located within the system's tmp - - directory (or within "." if there is none), then removes the tmp - - directory and all its contents. -} -withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a -withTmpDir template a = do - topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory -#ifndef mingw32_HOST_OS - -- Use mkdtemp to create a temp directory securely in /tmp. - bracket - (liftIO $ mkdtemp $ topleveltmpdir </> template) - removeTmpDir - a -#else - withTmpDirIn topleveltmpdir template a -#endif - -{- Runs an action with a tmp directory located within a specified directory, - - then removes the tmp directory and all its contents. -} -withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a -withTmpDirIn tmpdir template = bracketIO create removeTmpDir - where - create = do - createDirectoryIfMissing True tmpdir - makenewdir (tmpdir </> template) (0 :: Int) - makenewdir t n = do - let dir = t ++ "." ++ show n - catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do - createDirectory dir - return dir - -{- Deletes the entire contents of the the temporary directory, if it - - exists. -} -removeTmpDir :: MonadIO m => FilePath -> m () -removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do -#if mingw32_HOST_OS - -- Windows will often refuse to delete a file - -- after a process has just written to it and exited. - -- Because it's crap, presumably. So, ignore failure - -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive tmpdir - return () -#else - removeDirectoryRecursive tmpdir -#endif - {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile - will be longer, and may exceed the maximum filename length. diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs new file mode 100644 index 000000000..ddf6ddbde --- /dev/null +++ b/Utility/Tmp/Dir.hs @@ -0,0 +1,68 @@ +{- Temporary directorie + - + - Copyright 2010-2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Tmp.Dir where + +import Control.Monad.IfElse +import System.FilePath +import System.Directory +import Control.Monad.IO.Class +#ifndef mingw32_HOST_OS +import System.Posix.Temp (mkdtemp) +#endif + +import Utility.Exception + +type Template = String + +{- Runs an action with a tmp directory located within the system's tmp + - directory (or within "." if there is none), then removes the tmp + - directory and all its contents. -} +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a +withTmpDir template a = do + topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory +#ifndef mingw32_HOST_OS + -- Use mkdtemp to create a temp directory securely in /tmp. + bracket + (liftIO $ mkdtemp $ topleveltmpdir </> template) + removeTmpDir + a +#else + withTmpDirIn topleveltmpdir template a +#endif + +{- Runs an action with a tmp directory located within a specified directory, + - then removes the tmp directory and all its contents. -} +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create removeTmpDir + where + create = do + createDirectoryIfMissing True tmpdir + makenewdir (tmpdir </> template) (0 :: Int) + makenewdir t n = do + let dir = t ++ "." ++ show n + catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do + createDirectory dir + return dir + +{- Deletes the entire contents of the the temporary directory, if it + - exists. -} +removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive tmpdir + return () +#else + removeDirectoryRecursive tmpdir +#endif diff --git a/Utility/Url.hs b/Utility/Url.hs index 14a755f26..ad595e3d1 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -32,7 +32,7 @@ module Utility.Url ( ) where import Common -import Utility.Tmp +import Utility.Tmp.Dir import qualified BuildInfo import Network.URI diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index d504fa5c3..694bbe6d0 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,7 +14,7 @@ module Utility.UserInfo ( myUserGecos, ) where -import Utility.Env +import Utility.Env.Basic import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data diff --git a/doc/bugs/Add_custom-setup_stanza_to_.cabal_file.mdwn b/doc/bugs/Add_custom-setup_stanza_to_.cabal_file.mdwn index 51d4f189d..fcf9b6b3a 100644 --- a/doc/bugs/Add_custom-setup_stanza_to_.cabal_file.mdwn +++ b/doc/bugs/Add_custom-setup_stanza_to_.cabal_file.mdwn @@ -44,3 +44,6 @@ Use -v to see a list of the files searched for. Yeah, it's amazing! I've been using the version from the Debian repos and then wanted to try building the new version for youtube-dl support. + +> Revisited it and seem to have managed to add custom-setup back. [[done]] +> --[[Joey]] diff --git a/git-annex.cabal b/git-annex.cabal index 6b2fec439..987894c01 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -302,6 +302,11 @@ source-repository head type: git location: git://git-annex.branchable.com/ +custom-setup + Setup-Depends: base (>= 4.6), hslogger, split, unix-compat, process, + filepath, exceptions, bytestring, directory, IfElse, data-default, + utf8-string, Cabal + Executable git-annex Main-Is: git-annex.hs Build-Depends: @@ -987,10 +992,13 @@ Executable git-annex Utility.DirWatcher Utility.DirWatcher.Types Utility.Directory + Utility.Directory.Stream Utility.DiskFree Utility.Dot Utility.DottedVersion Utility.Env + Utility.Env.Basic + Utility.Env.Set Utility.Exception Utility.ExternalSHA Utility.FileMode @@ -1029,9 +1037,11 @@ Executable git-annex Utility.Parallel Utility.PartialPrelude Utility.Path + Utility.Path.Max Utility.Percentage Utility.Process Utility.Process.Shim + Utility.Process.Transcript Utility.QuickCheck Utility.Rsync Utility.SRV @@ -1050,6 +1060,7 @@ Executable git-annex Utility.ThreadLock Utility.ThreadScheduler Utility.Tmp + Utility.Tmp.Dir Utility.Tor Utility.Touch Utility.Tuple |