diff options
83 files changed, 1241 insertions, 576 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 021cd3926..9a89a65c3 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -24,7 +24,6 @@ module Annex.Branch ( ) where import qualified Data.ByteString.Lazy.Char8 as L -import System.Posix.Env import Common.Annex import Annex.BranchState @@ -41,6 +40,7 @@ import Git.FilePath import Annex.CatFile import Annex.Perms import qualified Annex +import Utility.Env {- Name of the branch that is used to store git-annex's information. -} name :: Git.Ref @@ -288,12 +288,14 @@ withIndex' bootstrapping a = do f <- fromRepo gitAnnexIndex g <- gitRepo #ifdef __ANDROID__ - {- Work around for weird getEnvironment breakage on Android. See + {- This should not be necessary on Android, but there is some + - weird getEnvironment breakage. See - https://github.com/neurocyte/ghc-android/issues/7 - - Instead, use getEnv to get some key environment variables that + - Use getEnv to get some key environment variables that - git expects to have. -} let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME" - let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k + let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> + catchMaybeIO (getEnv k) e <- liftIO $ catMaybes <$> forM keyenv getEnvPair #else e <- liftIO getEnvironment diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 9de6f9856..71b8985a3 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -22,6 +22,7 @@ import qualified Git import qualified Git.CatFile import qualified Annex import Git.Types +import Git.FilePath catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do @@ -56,7 +57,7 @@ catFileHandle = do {- From the Sha or Ref of a symlink back to the key. -} catKey :: Ref -> Annex (Maybe Key) catKey ref = do - l <- encodeW8 . L.unpack <$> catObject ref + l <- fromInternalGitPath . encodeW8 . L.unpack <$> catObject ref return $ if isLinkToAnnex l then fileKey $ takeFileName l else Nothing diff --git a/Annex/Content.hs b/Annex/Content.hs index ad04bdba1..5ec3c1b3f 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Content ( inAnnex, inAnnexSafe, @@ -31,6 +33,7 @@ module Annex.Content ( ) where import System.IO.Unsafe (unsafeInterleaveIO) +import System.PosixCompat.Files import Common.Annex import Logs.Location @@ -84,14 +87,22 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go where go f = liftIO $ openforlock f >>= check openforlock f = catchMaybeIO $ +#ifndef __WINDOWS__ openFd f ReadOnly Nothing defaultFileFlags +#else + return () +#endif check Nothing = return is_missing check (Just h) = do +#ifndef __WINDOWS__ v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) closeFd h return $ case v of Just _ -> is_locked Nothing -> is_unlocked +#else + return is_unlocked +#endif is_locked = Nothing is_unlocked = Just True is_missing = Just False @@ -100,6 +111,9 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go - it. (If the content is not present, no locking is done.) -} lockContent :: Key -> Annex a -> Annex a lockContent key a = do +#ifdef __WINDOWS__ + a +#else file <- calcRepo $ gitAnnexLocation key bracketIO (openforlock file >>= lock) unlock a where @@ -121,6 +135,7 @@ lockContent key a = do Right _ -> return $ Just fd unlock Nothing = noop unlock (Just l) = closeFd l +#endif {- Runs an action, passing it a temporary filename to get, - and if the action succeeds, moves the temp file into diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index 54befdf73..b885b5e5b 100644 --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -29,7 +29,7 @@ import Common.Annex import qualified Annex import Annex.Perms import qualified Git -import Utility.TempFile +import Utility.Tmp import Logs.Location import Utility.InodeCache @@ -110,7 +110,7 @@ goodContent key file = sameInodeCache file =<< recordedInodeCache key recordedInodeCache :: Key -> Annex [InodeCache] recordedInodeCache key = withInodeCacheFile key $ \f -> liftIO $ catchDefaultIO [] $ - mapMaybe readInodeCache . lines <$> readFile f + mapMaybe readInodeCache . lines <$> readFileStrict f {- Caches an inode for a file. - diff --git a/Annex/Environment.hs b/Annex/Environment.hs index 472fc934a..33569386e 100644 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -10,11 +10,10 @@ module Annex.Environment where import Common.Annex +import Utility.Env import Utility.UserInfo import qualified Git.Config -import System.Posix.Env - {- Checks that the system's environment allows git to function. - Git requires a GECOS username, or suitable git configuration, or - environment variables. -} @@ -25,7 +24,10 @@ checkEnvironment = do liftIO checkEnvironmentIO checkEnvironmentIO :: IO () -checkEnvironmentIO = do +checkEnvironmentIO = +#ifdef __WINDOWS__ + noop +#else whenM (null <$> myUserGecos) $ do username <- myUserName ensureEnv "GIT_AUTHOR_NAME" username @@ -33,9 +35,10 @@ checkEnvironmentIO = do where #ifndef __ANDROID__ -- existing environment is not overwritten - ensureEnv var val = setEnv var val False + ensureEnv var val = void $ setEnv var val False #else -- Environment setting is broken on Android, so this is dealt with -- in runshell instead. ensureEnv _ _ = noop #endif +#endif diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 2df5294ee..e68591ce2 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -9,6 +9,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Journal where import System.IO.Binary @@ -64,26 +66,38 @@ journalDirty = not . null <$> getJournalFiles journalFile :: FilePath -> Git.Repo -> FilePath journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file where - mangle '/' = "_" - mangle '_' = "__" - mangle c = [c] + mangle c + | c == pathSeparator = "_" + | c == '_' = "__" + | otherwise = [c] {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} fileJournal :: FilePath -> FilePath -fileJournal = replace "//" "_" . replace "_" "/" +fileJournal = replace [pathSeparator, pathSeparator] "_" . + replace "_" [pathSeparator] {- Runs an action that modifies the journal, using locking to avoid - contention with other git-annex processes. -} lockJournal :: Annex a -> Annex a lockJournal a = do - file <- fromRepo gitAnnexJournalLock - createAnnexDirectory $ takeDirectory file + lockfile <- fromRepo gitAnnexJournalLock + createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode - bracketIO (lock file mode) unlock a + bracketIO (lock lockfile mode) unlock a where - lock file mode = do - l <- noUmask mode $ createFile file mode + lock lockfile mode = do +#ifndef __WINDOWS__ + l <- noUmask mode $ createFile lockfile mode waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0) return l +#else + writeFile lockfile "" + return lockfile +#endif +#ifndef __WINDOWS__ unlock = closeFd +#else + unlock = removeFile +#endif + diff --git a/Annex/Link.hs b/Annex/Link.hs index 931836d31..b41e6d101 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -18,6 +18,7 @@ import qualified Git.HashObject import qualified Git.UpdateIndex import qualified Annex.Queue import Git.Types +import Git.FilePath type LinkTarget = String @@ -27,25 +28,27 @@ isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget {- Gets the link target of a symlink. - - - On a filesystem that does not support symlinks, get the link - - target by looking inside the file. (Only return at first 8k of the file, - - more than enough for any symlink target.) + - On a filesystem that does not support symlinks, fall back to getting the + - link target by looking inside the file. (Only return at first 8k of the + - file, more than enough for any symlink target.) - - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget) -getAnnexLinkTarget file = do - v <- ifM (coreSymlinks <$> Annex.getGitConfig) - ( liftIO $ catchMaybeIO $ readSymbolicLink file - , liftIO $ catchMaybeIO $ readfilestart file - ) - case v of - Nothing -> return Nothing - Just l - | isLinkToAnnex l -> return v - | otherwise -> return Nothing +getAnnexLinkTarget file = + check readSymbolicLink $ + check readfilestart $ + return Nothing where + check getlinktarget fallback = do + v <- liftIO $ catchMaybeIO $ getlinktarget file + case v of + Just l + | isLinkToAnnex (fromInternalGitPath l) -> return v + | otherwise -> return Nothing + Nothing -> fallback + readfilestart f = do h <- openFile f ReadMode fileEncoding h @@ -74,7 +77,8 @@ addAnnexLink linktarget file = do {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject linktarget +hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $ + toInternalGitPath linktarget {- Stages a symlink to the annex, using a Sha of its target. -} stageSymlink :: FilePath -> Sha -> Annex () diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs index 45fc55b3c..d8bc08485 100644 --- a/Annex/LockPool.hs +++ b/Annex/LockPool.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.LockPool where import qualified Data.Map as M @@ -20,17 +22,24 @@ lockFile file = go =<< fromPool file where go (Just _) = noop -- already locked go Nothing = do +#ifndef __WINDOWS__ mode <- annexFileMode fd <- liftIO $ noUmask mode $ openFd file ReadOnly (Just mode) defaultFileFlags liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) +#else + liftIO $ writeFile file "" + let fd = 0 +#endif changePool $ M.insert file fd unlockFile :: FilePath -> Annex () unlockFile file = maybe noop go =<< fromPool file where go fd = do +#ifndef __WINDOWS__ liftIO $ closeFd fd +#endif changePool $ M.delete file getPool :: Annex (M.Map FilePath Fd) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index cf92bd248..940cbb5a7 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -10,11 +10,11 @@ module Annex.Ssh ( sshCachingOptions, sshCleanup, + sshCacheDir, sshReadPort, ) where import qualified Data.Map as M -import System.Posix.Env import Common.Annex import Annex.LockPool @@ -22,6 +22,7 @@ import Annex.Perms import qualified Build.SysConfig as SysConfig import qualified Annex import Config +import Utility.Env {- Generates parameters to ssh to a given host (or user@host) on a given - port, with connection caching. -} @@ -95,6 +96,7 @@ sshCleanup = go =<< sshCacheDir liftIO (catchDefaultIO [] $ dirContents dir) forM_ sockets cleanup cleanup socketfile = do +#ifndef __WINDOWS__ -- Drop any shared lock we have, and take an -- exclusive lock, without blocking. If the lock -- succeeds, nothing is using this ssh, and it can @@ -110,6 +112,9 @@ sshCleanup = go =<< sshCacheDir Left _ -> noop Right _ -> stopssh socketfile liftIO $ closeFd fd +#else + stopssh socketfile +#endif stopssh socketfile = do let (host, port) = socket2hostport socketfile (_, params) <- sshInfo (host, port) diff --git a/Annex/Version.hs b/Annex/Version.hs index 31c6501be..7859707d3 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Version where import Common.Annex @@ -23,7 +25,11 @@ supportedVersions :: [Version] supportedVersions = [defaultVersion, directModeVersion] upgradableVersions :: [Version] +#ifndef __WINDOWS__ upgradableVersions = ["0", "1", "2"] +#else +upgradableVersions = ["2"] +#endif versionField :: ConfigKey versionField = annexConfig "version" diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index f94521117..af072d8ae 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -9,7 +9,7 @@ module Assistant.DaemonStatus where import Assistant.Common import Assistant.Alert.Utility -import Utility.TempFile +import Utility.Tmp import Assistant.Types.NetMessager import Utility.NotificationBroadcaster import Logs.Transfer diff --git a/Assistant/Install.hs b/Assistant/Install.hs index 278190b35..3c7d09698 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -16,7 +16,8 @@ import Assistant.Ssh import Config.Files import Utility.FileMode import Utility.Shell -import Utility.TempFile +import Utility.Tmp +import Utility.Env #ifdef darwin_HOST_OS import Utility.OSX @@ -24,8 +25,6 @@ import Utility.OSX import Utility.FreeDesktop #endif -import System.Posix.Env - standaloneAppBase :: IO (Maybe FilePath) standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 0c718d019..7875c4c4c 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -8,7 +8,7 @@ module Assistant.Ssh where import Common.Annex -import Utility.TempFile +import Utility.Tmp import Utility.UserInfo import Utility.Shell import Git.Remote @@ -146,7 +146,7 @@ authorizedKeysLine rsynconly dir pubkey {- Generates a ssh key pair. -} genSshKeyPair :: IO SshKeyPair -genSshKeyPair = withTempDir "git-annex-keygen" $ \dir -> do +genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do ok <- boolSystem "ssh-keygen" [ Param "-P", Param "" -- no password , Param "-f", File $ dir </> "key" diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 19300cf3c..3c1e6178a 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -33,7 +33,7 @@ import Assistant.WebApp.Control import Assistant.WebApp.OtherRepos import Assistant.Types.ThreadedMonad import Utility.WebApp -import Utility.TempFile +import Utility.Tmp import Utility.FileMode import Git @@ -74,7 +74,7 @@ webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup , return app ) runWebApp listenhost app' $ \addr -> if noannex - then withTempFile "webapp.html" $ \tmpfile _ -> + then withTmpFile "webapp.html" $ \tmpfile _ -> go addr webapp tmpfile Nothing else do let st = threadState assistantdata diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index f48178985..f087f6d1f 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -32,10 +32,10 @@ import qualified Remote as Remote import Remote.List import Utility.FileMode import Utility.Shell +import Utility.Env import Network.Protocol.XMPP import qualified Data.Text as T -import System.Posix.Env import System.Posix.Types import System.Process (std_in, std_out, std_err) import Control.Concurrent diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs new file mode 100644 index 000000000..570af4adf --- /dev/null +++ b/Build/BundledPrograms.hs @@ -0,0 +1,46 @@ +{- Bundled programs + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Build.BundledPrograms where + +import Data.Maybe + +import Build.SysConfig as SysConfig + +{- Programs that git-annex uses, to include in the bundle. + - + - These may be just the command name, or the full path to it. -} +bundledPrograms :: [FilePath] +bundledPrograms = catMaybes + [ Nothing +#ifndef mingw32_HOST_OS + -- git is not included in the windows bundle + , Just "git" +#endif + , Just "cp" + , Just "xargs" + , Just "rsync" + , Just "ssh" +#ifndef mingw32_HOST_OS + , Just "sh" +#endif + , ifset SysConfig.gpg "gpg" + , ifset SysConfig.curl "curl" + , ifset SysConfig.wget "wget" + , ifset SysConfig.bup "bup" + , SysConfig.lsof + , SysConfig.sha1 + , SysConfig.sha256 + , SysConfig.sha512 + , SysConfig.sha224 + , SysConfig.sha384 + ] + where + ifset True s = Just s + ifset False _ = Nothing diff --git a/Build/Configure.hs b/Build/Configure.hs index b269bc460..e57b79257 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -110,8 +110,8 @@ getVersion = do getChangelogVersion :: IO String getChangelogVersion = do - changelog <- readFile "CHANGELOG" - let verline = head $ lines changelog + changelog <- readFile "debian/changelog" + let verline = takeWhile (/= '\n') changelog return $ middle (words verline !! 1) where middle = drop 1 . init diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs index cde33f5d5..3c6816e60 100644 --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -22,18 +22,24 @@ import Assistant.Install.Menu import Control.Applicative import System.Directory import System.Environment +#ifndef mingw32_HOST_OS import System.Posix.User import System.Posix.Files +#endif import System.FilePath import Data.Maybe systemwideInstall :: IO Bool +#ifndef mingw32_HOST_OS systemwideInstall = isroot <||> destdirset where isroot = do uid <- fromIntegral <$> getRealUserID return $ uid == (0 :: Int) destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR") +#else +systemwideInstall = return False +#endif inDestDir :: FilePath -> IO FilePath inDestDir f = do diff --git a/Build/NullSoftInstaller.hs b/Build/NullSoftInstaller.hs new file mode 100644 index 000000000..b9e11fc27 --- /dev/null +++ b/Build/NullSoftInstaller.hs @@ -0,0 +1,114 @@ +{- Generates a NullSoft installer program for git-annex on Windows.
+ -
+ - To build the installer, git-annex should already be built by cabal,
+ - and ssh and rsync, as well as cygwin libraries, already installed.
+ -
+ - This uses the Haskell nsis package (cabal install nsis)
+ - to generate a .nsi file, which is then used to produce
+ - git-annex-installer.exe
+ -
+ - The installer includes git-annex, and utilities it uses, with the
+ - exception of git. The user needs to install git separately,
+ - and the installer checks for that.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+import Development.NSIS
+import System.FilePath
+import Control.Monad
+import System.Directory
+import Data.String
+
+import Utility.Tmp
+import Utility.CopyFile
+import Utility.SafeCommand
+import Build.BundledPrograms
+
+main = do
+ withTmpDir "nsis-build" $ \tmpdir -> do
+ let gitannex = tmpdir </> "git-annex.exe"
+ mustSucceed "ln" [File "dist/build/git-annex/git-annex.exe", File gitannex]
+ writeFile nsifile $ makeInstaller gitannex
+ mustSucceed "C:\\Program Files\\NSIS\\makensis" [File nsifile]
+ removeFile nsifile -- left behind if makensis fails
+ where
+ nsifile = "git-annex.nsi"
+ mustSucceed cmd params = do
+ r <- boolSystem cmd params
+ case r of
+ True -> return ()
+ False -> error $ cmd ++ "failed"
+
+installer :: FilePath
+installer = "git-annex-installer.exe"
+
+gitInstallDir :: Exp FilePath
+gitInstallDir = fromString "$PROGRAMFILES\\Git\\cmd"
+
+needGit :: Exp String
+needGit = strConcat
+ [ fromString "You need git installed to use git-annex. Looking at "
+ , gitInstallDir
+ , fromString " , it seems to not be installed, "
+ , fromString "or may be installed in another location. "
+ , fromString "You can install git from http:////git-scm.com//"
+ ]
+
+makeInstaller :: FilePath -> String
+makeInstaller gitannex = nsis $ do
+ name "git-annex"
+ outFile $ str installer
+ {- Installing into the same directory as git avoids needing to modify
+ - path myself, since the git installer already does it. -}
+ installDir gitInstallDir
+ requestExecutionLevel User
+
+ iff (fileExists gitInstallDir)
+ (return ())
+ (alert needGit)
+
+ -- Pages to display
+ page Directory -- Pick where to install
+ page InstFiles -- Give a progress bar while installing
+ -- Groups of files to install
+ section "programs" [] $ do
+ setOutPath "$INSTDIR"
+ addfile gitannex
+ mapM_ addcygfile cygwinPrograms
+ section "DLLS" [] $ do
+ setOutPath "$INSTDIR"
+ mapM_ addcygfile cygwinDlls
+ where
+ addfile f = file [] (str f)
+ addcygfile f = addfile $ "C:\\cygwin\\bin" </> f
+
+cygwinPrograms :: [FilePath]
+cygwinPrograms = map (\p -> p ++ ".exe") bundledPrograms
+
+-- These are the dlls needed by Cygwin's rsync, ssh, etc.
+cygwinDlls :: [FilePath]
+cygwinDlls =
+ [ "cygwin1.dll"
+ , "cygasn1-8.dll"
+ , "cygheimbase-1.dll"
+ , "cygroken-18.dll"
+ , "cygcom_err-2.dll"
+ , "cygheimntlm-0.dll"
+ , "cygsqlite3-0.dll"
+ , "cygcrypt-0.dll"
+ , "cyghx509-5.dll"
+ , "cygssp-0.dll"
+ , "cygcrypto-1.0.0.dll"
+ , "cygiconv-2.dll"
+ , "cyggcc_s-1.dll"
+ , "cygintl-8.dll"
+ , "cygwind-0.dll"
+ , "cyggssapi-3.dll"
+ , "cygkrb5-26.dll"
+ , "cygz.dll"
+ ]
diff --git a/Build/Standalone.hs b/Build/Standalone.hs index aa4521730..343daf9c9 100644 --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -18,7 +18,7 @@ import System.Directory import System.IO import Control.Monad import Data.List -import Build.SysConfig as SysConfig +import Build.BundledPrograms import Utility.PartialPrelude import Utility.Directory @@ -27,32 +27,6 @@ import Utility.Monad import Utility.SafeCommand import Utility.Path -{- Programs that git-annex uses, to include in the bundle. - - - - These may be just the command name, or the full path to it. -} -thirdpartyProgs :: [FilePath] -thirdpartyProgs = catMaybes - [ Just "git" - , Just "cp" - , Just "xargs" - , Just "gpg" - , Just "rsync" - , Just "ssh" - , Just "sh" - , ifset SysConfig.curl "curl" - , ifset SysConfig.wget "wget" - , ifset SysConfig.bup "bup" - , SysConfig.lsof - , SysConfig.sha1 - , SysConfig.sha256 - , SysConfig.sha512 - , SysConfig.sha224 - , SysConfig.sha384 - ] - where - ifset True s = Just s - ifset False _ = Nothing - progDir :: FilePath -> FilePath #ifdef darwin_HOST_OS progDir topdir = topdir @@ -76,5 +50,5 @@ main = getArgs >>= go go (topdir:_) = do let dir = progDir topdir createDirectoryIfMissing True dir - installed <- forM thirdpartyProgs $ installProg dir + installed <- forM bundledPrograms $ installProg dir writeFile "tmp/standalone-installed" (show installed) diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 9937f799f..8628ebe58 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -4,6 +4,7 @@ module Build.TestConfig where import Utility.Path import Utility.Monad +import Utility.SafeCommand import System.IO import System.Cmd @@ -75,8 +76,8 @@ requireCmd k cmdline = do {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test testCmd k cmdline = do - ret <- system $ quiet cmdline - return $ Config k (BoolConfig $ ret == ExitSuccess) + ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ] + return $ Config k (BoolConfig ok) {- Ensures that one of a set of commands is available by running each in - turn. The Config is set to the first one found. -} @@ -98,8 +99,8 @@ searchCmd success failure cmdsparams = search cmdsparams where search [] = failure $ fst $ unzip cmdsparams search ((c, params):cs) = do - ret <- system $ quiet $ c ++ " " ++ params - if ret == ExitSuccess + ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ] + if ok then success c else search cs diff --git a/CmdLine.hs b/CmdLine.hs index 050f119f1..8f4c99269 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module CmdLine ( dispatch, usage, @@ -15,7 +17,9 @@ import qualified Control.Exception as E import qualified Data.Map as M import Control.Exception (throw) import System.Console.GetOpt +#ifndef __WINDOWS__ import System.Posix.Signals +#endif import Common.Annex import qualified Annex @@ -114,7 +118,9 @@ tryRun' errnum state cmd (a:as) = do {- Actions to perform each time ran. -} startup :: Annex Bool startup = liftIO $ do +#ifndef __WINDOWS__ void $ installHandler sigINT Default Nothing +#endif return True {- Cleanup actions. -} diff --git a/Command/Add.hs b/Command/Add.hs index 68a894d30..95af72a6f 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -9,6 +9,8 @@ module Command.Add where +import System.PosixCompat.Files + import Common.Annex import Annex.Exception import Command diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 32c9c7a15..c40c9e5e9 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -15,7 +15,6 @@ import Init import Config.Files import System.Environment -import System.Posix.Directory def :: [Command] def = [noRepo checkAutoStart $ dontCheck repoExists $ @@ -64,5 +63,5 @@ autoStart = do ) where go program dir = do - changeWorkingDirectory dir + setCurrentDirectory dir boolSystem program [Param "assistant"] diff --git a/Command/Fix.hs b/Command/Fix.hs index 6aedbad6e..c6b4df257 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -7,6 +7,8 @@ module Command.Fix where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex.Queue diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 30b491478..c3d2daafe 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -7,6 +7,8 @@ module Command.FromKey where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex.Queue diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 1c9af0d34..fe1d35162 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -5,8 +5,12 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Command.Fsck where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex @@ -28,7 +32,11 @@ import qualified Option import Types.Key import Utility.HumanTime +#ifndef __WINDOWS__ import System.Posix.Process (getProcessID) +#else +import System.Random (getStdRandom, random) +#endif import Data.Time.Clock.POSIX import Data.Time import System.Posix.Types (EpochTime) @@ -138,10 +146,14 @@ performRemote key file backend numcopies remote = , checkKeyNumCopies key file numcopies ] withtmp a = do - pid <- liftIO getProcessID +#ifndef __WINDOWS__ + v <- liftIO getProcessID +#else + v <- liftIO (getStdRandom random :: IO Int) +#endif t <- fromRepo gitAnnexTmpDir createAnnexDirectory t - let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key + let tmp = t </> "fsck" ++ show v ++ "." ++ keyFile key let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) cleanup cleanup `after` a tmp @@ -449,7 +461,9 @@ recordFsckTime key = do parent <- parentDir <$> calcRepo (gitAnnexLocation key) liftIO $ void $ tryIO $ do touchFile parent +#ifndef __WINDOWS__ setSticky parent +#endif getFsckTime :: Key -> Annex (Maybe EpochTime) getFsckTime key = do diff --git a/Command/Import.hs b/Command/Import.hs index d86b44b80..cadf8fa2e 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -7,6 +7,8 @@ module Command.Import where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 668bebefb..bf1509944 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -7,6 +7,8 @@ module Command.Indirect where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Git diff --git a/Command/ReKey.hs b/Command/ReKey.hs index bc4a9fac9..05fd73f1b 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -7,6 +7,8 @@ module Command.ReKey where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 840fd34cb..c316e2ca5 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -7,6 +7,8 @@ module Command.RecvKey where +import System.PosixCompat.Files + import Common.Annex import Command import CmdLine diff --git a/Command/Status.hs b/Command/Status.hs index 0009ff075..6a50c1ab5 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -13,6 +13,7 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map as M import Text.JSON import Data.Tuple +import System.PosixCompat.Files import Common.Annex import qualified Types.Backend as B diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 53b593f20..6674b37d2 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Command.Unannex where import Common.Annex @@ -58,6 +60,9 @@ cleanup file key = do return True where +#ifdef __WINDOWS__ + goFast = go +#else goFast = do -- fast mode: hard link to content in annex src <- calcRepo $ gitAnnexLocation key @@ -66,6 +71,7 @@ cleanup file key = do ( thawContent file , go ) +#endif go = do fromAnnex key file logStatus key InfoMissing diff --git a/Command/WebApp.hs b/Command/WebApp.hs index b4307a21f..d15319078 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -28,7 +28,6 @@ import qualified Annex import Config.Files import qualified Option -import System.Posix.Directory import Control.Concurrent import Control.Concurrent.STM import System.Process (env, std_out, std_err) @@ -97,7 +96,7 @@ startNoRepo = do case dirs of [] -> firstRun listenhost (d:_) -> do - changeWorkingDirectory d + setCurrentDirectory d state <- Annex.new =<< Git.CurrentRepo.get void $ Annex.eval state $ doCommand $ start' False listenhost @@ -158,7 +157,11 @@ firstRun listenhost = do sendurlback v _origout _origerr url _htmlshim = putMVar v url openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () +#ifdef __ANDROID__ openBrowser mcmd htmlshim realurl outh errh = do +#else +openBrowser mcmd htmlshim _realurl outh errh = do +#endif hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout environ <- cleanEnvironment @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, CPP #-} module Common (module X) where @@ -12,12 +12,13 @@ import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) import Data.String.Utils as X hiding (join) -import "MissingH" System.Path as X import System.FilePath as X import System.Directory as X import System.IO as X hiding (FilePath) -import System.Posix.Files as X +import System.PosixCompat.Files as X +#ifndef mingw32_HOST_OS import System.Posix.IO as X +#endif import System.Exit as X import Utility.Misc as X diff --git a/Config/Files.hs b/Config/Files.hs index 45f478eeb..6504d1f6d 100644 --- a/Config/Files.hs +++ b/Config/Files.hs @@ -8,7 +8,7 @@ module Config.Files where import Common -import Utility.TempFile +import Utility.Tmp import Utility.FreeDesktop {- ~/.config/git-annex/file -} @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Creds where import Common.Annex @@ -13,9 +15,9 @@ import Utility.FileMode import Crypto import Types.Remote (RemoteConfig, RemoteConfigKey) import Remote.Helper.Encryptable (remoteCipher, embedCreds) +import Utility.Env (setEnv) import System.Environment -import System.Posix.Env (setEnv) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import Utility.Base64 @@ -105,12 +107,16 @@ getEnvCredPair storage = liftM2 (,) {- Stores a CredPair in the environment. -} setEnvCredPair :: CredPair -> CredPairStorage -> IO () +#ifndef __WINDOWS__ setEnvCredPair (l, p) storage = do set uenv l set penv p where (uenv, penv) = credPairEnvironment storage - set var val = setEnv var val True + set var val = void $ setEnv var val True +#else +setEnvCredPair _ _ = error "setEnvCredPair TODO" +#endif writeCacheCredPair :: CredPair -> CredPairStorage -> Annex () writeCacheCredPair credpair storage = @@ -8,6 +8,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Git ( Repo(..), Ref(..), @@ -30,7 +32,9 @@ module Git ( ) where import Network.URI (uriPath, uriScheme, unEscapeString) +#ifndef __WINDOWS__ import System.Posix.Files +#endif import Common import Git.Types @@ -127,4 +131,8 @@ hookPath script repo = do ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where +#if __WINDOWS__ + isexecutable f = doesFileExist f +#else isexecutable f = isExecutable . fileMode <$> getFileStatus f +#endif diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 704724211..5ab10b187 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -23,12 +23,13 @@ import Git import Git.Sha import Git.Command import Git.Types +import Git.FilePath import qualified Utility.CoProcess as CoProcess type CatFileHandle = CoProcess.CoProcessHandle catFileStart :: Repo -> IO CatFileHandle -catFileStart = gitCoProcessStart +catFileStart = CoProcess.rawMode <=< gitCoProcessStart [ Param "cat-file" , Param "--batch" ] @@ -38,7 +39,8 @@ catFileStop = CoProcess.stop {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString -catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file +catFile h branch file = catObject h $ Ref $ + show branch ++ ":" ++ toInternalGitPath file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -49,11 +51,8 @@ catObject h object = maybe L.empty fst <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) catObjectDetails h object = CoProcess.query h send receive where - send to = do - fileEncoding to - hPutStrLn to $ show object + send to = hPutStrLn to $ show object receive from = do - fileEncoding from header <- hGetLine from case words header of [sha, objtype, size] @@ -68,8 +67,10 @@ catObjectDetails h object = CoProcess.query h send receive | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) readcontent bytes from sha = do content <- S.hGet from bytes - c <- hGetChar from - when (c /= '\n') $ - error "missing newline from git cat-file" + eatchar '\n' from return $ Just (L.fromChunks [content], Ref sha) dne = return Nothing + eatchar expected from = do + c <- hGetChar from + when (c /= expected) $ + error $ "missing " ++ (show expected) ++ " from git cat-file" diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index f9279d460..b3055fd4c 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -22,7 +22,7 @@ type Attr = String checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart attrs repo = do cwd <- getCurrentDirectory - h <- gitCoProcessStart params repo + h <- CoProcess.rawMode =<< gitCoProcessStart params repo return (h, attrs, cwd) where params = @@ -43,11 +43,8 @@ checkAttr (h, attrs, cwd) want file = do [v] -> return v _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file where - send to = do - fileEncoding to - hPutStr to $ file' ++ "\0" + send to = hPutStr to $ file' ++ "\0" receive from = forM attrs $ \attr -> do - fileEncoding from l <- hGetLine from return (attr, attrvalue attr l) {- Before git 1.7.7, git check-attr worked best with diff --git a/Git/Construct.hs b/Git/Construct.hs index 12eae54c3..54eb84e22 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -25,13 +25,16 @@ module Git.Construct ( {-# LANGUAGE CPP #-} +#ifndef __WINDOWS__ import System.Posix.User +#endif import qualified Data.Map as M hiding (map, split) import Network.URI import Common import Git.Types import Git +import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo @@ -56,8 +59,7 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | "/" `isPrefixOf` dir = - ifM (doesDirectoryExist dir') ( ret dir' , hunt ) + | isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where @@ -69,7 +71,7 @@ fromAbsPath dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} hunt - | "/.git" `isSuffixOf` canondir = + | (pathSeparator:".git") `isSuffixOf` canondir = ifM (doesDirectoryExist $ dir </> ".git") ( ret dir , ret $ takeDirectory canondir @@ -144,7 +146,7 @@ fromRemoteLocation s repo = gen $ calcloc s where gen v #ifdef __WINDOWS__ - | dosstyle v = fromRemotePath v repo + | dosstyle v = fromRemotePath (dospath v) repo #endif | scpstyle v = fromUrl $ scptourl v | urlstyle v = fromUrl v @@ -183,6 +185,7 @@ fromRemoteLocation s repo = gen $ calcloc s -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive + dospath = fromInternalGitPath #endif {- Constructs a Repo from the path specified in the git remotes of @@ -204,6 +207,9 @@ repoAbsPath d = do return $ h </> d' expandTilde :: FilePath -> IO FilePath +#ifdef __WINDOWS__ +expandTilde = return +#else expandTilde = expandt True where expandt _ [] = return "" @@ -224,6 +230,7 @@ expandTilde = expandt True findname n (c:cs) | c == '/' = (n, cs) | otherwise = findname (n++[c]) cs +#endif {- Checks if a git repository exists in a directory. Does not find - git repositories in parent directories. -} diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 482873960..2a8807488 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -5,15 +5,15 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Git.CurrentRepo where +{-# LANGUAGE CPP #-} -import System.Posix.Directory (changeWorkingDirectory) -import System.Posix.Env (getEnv, unsetEnv) +module Git.CurrentRepo where import Common import Git.Types import Git.Construct import qualified Git.Config +import Utility.Env {- Gets the current git repository. - @@ -37,16 +37,20 @@ get = do Just d -> do cwd <- getCurrentDirectory unless (d `dirContains` cwd) $ - changeWorkingDirectory d + setCurrentDirectory d return $ addworktree wt r where pathenv s = do +#ifndef __WINDOWS__ v <- getEnv s case v of Just d -> do - unsetEnv s + void $ unsetEnv s Just <$> absPath d Nothing -> return Nothing +#else + return Nothing +#endif configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do diff --git a/Git/FilePath.hs b/Git/FilePath.hs index 6344353d6..c3813fe9e 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,16 +5,21 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Git.FilePath ( TopFilePath, getTopFilePath, toTopFilePath, asTopFilePath, + InternalGitPath, + toInternalGitPath, + fromInternalGitPath ) where import Common @@ -32,3 +37,22 @@ toTopFilePath file repo = TopFilePath <$> - repository -} asTopFilePath :: FilePath -> TopFilePath asTopFilePath file = TopFilePath file + +{- Git may use a different representation of a path when storing + - it internally. For example, on Windows, git uses '/' to separate paths + - stored in the repository, despite Windows using '\' -} +type InternalGitPath = String + +toInternalGitPath :: FilePath -> InternalGitPath +#ifndef __WINDOWS__ +toInternalGitPath = id +#else +toInternalGitPath = replace "\\" "/" +#endif + +fromInternalGitPath :: InternalGitPath -> FilePath +#ifndef __WINDOWS__ +fromInternalGitPath = id +#else +fromInternalGitPath = replace "/" "\\" +#endif diff --git a/Git/HashObject.hs b/Git/HashObject.hs index b4a32ef1c..bf3ca7f8b 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -17,7 +17,7 @@ import qualified Utility.CoProcess as CoProcess type HashObjectHandle = CoProcess.CoProcessHandle hashObjectStart :: Repo -> IO HashObjectHandle -hashObjectStart = gitCoProcessStart +hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart [ Param "hash-object" , Param "-w" , Param "--stdin-paths" @@ -30,16 +30,13 @@ hashObjectStop = CoProcess.stop hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = do - fileEncoding to - hPutStrLn to file + send to = hPutStrLn to file receive from = getSha "hash-object" $ hGetLine from {- Injects some content into git, returning its Sha. -} hashObject :: ObjectType -> String -> Repo -> IO Sha -hashObject objtype content repo = getSha subcmd $ do - s <- pipeWriteRead (map Param params) content repo - return s +hashObject objtype content repo = getSha subcmd $ + pipeWriteRead (map Param params) content repo where subcmd = "hash-object" params = [subcmd, "-t", show objtype, "-w", "--stdin"] diff --git a/Git/Index.hs b/Git/Index.hs index 80196ef78..5b660bb30 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -7,7 +7,7 @@ module Git.Index where -import System.Posix.Env (setEnv, unsetEnv, getEnv) +import Utility.Env {- Forces git to use the specified index file. - diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index aa65b4429..5d07e2011 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011, 2012 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module Git.UpdateIndex ( Streamer, @@ -59,13 +59,13 @@ lsTree (Ref x) repo streamer = do - a given file with a given sha. -} updateIndexLine :: Sha -> BlobType -> TopFilePath -> String updateIndexLine sha filetype file = - show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file + show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do p <- toTopFilePath file repo - return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p + return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer @@ -75,3 +75,6 @@ stageSymlink file sha repo = do <*> pure SymlinkBlob <*> toTopFilePath file repo return $ pureStreamer line + +indexPath :: TopFilePath -> InternalGitPath +indexPath = toInternalGitPath . getTopFilePath diff --git a/GitAnnex.hs b/GitAnnex.hs index 211d79ef3..ef6e0303a 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -23,7 +23,9 @@ import qualified Command.Get import qualified Command.FromKey import qualified Command.DropKey import qualified Command.TransferKey +#ifndef __WINDOWS__ import qualified Command.TransferKeys +#endif import qualified Command.ReKey import qualified Command.Reinject import qualified Command.Fix @@ -73,8 +75,10 @@ import qualified Command.XMPPGit #endif #endif #ifdef WITH_TESTSUITE +#ifndef __WINDOWS__ import qualified Command.Test #endif +#endif cmds :: [Command] cmds = concat @@ -107,7 +111,9 @@ cmds = concat , Command.FromKey.def , Command.DropKey.def , Command.TransferKey.def +#ifndef __WINDOWS__ , Command.TransferKeys.def +#endif , Command.ReKey.def , Command.Fix.def , Command.Fsck.def @@ -137,8 +143,10 @@ cmds = concat #endif #endif #ifdef WITH_TESTSUITE +#ifndef __WINDOWS__ , Command.Test.def #endif +#endif ] header :: String diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index 31912ebbe..6f03ac73b 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -7,7 +7,7 @@ module GitAnnexShell where -import System.Posix.Env +import System.Environment import System.Console.GetOpt import Common.Annex @@ -145,7 +145,7 @@ checkNotReadOnly cmd checkDirectory :: Maybe FilePath -> IO () checkDirectory mdir = do - v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY" + v <- catchMaybeIO $ getEnv "GIT_ANNEX_SHELL_DIRECTORY" case (v, mdir) of (Nothing, _) -> noop (Just d, Nothing) -> req d Nothing @@ -175,7 +175,7 @@ checkDirectory mdir = do checkEnv :: String -> IO () checkEnv var = do - v <- getEnv var + v <- catchMaybeIO $ getEnv var case v of Nothing -> noop Just "" -> noop @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Init ( ensureInitialized, isInitialized, @@ -14,8 +16,9 @@ module Init ( ) where import Common.Annex -import Utility.TempFile +import Utility.Tmp import Utility.Network +import qualified Annex import qualified Git import qualified Git.LsFiles import qualified Git.Config @@ -34,11 +37,15 @@ import Backend genDescription :: Maybe String -> Annex String genDescription (Just d) = return d genDescription Nothing = do + reldir <- liftIO . relHome =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname +#ifndef __WINDOWS__ let at = if null hostname then "" else "@" username <- liftIO myUserName - reldir <- liftIO . relHome =<< fromRepo Git.repoPath return $ concat [username, at, hostname, ":", reldir] +#else + return $ concat [hostname, ":", reldir] +#endif initialize :: Maybe String -> Annex () initialize mdescription = do @@ -111,8 +118,13 @@ preCommitScript = unlines , "git annex pre-commit ." ] +{- A crippled filesystem is one that does not allow making symlinks, + - or removing write access from files. -} probeCrippledFileSystem :: Annex Bool probeCrippledFileSystem = do +#ifdef __WINDOWS__ + return True +#else tmp <- fromRepo gitAnnexTmpDir let f = tmp </> "gaprobe" liftIO $ do @@ -132,11 +144,21 @@ probeCrippledFileSystem = do preventWrite f allowWrite f return True +#endif checkCrippledFileSystem :: Annex () checkCrippledFileSystem = whenM probeCrippledFileSystem $ do warning "Detected a crippled filesystem." setCrippledFileSystem True + + {- Normally git disables core.symlinks itself when the filesystem does + - not support them, but in Cygwin, git does support symlinks, while + - git-annex, not linking with Cygwin, does not. -} + whenM (coreSymlinks <$> Annex.getGitConfig) $ do + warning "Disabling core.symlinks." + setConfig (ConfigKey "core.symlinks") + (Git.Config.boolConfig False) + unlessM isDirect $ do warning "Enabling direct mode." top <- fromRepo Git.repoPath @@ -149,6 +171,9 @@ checkCrippledFileSystem = whenM probeCrippledFileSystem $ do probeFifoSupport :: Annex Bool probeFifoSupport = do +#ifdef __WINDOWS__ + return False +#else tmp <- fromRepo gitAnnexTmpDir let f = tmp </> "gaprobe" liftIO $ do @@ -159,6 +184,7 @@ probeFifoSupport = do getFileStatus f nukeFile f return $ either (const False) isNamedPipe ms +#endif checkFifoSupport :: Annex () checkFifoSupport = unlessM probeFifoSupport $ do @@ -19,6 +19,7 @@ import Text.Regex.TDFA.String #else import System.Path.WildMatch #endif +import System.PosixCompat.Files import Common.Annex import qualified Annex diff --git a/Locations.hs b/Locations.hs index cb98b840c..ba1e74150 100644 --- a/Locations.hs +++ b/Locations.hs @@ -259,7 +259,7 @@ gitAnnexAssistantDefaultDir = "annex" - than .git to be used. -} isLinkToAnnex :: FilePath -> Bool -isLinkToAnnex s = ('/':objectDir) `isInfixOf` s +isLinkToAnnex s = (pathSeparator:objectDir) `isInfixOf` s {- Converts a key into a filename fragment without any directory. - diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index cfe9e49a0..6f28ef115 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Logs.Transfer where import Common.Annex @@ -122,6 +124,7 @@ runTransfer t file shouldretry a = do return ok where prep tfile mode info = do +#ifndef __WINDOWS__ mfd <- catchMaybeIO $ openFd (transferLockFile tfile) ReadWrite (Just mode) defaultFileFlags { trunc = True } @@ -134,11 +137,18 @@ runTransfer t file shouldretry a = do error "transfer already in progress" void $ tryIO $ writeTransferInfoFile info tfile return mfd +#else + catchMaybeIO $ do + writeFile (transferLockFile tfile) "" + writeTransferInfoFile info tfile +#endif cleanup _ Nothing = noop cleanup tfile (Just fd) = do void $ tryIO $ removeFile tfile void $ tryIO $ removeFile $ transferLockFile tfile +#ifndef __WINDOWS__ closeFd fd +#endif retry oldinfo metervar run = do v <- tryAnnex run case v of @@ -195,8 +205,9 @@ startTransferInfo file = TransferInfo {- If a transfer is still running, returns its TransferInfo. -} checkTransfer :: Transfer -> Annex (Maybe TransferInfo) checkTransfer t = do - mode <- annexFileMode tfile <- fromRepo $ transferFile t +#ifndef __WINDOWS__ + mode <- annexFileMode mfd <- liftIO $ catchMaybeIO $ openFd (transferLockFile tfile) ReadOnly (Just mode) defaultFileFlags case mfd of @@ -209,6 +220,13 @@ checkTransfer t = do Nothing -> return Nothing Just (pid, _) -> liftIO $ catchDefaultIO Nothing $ readTransferInfoFile (Just pid) tfile +#else + ifM (liftIO $ doesFileExist $ transferLockFile tfile) + ( liftIO $ catchDefaultIO Nothing $ + readTransferInfoFile Nothing tfile + , return Nothing + ) +#endif {- Gets all currently running transfers. -} getTransfers :: Annex [(Transfer, TransferInfo)] diff --git a/Logs/Unused.hs b/Logs/Unused.hs index 437b01f71..342d88aa6 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -19,7 +19,7 @@ import qualified Data.Map as M import Common.Annex import Command import Types.Key -import Utility.TempFile +import Utility.Tmp writeUnusedLog :: FilePath -> [(Int, Key)] -> Annex () writeUnusedLog prefix l = do diff --git a/Remote/Directory.hs b/Remote/Directory.hs index d3885e89e..c960bb1b4 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Remote.Directory (remote) where import qualified Data.ByteString.Lazy as L @@ -217,10 +219,14 @@ retrieveEncrypted d chunksize (cipher, enck) k f p = metered (Just p) k $ \meter retrieveCheap :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool retrieveCheap _ (Just _) _ _ = return False -- no cheap retrieval for chunks +#ifndef __WINDOWS__ retrieveCheap d _ k f = liftIO $ withStoredFiles Nothing d k go where go [file] = catchBoolIO $ createSymbolicLink file f >> return True go _files = return False +#else +retrieveCheap _ _ _ _ = return False +#endif remove :: FilePath -> Key -> Annex Bool remove d k = liftIO $ do diff --git a/Remote/Git.hs b/Remote/Git.hs index 752d70d23..215cd590f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Remote.Git ( remote, configRead, @@ -18,6 +20,7 @@ import Common.Annex import Utility.CopyFile import Utility.Rsync import Remote.Helper.Ssh +import Annex.Ssh import Types.Remote import Types.GitConfig import qualified Git @@ -33,7 +36,7 @@ import qualified Annex.Content import qualified Annex.BranchState import qualified Annex.Branch import qualified Utility.Url as Url -import Utility.TempFile +import Utility.Tmp import Config import Config.Cost import Init @@ -177,7 +180,7 @@ tryGitConfigRead r geturlconfig headers = do s <- Url.get (Git.repoLocation r ++ "/config") headers - withTempFile "git-annex.tmp" $ \tmpfile h -> do + withTmpFile "git-annex.tmp" $ \tmpfile h -> do hPutStr h s hClose h safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] @@ -306,6 +309,8 @@ copyFromRemote' r key file dest - git-annex-shell transferinfo at the same time - git-annex-shell sendkey is running. - + - To avoid extra password prompts, this is only done when ssh + - connection caching is supported. - Note that it actually waits for rsync to indicate - progress before starting transferinfo, in order - to ensure ssh connection caching works and reuses @@ -314,7 +319,11 @@ copyFromRemote' r key file dest - Also note that older git-annex-shell does not support - transferinfo, so stderr is dropped and failure ignored. -} - feedprogressback a = do + feedprogressback a = ifM (isJust <$> sshCacheDir) + ( feedprogressback' a + , bracketIO noop (const noop) (a $ const noop) + ) + feedprogressback' a = do u <- getUUID let fields = (Fields.remoteUUID, fromUUID u) : maybe [] (\f -> [(Fields.associatedFile, f)]) file @@ -341,6 +350,7 @@ copyFromRemote' r key file dest copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool copyFromRemoteCheap r key file +#ifndef __WINDOWS__ | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do loc <- liftIO $ gitAnnexLocation key (repo r) $ fromJust $ remoteGitConfig $ gitconfig r @@ -350,6 +360,7 @@ copyFromRemoteCheap r key file ( copyFromRemote' r key Nothing file , return False ) +#endif | otherwise = return False {- Tries to copy a key's content to a remote's annex. -} @@ -396,12 +407,14 @@ rsyncHelper callback params = do - filesystem. Then cp could be faster. -} rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool rsyncOrCopyFile rsyncparams src dest p = +#ifdef __WINDOWS__ + dorsync + where +#else ifM (sameDeviceIds src dest) (docopy, dorsync) where sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b) getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f) - dorsync = rsyncHelper (Just p) $ - rsyncparams ++ [Param src, Param dest] docopy = liftIO $ bracket (forkIO $ watchfilesize zeroBytesProcessed) (void . tryIO . killThread) @@ -417,6 +430,9 @@ rsyncOrCopyFile rsyncparams src dest p = p sz watchfilesize sz _ -> watchfilesize oldsz +#endif + dorsync = rsyncHelper (Just p) $ + rsyncparams ++ [File src, File dest] {- Generates rsync parameters that ssh to the remote and asks it - to either receive or send the key's content. -} diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index 1aeb6cdcd..dfc543d0a 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Remote.Helper.Hooks (addHooks) where import qualified Data.Map as M @@ -70,6 +72,7 @@ runHooks r starthook stophook a = do Annex.addCleanup (remoteid ++ "-stop-command") $ runstop lck runstop lck = do +#ifndef __WINDOWS__ -- Drop any shared lock we have, and take an -- exclusive lock, without blocking. If the lock -- succeeds, we're the only process using this remote, @@ -84,3 +87,6 @@ runHooks r starthook stophook a = do Left _ -> noop Right _ -> run stophook liftIO $ closeFd fd +#else + run stophook +#endif diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 58b66b74b..f7abbbf2a 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -5,11 +5,17 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Remote.Rsync (remote) where import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +#ifndef __WINDOWS__ import System.Posix.Process (getProcessID) +#else +import System.Random (getStdRandom, random) +#endif import Common.Annex import Types.Remote @@ -215,10 +221,14 @@ sendParams = ifM crippledFileSystem - up trees for rsync. -} withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool withRsyncScratchDir a = do - pid <- liftIO getProcessID +#ifndef __WINDOWS__ + v <- liftIO getProcessID +#else + v <- liftIO (getStdRandom random :: IO Int) +#endif t <- fromRepo gitAnnexTmpDir createAnnexDirectory t - let tmp = t </> "rsynctmp" </> show pid + let tmp = t </> "rsynctmp" </> show v nuke tmp liftIO $ createDirectoryIfMissing True tmp nuke tmp `after` a tmp @@ -232,7 +242,7 @@ rsyncRetrieve o k dest callback = -- use inplace when retrieving to support resuming [ Param "--inplace" , Param u - , Param dest + , File dest ] rsyncRemote :: RsyncOpts -> (Maybe MeterUpdate) -> [CommandParam] -> Annex Bool @@ -269,8 +279,12 @@ rsyncSend o callback k canrename src = withRsyncScratchDir $ \tmp -> do else ifM crippledFileSystem ( liftIO $ copyFileExternal src dest , do +#ifndef __WINDOWS__ liftIO $ createLink src dest return True +#else + liftIO $ copyFileExternal src dest +#endif ) ps <- sendParams if ok @@ -278,7 +292,7 @@ rsyncSend o callback k canrename src = withRsyncScratchDir $ \tmp -> do [ Param "--recursive" , partialParams -- tmp/ to send contents of tmp dir - , Param $ addTrailingPathSeparator tmp + , File $ addTrailingPathSeparator tmp , Param $ rsyncUrl o ] else return False @@ -11,6 +11,8 @@ module Seek where +import System.PosixCompat.Files + import Common.Annex import Types.Command import Types.Key @@ -11,13 +11,12 @@ import Test.HUnit import Test.QuickCheck import Test.QuickCheck.Test -import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Files -import System.Posix.Env import Control.Exception.Extensible import qualified Data.Map as M import System.IO.HVFS (SystemFS(..)) import qualified Text.JSON +import System.Path import Common @@ -42,6 +41,7 @@ import qualified Logs.Presence import qualified Remote import qualified Types.Key import qualified Types.Messages +import qualified Config import qualified Config.Cost import qualified Crypto import qualified Utility.Path @@ -53,6 +53,9 @@ import qualified Utility.Verifiable import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache +import qualified Utility.Env + +type TestEnv = M.Map String String main :: IO () main = do @@ -64,10 +67,10 @@ main = do putStrLn "Now, some broader checks ..." putStrLn " (Do not be alarmed by odd output here; it's normal." putStrLn " wait for the last line to see how it went.)" - prepare + env <- prepare rs <- forM hunit $ \t -> do divider - t + t env cleanup tmpdir divider propigate rs qcok @@ -119,7 +122,7 @@ quickcheck = putStrLn desc quickCheckResult prop -hunit :: [IO Counts] +hunit :: [TestEnv -> IO Counts] hunit = -- test order matters, later tests may rely on state from earlier [ check "init" test_init @@ -155,210 +158,210 @@ hunit = , check "crypto" test_crypto ] where - check desc t = do + check desc t env = do putStrLn desc - runTestTT t + runTestTT (t env) -test_init :: Test -test_init = "git-annex init" ~: TestCase $ innewrepo $ do - git_annex "init" [reponame] @? "init failed" +test_init :: TestEnv -> Test +test_init env = "git-annex init" ~: TestCase $ innewrepo env $ do + git_annex env "init" [reponame] @? "init failed" where reponame = "test repo" -test_add :: Test -test_add = "git-annex add" ~: TestList [basic, sha1dup, subdirs] +test_add :: TestEnv -> Test +test_add env = "git-annex add" ~: TestList [basic, sha1dup, subdirs] where -- this test case runs in the main repo, to set up a basic -- annexed file that later tests will use - basic = TestCase $ inmainrepo $ do + basic = TestCase $ inmainrepo env $ do writeFile annexedfile $ content annexedfile - git_annex "add" [annexedfile] @? "add failed" + git_annex env "add" [annexedfile] @? "add failed" annexed_present annexedfile writeFile sha1annexedfile $ content sha1annexedfile - git_annex "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" + git_annex env "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" annexed_present sha1annexedfile checkbackend sha1annexedfile backendSHA1 writeFile wormannexedfile $ content wormannexedfile - git_annex "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" + git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" annexed_present wormannexedfile checkbackend wormannexedfile backendWORM boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" writeFile ingitfile $ content ingitfile boolSystem "git" [Param "add", File ingitfile] @? "git add failed" boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed" - git_annex "add" [ingitfile] @? "add ingitfile should be no-op" + git_annex env "add" [ingitfile] @? "add ingitfile should be no-op" unannexed ingitfile - sha1dup = TestCase $ intmpclonerepo $ do + sha1dup = TestCase $ intmpclonerepo env $ do writeFile sha1annexedfiledup $ content sha1annexedfiledup - git_annex "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" + git_annex env "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" annexed_present sha1annexedfiledup annexed_present sha1annexedfile - subdirs = TestCase $ intmpclonerepo $ do + subdirs = TestCase $ intmpclonerepo env $ do createDirectory "dir" writeFile "dir/foo" $ content annexedfile - git_annex "add" ["dir"] @? "add of subdir failed" + git_annex env "add" ["dir"] @? "add of subdir failed" createDirectory "dir2" writeFile "dir2/foo" $ content annexedfile - changeWorkingDirectory "dir" - git_annex "add" ["../dir2"] @? "add of ../subdir failed" + setCurrentDirectory "dir" + git_annex env "add" ["../dir2"] @? "add of ../subdir failed" -test_reinject :: Test -test_reinject = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepo $ do - git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" +test_reinject :: TestEnv -> Test +test_reinject env = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepo env $ do + git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed" writeFile tmp $ content sha1annexedfile r <- annexeval $ Types.Backend.getKey backendSHA1 $ Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp, Types.KeySource.inodeCache = Nothing } let key = Types.Key.key2file $ fromJust r - git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" - git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed" + git_annex env "reinject" [tmp, sha1annexedfile] @? "reinject failed" + git_annex env "fromkey" [key, sha1annexedfiledup] @? "fromkey failed" annexed_present sha1annexedfiledup where tmp = "tmpfile" -test_unannex :: Test -test_unannex = "git-annex unannex" ~: TestList [nocopy, withcopy] +test_unannex :: TestEnv -> Test +test_unannex env = "git-annex unannex" ~: TestList [nocopy, withcopy] where - nocopy = "no content" ~: intmpclonerepo $ do + nocopy = "no content" ~: intmpclonerepo env $ do annexed_notpresent annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed with no copy" + git_annex env "unannex" [annexedfile] @? "unannex failed with no copy" annexed_notpresent annexedfile - withcopy = "with content" ~: intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + withcopy = "with content" ~: intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" + git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" unannexed annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed on non-annexed file" + git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file" unannexed annexedfile - git_annex "unannex" [ingitfile] @? "unannex ingitfile should be no-op" + git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op" unannexed ingitfile -test_drop :: Test -test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] +test_drop :: TestEnv -> Test +test_drop env = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] where - noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + noremote = "no remotes" ~: TestCase $ intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" boolSystem "git" [Params "remote rm origin"] @? "git remote rm origin failed" - not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" + not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" annexed_present annexedfile - git_annex "drop" ["--force", annexedfile] @? "drop --force failed" + git_annex env "drop" ["--force", annexedfile] @? "drop --force failed" annexed_notpresent annexedfile - git_annex "drop" [annexedfile] @? "drop of dropped file failed" - git_annex "drop" [ingitfile] @? "drop ingitfile should be no-op" + git_annex env "drop" [annexedfile] @? "drop of dropped file failed" + git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op" unannexed ingitfile - withremote = "with remote" ~: TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + withremote = "with remote" ~: TestCase $ intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex "drop" [annexedfile] @? "drop failed though origin has copy" + git_annex env "drop" [annexedfile] @? "drop failed though origin has copy" annexed_notpresent annexedfile - inmainrepo $ annexed_present annexedfile - untrustedremote = "untrusted remote" ~: TestCase $ intmpclonerepo $ do - git_annex "untrust" ["origin"] @? "untrust of origin failed" - git_annex "get" [annexedfile] @? "get failed" + inmainrepo env $ annexed_present annexedfile + untrustedremote = "untrusted remote" ~: TestCase $ intmpclonerepo env $ do + git_annex env "untrust" ["origin"] @? "untrust of origin failed" + git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile - not <$> git_annex "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" + not <$> git_annex env "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" annexed_present annexedfile - inmainrepo $ annexed_present annexedfile + inmainrepo env $ annexed_present annexedfile -test_get :: Test -test_get = "git-annex get" ~: TestCase $ intmpclonerepo $ do - inmainrepo $ annexed_present annexedfile +test_get :: TestEnv -> Test +test_get env = "git-annex get" ~: TestCase $ intmpclonerepo env $ do + inmainrepo env $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex "get" [annexedfile] @? "get of file failed" - inmainrepo $ annexed_present annexedfile + git_annex env "get" [annexedfile] @? "get of file failed" + inmainrepo env $ annexed_present annexedfile annexed_present annexedfile - git_annex "get" [annexedfile] @? "get of file already here failed" - inmainrepo $ annexed_present annexedfile + git_annex env "get" [annexedfile] @? "get of file already here failed" + inmainrepo env $ annexed_present annexedfile annexed_present annexedfile - inmainrepo $ unannexed ingitfile + inmainrepo env $ unannexed ingitfile unannexed ingitfile - git_annex "get" [ingitfile] @? "get ingitfile should be no-op" - inmainrepo $ unannexed ingitfile + git_annex env "get" [ingitfile] @? "get ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile unannexed ingitfile -test_move :: Test -test_move = "git-annex move" ~: TestCase $ intmpclonerepo $ do +test_move :: TestEnv -> Test +test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do annexed_notpresent annexedfile - inmainrepo $ annexed_present annexedfile - git_annex "move" ["--from", "origin", annexedfile] @? "move --from of file failed" + inmainrepo env $ annexed_present annexedfile + git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file failed" annexed_present annexedfile - inmainrepo $ annexed_notpresent annexedfile - git_annex "move" ["--from", "origin", annexedfile] @? "move --from of file already here failed" + inmainrepo env $ annexed_notpresent annexedfile + git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file already here failed" annexed_present annexedfile - inmainrepo $ annexed_notpresent annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file failed" - inmainrepo $ annexed_present annexedfile + inmainrepo env $ annexed_notpresent annexedfile + git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file failed" + inmainrepo env $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" - inmainrepo $ annexed_present annexedfile + git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + inmainrepo env $ annexed_present annexedfile annexed_notpresent annexedfile unannexed ingitfile - inmainrepo $ unannexed ingitfile - git_annex "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile + git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" unannexed ingitfile - inmainrepo $ unannexed ingitfile - git_annex "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile + git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" unannexed ingitfile - inmainrepo $ unannexed ingitfile + inmainrepo env $ unannexed ingitfile -test_copy :: Test -test_copy = "git-annex copy" ~: TestCase $ intmpclonerepo $ do +test_copy :: TestEnv -> Test +test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do annexed_notpresent annexedfile - inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" + inmainrepo env $ annexed_present annexedfile + git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" annexed_present annexedfile - inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--from", "origin", annexedfile] @? "copy --from of file already here failed" + inmainrepo env $ annexed_present annexedfile + git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file already here failed" annexed_present annexedfile - inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--to", "origin", annexedfile] @? "copy --to of file already there failed" + inmainrepo env $ annexed_present annexedfile + git_annex env "copy" ["--to", "origin", annexedfile] @? "copy --to of file already there failed" annexed_present annexedfile - inmainrepo $ annexed_present annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + inmainrepo env $ annexed_present annexedfile + git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" annexed_notpresent annexedfile - inmainrepo $ annexed_present annexedfile + inmainrepo env $ annexed_present annexedfile unannexed ingitfile - inmainrepo $ unannexed ingitfile - git_annex "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile + git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" unannexed ingitfile - inmainrepo $ unannexed ingitfile - git_annex "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile + git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" checkregularfile ingitfile checkcontent ingitfile -test_lock :: Test -test_lock = "git-annex unlock/lock" ~: intmpclonerepo $ do +test_lock :: TestEnv -> Test +test_lock env = "git-annex unlock/lock" ~: intmpclonerepo env $ do -- regression test: unlock of not present file should skip it annexed_notpresent annexedfile - not <$> git_annex "unlock" [annexedfile] @? "unlock failed to fail with not present file" + not <$> git_annex env "unlock" [annexedfile] @? "unlock failed to fail with not present file" annexed_notpresent annexedfile - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex env "unlock" [annexedfile] @? "unlock failed" unannexed annexedfile -- write different content, to verify that lock -- throws it away changecontent annexedfile writeFile annexedfile $ content annexedfile ++ "foo" - git_annex "lock" [annexedfile] @? "lock failed" + git_annex env "lock" [annexedfile] @? "lock failed" annexed_present annexedfile - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex env "unlock" [annexedfile] @? "unlock failed" unannexed annexedfile changecontent annexedfile - git_annex "add" [annexedfile] @? "add of modified file failed" + git_annex env "add" [annexedfile] @? "add of modified file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - r' <- git_annex "drop" [annexedfile] + r' <- git_annex env "drop" [annexedfile] not r' @? "drop wrongly succeeded with no known copy of modified file" -test_edit :: Test -test_edit = "git-annex edit/commit" ~: TestList [t False, t True] - where t precommit = TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get of file failed" +test_edit :: TestEnv -> Test +test_edit env = "git-annex edit/commit" ~: TestList [t False, t True] + where t precommit = TestCase $ intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "edit" [annexedfile] @? "edit failed" + git_annex env "edit" [annexedfile] @? "edit failed" unannexed annexedfile changecontent annexedfile if precommit @@ -367,7 +370,7 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True] -- staged, normally git commit does this boolSystem "git" [Param "add", File annexedfile] @? "git add of edited file failed" - git_annex "pre-commit" [] + git_annex env "pre-commit" [] @? "pre-commit failed" else do boolSystem "git" [Params "commit -q -a -m contentchanged"] @@ -375,21 +378,21 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True] runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" + not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" -test_fix :: Test -test_fix = "git-annex fix" ~: intmpclonerepo $ do +test_fix :: TestEnv -> Test +test_fix env = "git-annex fix" ~: intmpclonerepo env $ do annexed_notpresent annexedfile - git_annex "fix" [annexedfile] @? "fix of not present failed" + git_annex env "fix" [annexedfile] @? "fix of not present failed" annexed_notpresent annexedfile - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "fix" [annexedfile] @? "fix of present file failed" + git_annex env "fix" [annexedfile] @? "fix of present file failed" annexed_present annexedfile createDirectory subdir boolSystem "git" [Param "mv", File annexedfile, File subdir] @? "git mv failed" - git_annex "fix" [newfile] @? "fix of moved file failed" + git_annex env "fix" [newfile] @? "fix of moved file failed" runchecks [checklink, checkunwritable] newfile c <- readFile newfile assertEqual "content of moved file" c (content annexedfile) @@ -397,23 +400,23 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do subdir = "s" newfile = subdir ++ "/" ++ annexedfile -test_trust :: Test -test_trust = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo $ do - git_annex "trust" [repo] @? "trust failed" +test_trust :: TestEnv -> Test +test_trust env = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo env $ do + git_annex env "trust" [repo] @? "trust failed" trustcheck Logs.Trust.Trusted "trusted 1" - git_annex "trust" [repo] @? "trust of trusted failed" + git_annex env "trust" [repo] @? "trust of trusted failed" trustcheck Logs.Trust.Trusted "trusted 2" - git_annex "untrust" [repo] @? "untrust failed" + git_annex env "untrust" [repo] @? "untrust failed" trustcheck Logs.Trust.UnTrusted "untrusted 1" - git_annex "untrust" [repo] @? "untrust of untrusted failed" + git_annex env "untrust" [repo] @? "untrust of untrusted failed" trustcheck Logs.Trust.UnTrusted "untrusted 2" - git_annex "dead" [repo] @? "dead failed" + git_annex env "dead" [repo] @? "dead failed" trustcheck Logs.Trust.DeadTrusted "deadtrusted 1" - git_annex "dead" [repo] @? "dead of dead failed" + git_annex env "dead" [repo] @? "dead of dead failed" trustcheck Logs.Trust.DeadTrusted "deadtrusted 2" - git_annex "semitrust" [repo] @? "semitrust failed" + git_annex env "semitrust" [repo] @? "semitrust failed" trustcheck Logs.Trust.SemiTrusted "semitrusted 1" - git_annex "semitrust" [repo] @? "semitrust of semitrusted failed" + git_annex env "semitrust" [repo] @? "semitrust of semitrusted failed" trustcheck Logs.Trust.SemiTrusted "semitrusted 2" where repo = "origin" @@ -424,64 +427,64 @@ test_trust = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo $ do return $ u `elem` l assertBool msg present -test_fsck :: Test -test_fsck = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntrusted, withremoteuntrusted] +test_fsck :: TestEnv -> Test +test_fsck env = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntrusted, withremoteuntrusted] where - basicfsck = TestCase $ intmpclonerepo $ do - git_annex "fsck" [] @? "fsck failed" + basicfsck = TestCase $ intmpclonerepo env $ do + git_annex env "fsck" [] @? "fsck failed" boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" fsck_should_fail "numcopies unsatisfied" boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" corrupt annexedfile corrupt sha1annexedfile - barefsck = TestCase $ intmpbareclonerepo $ do - git_annex "fsck" [] @? "fsck failed" - withlocaluntrusted = TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - git_annex "untrust" ["origin"] @? "untrust of origin repo failed" - git_annex "untrust" ["."] @? "untrust of current repo failed" + barefsck = TestCase $ intmpbareclonerepo env $ do + git_annex env "fsck" [] @? "fsck failed" + withlocaluntrusted = TestCase $ intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" + git_annex env "untrust" ["origin"] @? "untrust of origin repo failed" + git_annex env "untrust" ["."] @? "untrust of current repo failed" fsck_should_fail "content only available in untrusted (current) repository" - git_annex "trust" ["."] @? "trust of current repo failed" - git_annex "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" - withremoteuntrusted = TestCase $ intmpclonerepo $ do + git_annex env "trust" ["."] @? "trust of current repo failed" + git_annex env "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" + withremoteuntrusted = TestCase $ intmpclonerepo env $ do boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" - git_annex "get" [annexedfile] @? "get failed" - git_annex "get" [sha1annexedfile] @? "get failed" - git_annex "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" - git_annex "untrust" ["origin"] @? "untrust of origin failed" + git_annex env "get" [annexedfile] @? "get failed" + git_annex env "get" [sha1annexedfile] @? "get failed" + git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" + git_annex env "untrust" ["origin"] @? "untrust of origin failed" fsck_should_fail "content not replicated to enough non-untrusted repositories" corrupt f = do - git_annex "get" [f] @? "get of file failed" + git_annex env "get" [f] @? "get of file failed" Utility.FileMode.allowWrite f writeFile f (changedcontent f) - not <$> git_annex "fsck" [] @? "fsck failed to fail with corrupted file content" - git_annex "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f + not <$> git_annex env "fsck" [] @? "fsck failed to fail with corrupted file content" + git_annex env "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f fsck_should_fail m = do - not <$> git_annex "fsck" [] @? "fsck failed to fail with " ++ m + not <$> git_annex env "fsck" [] @? "fsck failed to fail with " ++ m -test_migrate :: Test -test_migrate = "git-annex migrate" ~: TestList [t False, t True] - where t usegitattributes = TestCase $ intmpclonerepo $ do +test_migrate :: TestEnv -> Test +test_migrate env = "git-annex migrate" ~: TestList [t False, t True] + where t usegitattributes = TestCase $ intmpclonerepo env $ do annexed_notpresent annexedfile annexed_notpresent sha1annexedfile - git_annex "migrate" [annexedfile] @? "migrate of not present failed" - git_annex "migrate" [sha1annexedfile] @? "migrate of not present failed" - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "get" [sha1annexedfile] @? "get of file failed" + git_annex env "migrate" [annexedfile] @? "migrate of not present failed" + git_annex env "migrate" [sha1annexedfile] @? "migrate of not present failed" + git_annex env "get" [annexedfile] @? "get of file failed" + git_annex env "get" [sha1annexedfile] @? "get of file failed" annexed_present annexedfile annexed_present sha1annexedfile if usegitattributes then do writeFile ".gitattributes" $ "* annex.backend=SHA1" - git_annex "migrate" [sha1annexedfile] + git_annex env "migrate" [sha1annexedfile] @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile] + git_annex env "migrate" [annexedfile] @? "migrate annexedfile failed" else do - git_annex "migrate" [sha1annexedfile, "--backend", "SHA1"] + git_annex env "migrate" [sha1annexedfile, "--backend", "SHA1"] @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile, "--backend", "SHA1"] + git_annex env "migrate" [annexedfile, "--backend", "SHA1"] @? "migrate annexedfile failed" annexed_present annexedfile annexed_present sha1annexedfile @@ -490,22 +493,22 @@ test_migrate = "git-annex migrate" ~: TestList [t False, t True] -- check that reversing a migration works writeFile ".gitattributes" $ "* annex.backend=SHA256" - git_annex "migrate" [sha1annexedfile] + git_annex env "migrate" [sha1annexedfile] @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile] + git_annex env "migrate" [annexedfile] @? "migrate annexedfile failed" annexed_present annexedfile annexed_present sha1annexedfile checkbackend annexedfile backendSHA256 checkbackend sha1annexedfile backendSHA256 -test_unused :: Test -test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do +test_unused :: TestEnv -> Test +test_unused env = "git-annex unused/dropunused" ~: intmpclonerepo env $ do -- keys have to be looked up before files are removed annexedfilekey <- annexeval $ findkey annexedfile sha1annexedfilekey <- annexeval $ findkey sha1annexedfile - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "get" [sha1annexedfile] @? "get of file failed" + git_annex env "get" [annexedfile] @? "get of file failed" + git_annex env "get" [sha1annexedfile] @? "get of file failed" checkunused [] "after get" boolSystem "git" [Params "rm -q", File annexedfile] @? "git rm failed" checkunused [] "after rm" @@ -519,17 +522,17 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also - git_annex "dropkey" ["--force", Types.Key.key2file annexedfilekey] + git_annex env "dropkey" ["--force", Types.Key.key2file annexedfilekey] @? "dropkey failed" checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Types.Key.key2file annexedfilekey) - git_annex "dropunused" ["1", "2"] @? "dropunused failed" + git_annex env "dropunused" ["1", "2"] @? "dropunused failed" checkunused [] "after dropunused" - git_annex "dropunused" ["10", "501"] @? "dropunused failed on bogus numbers" + git_annex env "dropunused" ["10", "501"] @? "dropunused failed on bogus numbers" where checkunused expectedkeys desc = do - git_annex "unused" [] @? "unused failed" + git_annex env "unused" [] @? "unused failed" unusedmap <- annexeval $ Logs.Unused.readUnusedLog "" let unusedkeys = M.elems unusedmap assertEqual ("unused keys differ " ++ desc) @@ -538,119 +541,119 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do r <- Backend.lookupFile f return $ fst $ fromJust r -test_describe :: Test -test_describe = "git-annex describe" ~: intmpclonerepo $ do - git_annex "describe" [".", "this repo"] @? "describe 1 failed" - git_annex "describe" ["origin", "origin repo"] @? "describe 2 failed" +test_describe :: TestEnv -> Test +test_describe env = "git-annex describe" ~: intmpclonerepo env $ do + git_annex env "describe" [".", "this repo"] @? "describe 1 failed" + git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" -test_find :: Test -test_find = "git-annex find" ~: intmpclonerepo $ do +test_find :: TestEnv -> Test +test_find env = "git-annex find" ~: intmpclonerepo env $ do annexed_notpresent annexedfile - git_annex_expectoutput "find" [] [] - git_annex "get" [annexedfile] @? "get failed" + git_annex_expectoutput env "find" [] [] + git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile annexed_notpresent sha1annexedfile - git_annex_expectoutput "find" [] [annexedfile] - git_annex_expectoutput "find" ["--exclude", annexedfile, "--and", "--exclude", sha1annexedfile] [] - git_annex_expectoutput "find" ["--include", annexedfile] [annexedfile] - git_annex_expectoutput "find" ["--not", "--in", "origin"] [] - git_annex_expectoutput "find" ["--copies", "1", "--and", "--not", "--copies", "2"] [sha1annexedfile] - git_annex_expectoutput "find" ["--inbackend", "SHA1"] [sha1annexedfile] - git_annex_expectoutput "find" ["--inbackend", "WORM"] [] + git_annex_expectoutput env "find" [] [annexedfile] + git_annex_expectoutput env "find" ["--exclude", annexedfile, "--and", "--exclude", sha1annexedfile] [] + git_annex_expectoutput env "find" ["--include", annexedfile] [annexedfile] + git_annex_expectoutput env "find" ["--not", "--in", "origin"] [] + git_annex_expectoutput env "find" ["--copies", "1", "--and", "--not", "--copies", "2"] [sha1annexedfile] + git_annex_expectoutput env "find" ["--inbackend", "SHA1"] [sha1annexedfile] + git_annex_expectoutput env "find" ["--inbackend", "WORM"] [] {- --include=* should match files in subdirectories too, - and --exclude=* should exclude them. -} createDirectory "dir" writeFile "dir/subfile" "subfile" - git_annex "add" ["dir"] @? "add of subdir failed" - git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] - git_annex_expectoutput "find" ["--exclude", "*"] [] + git_annex env "add" ["dir"] @? "add of subdir failed" + git_annex_expectoutput env "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] + git_annex_expectoutput env "find" ["--exclude", "*"] [] -test_merge :: Test -test_merge = "git-annex merge" ~: intmpclonerepo $ do - git_annex "merge" [] @? "merge failed" +test_merge :: TestEnv -> Test +test_merge env = "git-annex merge" ~: intmpclonerepo env $ do + git_annex env "merge" [] @? "merge failed" -test_status :: Test -test_status = "git-annex status" ~: intmpclonerepo $ do - json <- git_annex_output "status" ["--json"] +test_status :: TestEnv -> Test +test_status env = "git-annex status" ~: intmpclonerepo env $ do + json <- git_annex_output env "status" ["--json"] case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of Text.JSON.Ok _ -> return () Text.JSON.Error e -> assertFailure e -test_version :: Test -test_version = "git-annex version" ~: intmpclonerepo $ do - git_annex "version" [] @? "version failed" +test_version :: TestEnv -> Test +test_version env = "git-annex version" ~: intmpclonerepo env $ do + git_annex env "version" [] @? "version failed" -test_sync :: Test -test_sync = "git-annex sync" ~: intmpclonerepo $ do - git_annex "sync" [] @? "sync failed" +test_sync :: TestEnv -> Test +test_sync env = "git-annex sync" ~: intmpclonerepo env $ do + git_annex env "sync" [] @? "sync failed" {- Regression test for sync merge bug fixed in - 0214e0fb175a608a49b812d81b4632c081f63027 -} -test_sync_regression :: Test -test_sync_regression = "git-annex sync_regression" ~: +test_sync_regression :: TestEnv -> Test +test_sync_regression env = "git-annex sync_regression" ~: {- We need 3 repos to see this bug. -} - withtmpclonerepo False $ \r1 -> do - withtmpclonerepo False $ \r2 -> do - withtmpclonerepo False $ \r3 -> do - forM_ [r1, r2, r3] $ \r -> indir r $ do + withtmpclonerepo env False $ \r1 -> do + withtmpclonerepo env False $ \r2 -> do + withtmpclonerepo env False $ \r3 -> do + forM_ [r1, r2, r3] $ \r -> indir env r $ do when (r /= r1) $ boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" when (r /= r2) $ boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" when (r /= r3) $ boolSystem "git" [Params "remote add r3", File ("../../" ++ r3)] @? "remote add" - git_annex "get" [annexedfile] @? "get failed" + git_annex env "get" [annexedfile] @? "get failed" boolSystem "git" [Params "remote rm origin"] @? "remote rm" - forM_ [r3, r2, r1] $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" - forM_ [r3, r2] $ \r -> indir r $ - git_annex "drop" ["--force", annexedfile] @? "drop failed" - indir r1 $ do - git_annex "sync" [] @? "sync failed in r1" - git_annex_expectoutput "find" ["--in", "r3"] [] + forM_ [r3, r2, r1] $ \r -> indir env r $ + git_annex env "sync" [] @? "sync failed" + forM_ [r3, r2] $ \r -> indir env r $ + git_annex env "drop" ["--force", annexedfile] @? "drop failed" + indir env r1 $ do + git_annex env "sync" [] @? "sync failed in r1" + git_annex_expectoutput env "find" ["--in", "r3"] [] {- This was the bug. The sync - mangled location log data and it - thought the file was still in r2 -} - git_annex_expectoutput "find" ["--in", "r2"] [] + git_annex_expectoutput env "find" ["--in", "r2"] [] -test_map :: Test -test_map = "git-annex map" ~: intmpclonerepo $ do +test_map :: TestEnv -> Test +test_map env = "git-annex map" ~: intmpclonerepo env $ do -- set descriptions, that will be looked for in the map - git_annex "describe" [".", "this repo"] @? "describe 1 failed" - git_annex "describe" ["origin", "origin repo"] @? "describe 2 failed" + git_annex env "describe" [".", "this repo"] @? "describe 1 failed" + git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" -- --fast avoids it running graphviz, not a build dependency - git_annex "map" ["--fast"] @? "map failed" + git_annex env "map" ["--fast"] @? "map failed" -test_uninit :: Test -test_uninit = "git-annex uninit" ~: intmpclonerepo $ do - git_annex "get" [] @? "get failed" +test_uninit :: TestEnv -> Test +test_uninit env = "git-annex uninit" ~: intmpclonerepo env $ do + git_annex env "get" [] @? "get failed" annexed_present annexedfile boolSystem "git" [Params "checkout git-annex"] @? "git checkout git-annex" - not <$> git_annex "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" + not <$> git_annex env "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" boolSystem "git" [Params "checkout master"] @? "git checkout master" - _ <- git_annex "uninit" [] -- exit status not checked; does abnormal exit + _ <- git_annex env "uninit" [] -- exit status not checked; does abnormal exit checkregularfile annexedfile doesDirectoryExist ".git" @? ".git vanished in uninit" not <$> doesDirectoryExist ".git/annex" @? ".git/annex still present after uninit" -test_upgrade :: Test -test_upgrade = "git-annex upgrade" ~: intmpclonerepo $ do - git_annex "upgrade" [] @? "upgrade from same version failed" +test_upgrade :: TestEnv -> Test +test_upgrade env = "git-annex upgrade" ~: intmpclonerepo env $ do + git_annex env "upgrade" [] @? "upgrade from same version failed" -test_whereis :: Test -test_whereis = "git-annex whereis" ~: intmpclonerepo $ do +test_whereis :: TestEnv -> Test +test_whereis env = "git-annex whereis" ~: intmpclonerepo env $ do annexed_notpresent annexedfile - git_annex "whereis" [annexedfile] @? "whereis on non-present file failed" - git_annex "untrust" ["origin"] @? "untrust failed" - not <$> git_annex "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" - git_annex "get" [annexedfile] @? "get failed" + git_annex env "whereis" [annexedfile] @? "whereis on non-present file failed" + git_annex env "untrust" ["origin"] @? "untrust failed" + not <$> git_annex env "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" + git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex "whereis" [annexedfile] @? "whereis on present file failed" + git_annex env "whereis" [annexedfile] @? "whereis on present file failed" -test_hook_remote :: Test -test_hook_remote = "git-annex hook remote" ~: intmpclonerepo $ do - git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" +test_hook_remote :: TestEnv -> Test +test_hook_remote env = "git-annex hook remote" ~: intmpclonerepo env $ do + git_annex env "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" createDirectory dir git_config "annex.foo-store-hook" $ "cp $ANNEX_FILE " ++ loc @@ -660,15 +663,15 @@ test_hook_remote = "git-annex hook remote" ~: intmpclonerepo $ do "rm -f " ++ loc git_config "annex.foo-checkpresent-hook" $ "if [ -e " ++ loc ++ " ]; then echo $ANNEX_KEY; fi" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to hook remote failed" + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to hook remote failed" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" + git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" annexed_present annexedfile - not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile where dir = "dir" @@ -676,61 +679,59 @@ test_hook_remote = "git-annex hook remote" ~: intmpclonerepo $ do git_config k v = boolSystem "git" [Param "config", Param k, Param v] @? "git config failed" -test_directory_remote :: Test -test_directory_remote = "git-annex directory remote" ~: intmpclonerepo $ do +test_directory_remote :: TestEnv -> Test +test_directory_remote env = "git-annex directory remote" ~: intmpclonerepo env $ do createDirectory "dir" - git_annex "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed" + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" + git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" annexed_present annexedfile - not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile -test_rsync_remote :: Test -test_rsync_remote = "git-annex rsync remote" ~: intmpclonerepo $ do +test_rsync_remote :: TestEnv -> Test +test_rsync_remote env = "git-annex rsync remote" ~: intmpclonerepo env $ do createDirectory "dir" - git_annex "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed" + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" + git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" annexed_present annexedfile - not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile -test_bup_remote :: Test -test_bup_remote = "git-annex bup remote" ~: intmpclonerepo $ when Build.SysConfig.bup $ do +test_bup_remote :: TestEnv -> Test +test_bup_remote env = "git-annex bup remote" ~: intmpclonerepo env $ when Build.SysConfig.bup $ do dir <- absPath "dir" -- bup special remote needs an absolute path createDirectory dir - git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to bup remote failed" + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to bup remote failed" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex "copy" [annexedfile, "--from", "foo"] @? "copy --from bup remote failed" + git_annex env "copy" [annexedfile, "--from", "foo"] @? "copy --from bup remote failed" annexed_present annexedfile - not <$> git_annex "move" [annexedfile, "--from", "foo"] @? "move --from bup remote failed to fail" + not <$> git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from bup remote failed to fail" annexed_present annexedfile -- gpg is not a build dependency, so only test when it's available -test_crypto :: Test -test_crypto = "git-annex crypto" ~: intmpclonerepo $ when Build.SysConfig.gpg $ do - -- force gpg into batch mode for the tests - setEnv "GPG_BATCH" "1" True +test_crypto :: TestEnv -> Test +test_crypto env = "git-annex crypto" ~: intmpclonerepo env $ when Build.SysConfig.gpg $ do Utility.Gpg.testTestHarness @? "test harness self-test failed" Utility.Gpg.testHarness $ do createDirectory "dir" - let a cmd = git_annex cmd + let a cmd = git_annex env cmd [ "foo" , "type=directory" , "encryption=" ++ Utility.Gpg.testKeyId @@ -741,21 +742,24 @@ test_crypto = "git-annex crypto" ~: intmpclonerepo $ when Build.SysConfig.gpg $ not <$> a "initremote" @? "initremote failed to fail when run twice in a row" a "enableremote" @? "enableremote failed" a "enableremote" @? "enableremote failed when run twice in a row" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" + git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" annexed_present annexedfile - not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile -- This is equivilant to running git-annex, but it's all run in-process -- so test coverage collection works. -git_annex :: String -> [String] -> IO Bool -git_annex command params = do +git_annex :: TestEnv -> String -> [String] -> IO Bool +git_annex env command params = do + forM_ (M.toList env) $ \(var, val) -> + Utility.Env.setEnv var val True + -- catch all errors, including normally fatal errors r <- try (run)::IO (Either SomeException ()) case r of @@ -765,18 +769,19 @@ git_annex command params = do run = GitAnnex.run (command:"-q":params) {- Runs git-annex and returns its output. -} -git_annex_output :: String -> [String] -> IO String -git_annex_output command params = do - got <- Utility.Process.readProcess "git-annex" (command:params) +git_annex_output :: TestEnv -> String -> [String] -> IO String +git_annex_output env command params = do + got <- Utility.Process.readProcessEnv "git-annex" (command:params) $ + Just $ M.toList env -- XXX since the above is a separate process, code coverage stats are -- not gathered for things run in it. -- Run same command again, to get code coverage. - _ <- git_annex command params + _ <- git_annex env command params return got -git_annex_expectoutput :: String -> [String] -> [String] -> IO () -git_annex_expectoutput command params expected = do - got <- lines <$> git_annex_output command params +git_annex_expectoutput :: TestEnv -> String -> [String] -> [String] -> IO () +git_annex_expectoutput env command params expected = do + got <- lines <$> git_annex_output env command params got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected) -- Runs an action in the current annex. Note that shutdown actions @@ -788,56 +793,57 @@ annexeval a = do Annex.setOutput Types.Messages.QuietOutput a -innewrepo :: Assertion -> Assertion -innewrepo a = withgitrepo $ \r -> indir r a +innewrepo :: TestEnv -> Assertion -> Assertion +innewrepo env a = withgitrepo env $ \r -> indir env r a -inmainrepo :: Assertion -> Assertion -inmainrepo a = indir mainrepodir a +inmainrepo :: TestEnv -> Assertion -> Assertion +inmainrepo env a = indir env mainrepodir a -intmpclonerepo :: Assertion -> Assertion -intmpclonerepo a = withtmpclonerepo False $ \r -> indir r a +intmpclonerepo :: TestEnv -> Assertion -> Assertion +intmpclonerepo env a = withtmpclonerepo env False $ \r -> indir env r a -intmpbareclonerepo :: Assertion -> Assertion -intmpbareclonerepo a = withtmpclonerepo True $ \r -> indir r a +intmpbareclonerepo :: TestEnv -> Assertion -> Assertion +intmpbareclonerepo env a = withtmpclonerepo env True $ \r -> indir env r a -withtmpclonerepo :: Bool -> (FilePath -> Assertion) -> Assertion -withtmpclonerepo bare a = do +withtmpclonerepo :: TestEnv -> Bool -> (FilePath -> Assertion) -> Assertion +withtmpclonerepo env bare a = do dir <- tmprepodir - bracket (clonerepo mainrepodir dir bare) cleanup a + bracket (clonerepo env mainrepodir dir bare) cleanup a -withgitrepo :: (FilePath -> Assertion) -> Assertion -withgitrepo = bracket (setuprepo mainrepodir) return +withgitrepo :: TestEnv -> (FilePath -> Assertion) -> Assertion +withgitrepo env = bracket (setuprepo env mainrepodir) return -indir :: FilePath -> Assertion -> Assertion -indir dir a = do +indir :: TestEnv -> FilePath -> Assertion -> Assertion +indir env dir a = do cwd <- getCurrentDirectory -- Assertion failures throw non-IO errors; catch -- any type of error and change back to cwd before -- rethrowing. - r <- bracket_ (changeToTmpDir dir) (changeWorkingDirectory cwd) + r <- bracket_ (changeToTmpDir env dir) (setCurrentDirectory cwd) (try (a)::IO (Either SomeException ())) case r of Right () -> return () Left e -> throw e -setuprepo :: FilePath -> IO FilePath -setuprepo dir = do +setuprepo :: TestEnv -> FilePath -> IO FilePath +setuprepo env dir = do cleanup dir ensuretmpdir boolSystem "git" [Params "init -q", File dir] @? "git init failed" - indir dir $ do + indir env dir $ do boolSystem "git" [Params "config user.name", Param "Test User"] @? "git config failed" boolSystem "git" [Params "config user.email test@example.com"] @? "git config failed" return dir -- clones are always done as local clones; we cannot test ssh clones -clonerepo :: FilePath -> FilePath -> Bool -> IO FilePath -clonerepo old new bare = do +clonerepo :: TestEnv -> FilePath -> FilePath -> Bool -> IO FilePath +clonerepo env old new bare = do cleanup new ensuretmpdir let b = if bare then " --bare" else "" boolSystem "git" [Params ("clone -q" ++ b), File old, File new] @? "git clone failed" - indir new $ git_annex "init" ["-q", new] @? "git annex init failed" + indir env new $ + git_annex env "init" ["-q", new] @? "git annex init failed" return new ensuretmpdir :: IO () @@ -860,7 +866,12 @@ cleanup dir = do checklink :: FilePath -> Assertion checklink f = do s <- getSymbolicLinkStatus f - isSymbolicLink s @? f ++ " is not a symlink" + ifM (annexeval Config.isDirect) + -- in direct mode, it may be a symlink, or not, depending + -- on whether the content is present. + ( return () + , isSymbolicLink s @? f ++ " is not a symlink" + ) checkregularfile :: FilePath -> Assertion checkregularfile f = do @@ -874,15 +885,18 @@ checkcontent f = do assertEqual ("checkcontent " ++ f) c (content f) checkunwritable :: FilePath -> Assertion -checkunwritable f = do - -- Look at permissions bits rather than trying to write or using - -- fileAccess because if run as root, any file can be modified - -- despite permissions. - s <- getFileStatus f - let mode = fileMode s - if (mode == mode `unionFileModes` ownerWriteMode) - then assertFailure $ "able to modify annexed file's " ++ f ++ " content" - else return () +checkunwritable f = ifM (annexeval Config.isDirect) + ( return () + , do + -- Look at permissions bits rather than trying to write or + -- using fileAccess because if run as root, any file can be + -- modified despite permissions. + s <- getFileStatus f + let mode = fileMode s + if (mode == mode `unionFileModes` ownerWriteMode) + then assertFailure $ "able to modify annexed file's " ++ f ++ " content" + else return () + ) checkwritable :: FilePath -> Assertion checkwritable f = do @@ -938,30 +952,35 @@ annexed_present = runchecks unannexed :: FilePath -> Assertion unannexed = runchecks [checkregularfile, checkcontent, checkwritable] -prepare :: IO () +prepare :: IO TestEnv prepare = do whenM (doesDirectoryExist tmpdir) $ error $ "The temporary directory " ++ tmpdir ++ " already exists; cannot run test suite." - -- While PATH is mostly avoided, the commit hook does run it, - -- and so does git_annex_output. Make sure that the just-built - -- git annex is used. cwd <- getCurrentDirectory - p <- getEnvDefault "PATH" "" - setEnv "PATH" (cwd ++ ":" ++ p) True - setEnv "TOPDIR" cwd True - -- Avoid git complaining if it cannot determine the user's email - -- address, or exploding if it doesn't know the user's name. - setEnv "GIT_AUTHOR_EMAIL" "test@example.com" True - setEnv "GIT_AUTHOR_NAME" "git-annex test" True - setEnv "GIT_COMMITTER_EMAIL" "test@example.com" True - setEnv "GIT_COMMITTER_NAME" "git-annex test" True - -changeToTmpDir :: FilePath -> IO () -changeToTmpDir t = do - -- Hack alert. Threading state to here was too much bother. - topdir <- getEnvDefault "TOPDIR" "" - changeWorkingDirectory $ topdir ++ "/" ++ t + p <- Utility.Env.getEnvDefault "PATH" "" + + let env = + -- Ensure that the just-built git annex is used. + [ ("PATH", cwd ++ ":" ++ p) + , ("TOPDIR", cwd) + -- Avoid git complaining if it cannot determine the user's + -- email address, or exploding if it doesn't know the user's + -- name. + , ("GIT_AUTHOR_EMAIL", "test@example.com") + , ("GIT_AUTHOR_NAME", "git-annex test") + , ("GIT_COMMITTER_EMAIL", "test@example.com") + , ("GIT_COMMITTER_NAME", "git-annex test") + -- force gpg into batch mode for the tests + , ("GPG_BATCH", "1") + ] + + return $ M.fromList env + +changeToTmpDir :: TestEnv -> FilePath -> IO () +changeToTmpDir env t = do + let topdir = fromMaybe "" $ M.lookup "TOPDIR" env + setCurrentDirectory $ topdir ++ "/" ++ t tmpdir :: String tmpdir = ".t" diff --git a/Upgrade.hs b/Upgrade.hs index 705b190d8..30f2b7ed8 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -5,18 +5,27 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Upgrade where import Common.Annex import Annex.Version +#ifndef __WINDOWS__ import qualified Upgrade.V0 import qualified Upgrade.V1 +#endif import qualified Upgrade.V2 upgrade :: Annex Bool upgrade = go =<< getVersion where +#ifndef __WINDOWS__ go (Just "0") = Upgrade.V0.upgrade go (Just "1") = Upgrade.V1.upgrade +#else + go (Just "0") = error "upgrade from v0 on Windows not supported" + go (Just "1") = error "upgrade from v1 on Windows not supported" +#endif go (Just "2") = Upgrade.V2.upgrade go _ = return True diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index e048b3db8..9793f04e8 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -20,7 +20,7 @@ import qualified Git.LsFiles as LsFiles import Backend import Annex.Version import Utility.FileMode -import Utility.TempFile +import Utility.Tmp import qualified Upgrade.V2 -- v2 adds hashing of filenames of content and location log files. diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 935fc4825..b5de6c8c0 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -14,7 +14,7 @@ import qualified Git.Ref import qualified Annex.Branch import Logs.Location import Annex.Content -import Utility.TempFile +import Utility.Tmp olddir :: Git.Repo -> FilePath olddir g diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 7a2a5fe8e..f72850fc5 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -6,11 +6,14 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.CoProcess ( CoProcessHandle, start, stop, - query + query, + rawMode ) where import Common @@ -33,3 +36,15 @@ query (_, from, to, _) send receive = do _ <- send to hFlush to receive from + +rawMode :: CoProcessHandle -> IO CoProcessHandle +rawMode ch@(_, from, to, _) = do + raw from + raw to + return ch + where + raw h = do + fileEncoding h +#ifdef __WINDOWS__ + hSetNewlineMode h noNewlineTranslation +#endif diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index ff13a3b8a..e1cd25088 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -5,12 +5,19 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.Daemon where import Common import Utility.LogFile +#ifndef __WINDOWS__ import System.Posix +#else +import System.PosixCompat +import System.Posix.Types +#endif {- Run an action as a daemon, with all output sent to a file descriptor. - @@ -19,6 +26,7 @@ import System.Posix - - When successful, does not return. -} daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO () +#ifndef __WINDOWS__ daemonize logfd pidfile changedirectory a = do maybe noop checkalreadyrunning pidfile _ <- forkProcess child1 @@ -40,6 +48,9 @@ daemonize logfd pidfile changedirectory a = do a out out = exitImmediately ExitSuccess +#else +daemonize = error "daemonize is not implemented on Windows" -- TODO +#endif {- Locks the pid file, with an exclusive, non-blocking lock. - Writes the pid to the file, fully atomically. @@ -47,6 +58,7 @@ daemonize logfd pidfile changedirectory a = do lockPidFile :: FilePath -> IO () lockPidFile file = do createDirectoryIfMissing True (parentDir file) +#ifndef __WINDOWS__ fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags @@ -57,8 +69,11 @@ lockPidFile file = do (_, Nothing) -> alreadyRunning _ -> do _ <- fdWrite fd' =<< show <$> getProcessID - renameFile newfile file closeFd fd +#else + writeFile newfile "-1" +#endif + renameFile newfile file where newfile = file ++ ".new" @@ -70,6 +85,7 @@ alreadyRunning = error "Daemon is already running." - - If it's running, returns its pid. -} checkDaemon :: FilePath -> IO (Maybe ProcessID) +#ifndef __WINDOWS__ checkDaemon pidfile = do v <- catchMaybeIO $ openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags @@ -88,10 +104,17 @@ checkDaemon pidfile = do "stale pid in " ++ pidfile ++ " (got " ++ show pid' ++ "; expected " ++ show pid ++ " )" +#else +checkDaemon pidfile = maybe Nothing readish <$> catchMaybeIO (readFile pidfile) +#endif {- Stops the daemon, safely. -} stopDaemon :: FilePath -> IO () +#ifndef __WINDOWS__ stopDaemon pidfile = go =<< checkDaemon pidfile where go Nothing = noop go (Just pid) = signalProcess sigTERM pid +#else +stopDaemon = error "stopDaemon is not implemented on Windows" -- TODO +#endif diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 7cce4a68f..9477ad5b9 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -8,7 +8,7 @@ module Utility.Directory where import System.IO.Error -import System.Posix.Files +import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad @@ -18,7 +18,7 @@ import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Utility.SafeCommand -import Utility.TempFile +import Utility.Tmp import Utility.Exception import Utility.Monad diff --git a/Utility/Env.hs b/Utility/Env.hs new file mode 100644 index 000000000..cb738732f --- /dev/null +++ b/Utility/Env.hs @@ -0,0 +1,63 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.Env where + +#ifdef mingw32_HOST_OS +import Utility.Exception +import Control.Applicative +import Data.Maybe +import qualified System.Environment as E +#else +import qualified System.Posix.Env as PE +#endif + +getEnv :: String -> IO (Maybe String) +#ifndef mingw32_HOST_OS +getEnv = PE.getEnv +#else +getEnv = catchMaybeIO . E.getEnv +#endif + +getEnvDefault :: String -> String -> IO String +#ifndef mingw32_HOST_OS +getEnvDefault = PE.getEnvDefault +#else +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var +#endif + +getEnvironment :: IO [(String, String)] +#ifndef mingw32_HOST_OS +getEnvironment = PE.getEnvironment +#else +getEnvironment = E.getEnvironment +#endif + +{- Returns True if it could successfully set the environment variable. + - + - There is, apparently, no way to do this in Windows. Instead, + - environment varuables must be provided when running a new process. -} +setEnv :: String -> String -> Bool -> IO Bool +#ifndef mingw32_HOST_OS +setEnv var val overwrite = do + PE.setEnv var val overwrite + return True +#else +setEnv _ _ _ = return False +#endif + +{- Returns True if it could successfully unset the environment variable. -} +unsetEnv :: String -> IO Bool +#ifndef mingw32_HOST_OS +unsetEnv var = do + PE.unsetEnv var + return True +#else +unsetEnv _ = return False +#endif diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 2ca4a4600..47247e2a1 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -5,12 +5,17 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.FileMode where import Common import Control.Exception (bracket) -import System.Posix.Types +import System.PosixCompat.Types +#ifndef __WINDOWS__ +import System.Posix.Files +#endif import Foreign (complement) {- Applies a conversion function to a file's mode. -} @@ -71,7 +76,11 @@ checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor {- Checks if a file mode indicates it's a symlink. -} isSymLink :: FileMode -> Bool +#ifdef __WINDOWS__ +isSymLink _ = False +#else isSymLink = checkMode symbolicLinkMode +#endif {- Checks if a file has any executable bits set. -} isExecutable :: FileMode -> Bool @@ -80,6 +89,7 @@ isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 {- Runs an action without that pesky umask influencing it, unless the - passed FileMode is the standard one. -} noUmask :: FileMode -> IO a -> IO a +#ifndef __WINDOWS__ noUmask mode a | mode == stdFileMode = a | otherwise = bracket setup cleanup go @@ -87,20 +97,27 @@ noUmask mode a setup = setFileCreationMask nullFileMode cleanup = setFileCreationMask go _ = a +#else +noUmask _ a = a +#endif combineModes :: [FileMode] -> FileMode combineModes [] = undefined combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms -stickyMode :: FileMode -stickyMode = 512 - isSticky :: FileMode -> Bool +#ifdef __WINDOWS__ +isSticky _ = False +#else isSticky = checkMode stickyMode +stickyMode :: FileMode +stickyMode = 512 + setSticky :: FilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] +#endif {- Writes a file, ensuring that its modes do not allow it to be read - by anyone other than the current user, before any content is written. diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 4a13d456c..aa4a7af73 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -5,21 +5,25 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.Gpg where import System.Posix.Types import Control.Applicative import Control.Concurrent import Control.Exception (bracket) -import System.Posix.Env (setEnv, unsetEnv, getEnv) +import System.Path import Common +import Utility.Env newtype KeyIds = KeyIds [String] deriving (Ord, Eq) stdParams :: [CommandParam] -> IO [String] stdParams params = do +#ifndef __WINDOWS__ -- Enable batch mode if GPG_AGENT_INFO is set, to avoid extraneous -- gpg output about password prompts. GPG_BATCH is set by the test -- suite for a similar reason. @@ -29,6 +33,9 @@ stdParams params = do then [] else ["--batch", "--no-tty", "--use-agent"] return $ batch ++ defaults ++ toCommand params +#else + return $ defaults ++ toCommand params +#endif where -- be quiet, even about checking the trustdb defaults = ["--quiet", "--trust-model", "always"] @@ -64,6 +71,7 @@ pipeStrict params input = do - Note that to avoid deadlock with the cleanup stage, - the reader must fully consume gpg's input before returning. -} feedRead :: [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a +#ifndef __WINDOWS__ feedRead params passphrase feeder reader = do -- pipe the passphrase into gpg on a fd (frompipe, topipe) <- createPipe @@ -83,6 +91,9 @@ feedRead params passphrase feeder reader = do feeder to hClose to reader from +#else +feedRead = error "gpg feedRead not implemented on Windows" -- TODO +#endif {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of @@ -204,6 +215,7 @@ keyBlock public ls = unlines | public = "PUBLIC" | otherwise = "PRIVATE" +#ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does - not use ~/.gpg/, but a directory with the test key set up to be used. -} testHarness :: IO a -> IO a @@ -216,7 +228,7 @@ testHarness a = do setup = do base <- getTemporaryDirectory dir <- mktmpdir $ base </> "gpgtmpXXXXXX" - setEnv var dir True + void $ setEnv var dir True _ <- pipeStrict [Params "--import -q"] $ unlines [testSecretKey, testKey] return dir @@ -230,3 +242,4 @@ testTestHarness :: IO Bool testTestHarness = do keys <- testHarness $ findPubKeys testKeyId return $ KeyIds [testKeyId] == keys +#endif diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index e08abc6ad..8037c61c8 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -8,7 +8,7 @@ module Utility.InodeCache where import Common -import System.Posix.Types +import System.PosixCompat.Types import Utility.QuickCheck data InodeCachePrim = InodeCachePrim FileID FileOffset EpochTime diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index 1ff3006fe..339d6e8b9 100644 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -5,17 +5,23 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.LogFile where import Common -import System.Posix +import System.Posix.Types openLog :: FilePath -> IO Fd +#ifndef __WINDOWS__ openLog logfile = do rotateLog logfile openFd logfile WriteOnly (Just stdFileMode) defaultFileFlags { append = True } +#else +openLog = error "openLog TODO" +#endif rotateLog :: FilePath -> IO () rotateLog logfile = go 0 @@ -44,11 +50,19 @@ maxLogs :: Int maxLogs = 9 redirLog :: Fd -> IO () +#ifndef __WINDOWS__ redirLog logfd = do mapM_ (redir logfd) [stdOutput, stdError] closeFd logfd +#else +redirLog _ = error "redirLog TODO" +#endif +#ifndef __WINDOWS__ redir :: Fd -> Fd -> IO () redir newh h = do closeFd h void $ dupTo newh h +#else +redir _ _ = error "redir TODO" +#endif diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 31da6781e..6d6b353f2 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -11,9 +11,9 @@ module Utility.Lsof where import Common import Build.SysConfig as SysConfig +import Utility.Env import System.Posix.Types -import System.Posix.Env data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown deriving (Show, Eq) @@ -32,7 +32,7 @@ setupLsof = do when (isAbsolute cmd) $ do path <- getSearchPath let path' = takeDirectory cmd : path - setEnv "PATH" (intercalate [searchPathSeparator] path') True + void $ setEnv "PATH" (intercalate [searchPathSeparator] path') True {- Checks each of the files in a directory to find open files. - Note that this will find hard links to files elsewhere that are open. -} diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 1bb6de79f..39d0e3de0 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.Misc where import System.IO @@ -13,7 +15,9 @@ import Foreign import Data.Char import Data.List import Control.Applicative +#ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) +#endif import Utility.Exception @@ -124,7 +128,12 @@ hGetSomeString h sz = do - 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 = do -- 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/Utility/Path.hs b/Utility/Path.hs index 4ffcf1c65..4df0703ab 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,33 +1,60 @@ {- path manipulation - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, CPP #-} module Utility.Path where import Data.String.Utils -import "MissingH" System.Path import System.FilePath import System.Directory import Data.List import Data.Maybe import Control.Applicative +#ifdef __WINDOWS__ +import Data.Char +import qualified System.FilePath.Posix as Posix +#else +import qualified "MissingH" System.Path as MissingH +#endif + import Utility.Monad import Utility.UserInfo -{- Returns the parent directory of a path. Parent of / is "" -} +{- Makes a path absolute if it's not already. + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute. + - + - On Unix, collapses and normalizes ".." etc in the path. May return Nothing + - if the path cannot be normalized. + - + - MissingH's absNormPath does not work on Windows, so on Windows + - no normalization is done. + -} +absNormPath :: FilePath -> FilePath -> Maybe FilePath +#ifndef __WINDOWS__ +absNormPath dir path = MissingH.absNormPath dir path +#else +absNormPath dir path = Just $ combine dir path +#endif + +{- Returns the parent directory of a path. + - + - To allow this to be easily used in loops, which terminate upon reaching the + - top, the parent of / is "" -} parentDir :: FilePath -> FilePath parentDir dir - | not $ null dirs = slash ++ join s (init dirs) - | otherwise = "" + | null dirs = "" + | otherwise = joinDrive drive (join s $ init dirs) where - dirs = filter (not . null) $ split s dir - slash = if isAbsolute dir then s else "" + -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + (drive, path) = splitDrive dir + dirs = filter (not . null) $ split s path s = [pathSeparator] prop_parentDir_basics :: FilePath -> Bool @@ -43,7 +70,7 @@ prop_parentDir_basics dir - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' +dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b' where norm p = fromMaybe "" $ absNormPath p "." a' = norm a @@ -108,7 +135,7 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference {- Given an original list of paths, and an expanded list derived from it, - generates a list of lists, where each sublist corresponds to one of the - - original paths. When the original path is a direcotry, any items + - original paths. When the original path is a directory, any items - in the expanded list that are contained in that directory will appear in - its segment. -} @@ -164,3 +191,22 @@ dotfile file | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file + +{- Converts a DOS style path to a Cygwin style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' -} +toCygPath :: FilePath -> FilePath +#ifndef __WINDOWS__ +toCygPath = id +#else +toCygPath p + | null drive = recombine parts + | otherwise = recombine $ "/cygdrive" : 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/Process.hs b/Utility/Process.hs index b2bac99a1..6e0aef21c 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -6,7 +6,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X, @@ -42,7 +42,9 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad import Data.Maybe +#ifndef mingw32_HOST_OS import System.Posix.IO +#endif import Utility.Misc @@ -156,6 +158,7 @@ createBackgroundProcess p a = a =<< createProcess p - returns a transcript combining its stdout and stderr, and - whether it succeeded or failed. -} processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +#ifndef mingw32_HOST_OS processTranscript cmd opts input = do (readf, writef) <- createPipe readh <- fdToHandle readf @@ -189,7 +192,9 @@ processTranscript cmd opts input = do ok <- checkSuccessProcess pid return (transcript, ok) - +#else +processTranscript = error "processTranscript TODO" +#endif {- Runs a CreateProcessRunner, on a CreateProcess structure, that - is adjusted to pipe only from/to a single StdHandle, and passes diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 652da8b20..5f322a0cb 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -1,6 +1,6 @@ {- various rsync stuff - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -49,7 +49,16 @@ rsyncUseDestinationPermissions :: CommandParam rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX" rsync :: [CommandParam] -> IO Bool -rsync = boolSystem "rsync" +rsync = boolSystem "rsync" . rsyncParamsFixup + +{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted + - paths to files. (It thinks that C:foo refers to a host named "C"). + - Fix up all Files in the Params appropriately. -} +rsyncParamsFixup :: [CommandParam] -> [CommandParam] +rsyncParamsFixup = map fixup + where + fixup (File f) = File (toCygPath f) + fixup p = p {- Runs rsync, but intercepts its progress output and updates a meter. - The progress output is also output to stdout. @@ -65,7 +74,7 @@ rsyncProgress meterupdate params = do reapZombies return r where - p = proc "rsync" (toCommand params) + p = proc "rsync" (toCommand $ rsyncParamsFixup params) feedprogress prev buf h = do s <- hGetSomeString h 80 if null s diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs deleted file mode 100644 index 6dbea693a..000000000 --- a/Utility/TempFile.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- temp file functions - - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility.TempFile where - -import Control.Exception (bracket) -import System.IO -import System.Posix.Process -import System.Directory - -import Utility.Exception -import Utility.Path -import System.FilePath - -{- Runs an action like writeFile, writing to a temp file first and - - then moving it into place. The temp file is stored in the same - - directory as the final file to avoid cross-device renames. -} -viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () -viaTmp a file content = do - pid <- getProcessID - let tmpfile = file ++ ".tmp" ++ show pid - createDirectoryIfMissing True (parentDir file) - a tmpfile content - renameFile tmpfile file - -type Template = String - -{- Runs an action with a temp file, then removes the file. -} -withTempFile :: Template -> (FilePath -> Handle -> IO a) -> IO a -withTempFile template a = bracket create remove use - where - create = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory - openTempFile tmpdir template - remove (name, handle) = do - hClose handle - catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle - -{- Runs an action with a temp directory, then removes the directory and - - all its contents. -} -withTempDir :: Template -> (FilePath -> IO a) -> IO a -withTempDir template = bracket create remove - where - remove = removeDirectoryRecursive - create = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory - createDirectoryIfMissing True tmpdir - pid <- getProcessID - makedir tmpdir (template ++ show pid) (0 :: Int) - makedir tmpdir t n = do - let dir = tmpdir </> t ++ "." ++ show n - r <- tryIO $ createDirectory dir - either (const $ makedir tmpdir t $ n + 1) (const $ return dir) r diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs new file mode 100644 index 000000000..f03e4c0dc --- /dev/null +++ b/Utility/Tmp.hs @@ -0,0 +1,71 @@ +{- Temporary files and directories. + - + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Tmp where + +import Control.Exception (bracket) +import System.IO +import System.Directory +import Control.Monad.IfElse + +import Utility.Exception +import System.FilePath + +type Template = String + +{- Runs an action like writeFile, writing to a temp file first and + - then moving it into place. The temp file is stored in the same + - directory as the final file to avoid cross-device renames. -} +viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () +viaTmp a file content = do + let (dir, base) = splitFileName file + createDirectoryIfMissing True dir + (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") + hClose handle + a tmpfile content + renameFile tmpfile file + +{- Runs an action with a tmp file located in the system's tmp directory + - (or in "." if there is none) then removes the file. -} +withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile template a = do + tmpdir <- catchDefaultIO "." getTemporaryDirectory + withTmpFileIn tmpdir template a + +{- Runs an action with a tmp file located in the specified directory, + - then removes the file. -} +withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn tmpdir template a = bracket create remove use + where + create = openTempFile tmpdir template + remove (name, handle) = do + hClose handle + catchBoolIO (removeFile name >> return True) + use (name, handle) = a name handle + +{- 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 :: Template -> (FilePath -> IO a) -> IO a +withTmpDir template a = do + tmpdir <- catchDefaultIO "." getTemporaryDirectory + withTmpDirIn tmpdir template a + +{- Runs an action with a tmp directory located within a specified directory, + - then removes the tmp directory and all its contents. -} +withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a +withTmpDirIn tmpdir template = bracket create remove + where + remove d = whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + create = do + createDirectoryIfMissing True tmpdir + makenewdir (tmpdir </> template) (0 :: Int) + makenewdir t n = do + let dir = t ++ "." ++ show n + either (const $ makenewdir t $ n + 1) (const $ return dir) + =<< tryIO (createDirectory dir) diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 916ebb191..3a71c6baf 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,18 +14,31 @@ module Utility.UserInfo ( ) where import Control.Applicative -import System.Posix.User -import System.Posix.Env +import System.PosixCompat + +import Utility.Env {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = myVal ["HOME"] homeDirectory +myHomeDir = myVal env homeDirectory + where +#ifndef __WINDOWS__ + env = ["HOME"] +#else + env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin +#endif {- Current user's user name. -} myUserName :: IO String -myUserName = myVal ["USER", "LOGNAME"] userName +myUserName = myVal env userName + where +#ifndef __WINDOWS__ + env = ["USER", "LOGNAME"] +#else + env = ["USERNAME", "USER", "LOGNAME"] +#endif myUserGecos :: IO String #ifdef __ANDROID__ diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 0614384a1..762819b2f 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -10,7 +10,7 @@ module Utility.WebApp where import Common -import Utility.TempFile +import Utility.Tmp import Utility.FileMode import qualified Yesod diff --git a/debian/control b/debian/control index a0053d720..f9d27243a 100644 --- a/debian/control +++ b/debian/control @@ -17,6 +17,7 @@ Build-Depends: libghc-quickcheck2-dev, libghc-monad-control-dev (>= 0.3), libghc-lifted-base-dev, + libghc-unix-compat-dev, libghc-dlist-dev, libghc-uuid-dev, libghc-json-dev, diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 5aa4fc6b3..15539d1f4 100644 --- a/doc/install/fromscratch.mdwn +++ b/doc/install/fromscratch.mdwn @@ -48,6 +48,7 @@ quite a lot. * [xml-types](http://hackage.haskell.org/package/xml-types) * [async](http://hackage.haskell.org/package/async) * [HTTP](http://hackage.haskell.org/package/HTTP) + * [unix-compat](http://hackage.haskell.org/package/unix-compat) * Shell commands * [git](http://git-scm.com/) * [xargs](http://savannah.gnu.org/projects/findutils/) diff --git a/git-annex.cabal b/git-annex.cabal index 7678b7feb..7c62e0efc 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -68,12 +68,12 @@ Flag TDFA Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, - unix, containers, utf8-string, network (>= 2.0), mtl (>= 2), + containers, utf8-string, network (>= 2.0), mtl (>= 2), bytestring, old-locale, time, HTTP, extensible-exceptions, dataenc, SHA, process, json, base (>= 4.5 && < 4.8), monad-control, transformers-base, lifted-base, IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process, - SafeSemaphore, uuid, random, dlist + SafeSemaphore, uuid, random, dlist, unix-compat -- Need to list these because they're generated from .hsc files. Other-Modules: Utility.Touch Utility.Mounts Include-Dirs: Utility @@ -86,6 +86,11 @@ Executable git-annex if flag(Production) GHC-Options: -O2 + if os(windows) + CPP-Options: -D__WINDOWS__ + else + Build-Depends: unix + if flag(TestSuite) Build-Depends: HUnit CPP-Options: -DWITH_TESTSUITE diff --git a/git-annex.hs b/git-annex.hs index 0f45f53eb..b8b05a27c 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -13,7 +13,10 @@ import System.FilePath import qualified GitAnnex import qualified GitAnnexShell #ifdef WITH_TESTSUITE +#ifndef __WINDOWS__ import qualified Test +#define CHECK_TEST +#endif #endif main :: IO () @@ -25,7 +28,7 @@ main = run =<< getProgName isshell n = takeFileName n == "git-annex-shell" go a = do ps <- getArgs -#ifdef WITH_TESTSUITE +#ifdef CHECK_TEST if ps == ["test"] then Test.main else a ps |