diff options
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 |