diff options
| -rwxr-xr-x | Annex/Branch.hs | 14 | ||||
| -rwxr-xr-x | Annex/Content.hs | 15 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/Content/Direct.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/Direct.hs | 2 | ||||
| -rwxr-xr-x | Annex/Environment.hs | 10 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/Journal.hs | 22 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/Link.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/LockPool.hs | 9 | ||||
| -rwxr-xr-x[-rw-r--r--] | Annex/Perms.hs | 1 | ||||
| -rwxr-xr-x | Annex/Ssh.hs | 10 | ||||
| -rw-r--r-- | Annex/Version.hs | 6 | ||||
| -rwxr-xr-x[-rw-r--r--] | Backend/SHA.hs | 1 | ||||
| -rwxr-xr-x[-rw-r--r--] | Backend/WORM.hs | 2 | ||||
| -rwxr-xr-x | CmdLine.hs | 4 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Add.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Fix.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/FromKey.hs | 2 | ||||
| -rwxr-xr-x | Command/Fsck.hs | 16 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Import.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Indirect.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/ReKey.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/RecvKey.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Status.hs | 1 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/TransferKeys.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Command/Unannex.hs | 6 | ||||
| -rwxr-xr-x | Creds.hs | 4 | ||||
| -rwxr-xr-x | Git.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Git/Config.hs | 0 | ||||
| -rwxr-xr-x | Git/Construct.hs | 6 | ||||
| -rwxr-xr-x | Git/CurrentRepo.hs | 8 | ||||
| -rwxr-xr-x[-rw-r--r--] | GitAnnex.hs | 8 | ||||
| -rwxr-xr-x | GitAnnexShell.hs | 10 | ||||
| -rwxr-xr-x[-rw-r--r--] | Init.hs | 16 | ||||
| -rwxr-xr-x[-rw-r--r--] | Limit.hs | 1 | ||||
| -rwxr-xr-x[-rw-r--r--] | Logs/Transfer.hs | 21 | ||||
| -rwxr-xr-x[-rw-r--r--] | Remote/Directory.hs | 6 | ||||
| -rwxr-xr-x[-rw-r--r--] | Remote/Git.hs | 13 | ||||
| -rwxr-xr-x[-rw-r--r--] | Remote/Helper/Hooks.hs | 6 | ||||
| -rwxr-xr-x | Remote/Rsync.hs | 16 | ||||
| -rwxr-xr-x[-rw-r--r--] | Seek.hs | 2 | ||||
| -rwxr-xr-x | Test.hs | 4 | ||||
| -rwxr-xr-x[-rw-r--r--] | Upgrade.hs | 9 | ||||
| -rwxr-xr-x[-rw-r--r--] | Upgrade/V1.hs | 0 | ||||
| -rwxr-xr-x | Utility/Daemon.hs | 19 | ||||
| -rwxr-xr-x | Utility/Env.hs | 39 | ||||
| -rwxr-xr-x | Utility/FileMode.hs | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | Utility/InodeCache.hs | 3 | ||||
| -rwxr-xr-x | Utility/LogFile.hs | 17 | ||||
| -rwxr-xr-x | Utility/Misc.hs | 4 | ||||
| -rwxr-xr-x[-rw-r--r--] | Utility/Url.hs | 1 | ||||
| -rwxr-xr-x | Utility/UserInfo.hs | 22 | ||||
| -rwxr-xr-x[-rw-r--r--] | git-annex.hs | 5 |
52 files changed, 319 insertions, 64 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 3788358f2..8c3fb41f6 100755 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -24,8 +24,10 @@ module Annex.Branch ( ) where import qualified Data.ByteString.Lazy.Char8 as L -#ifndef mingw32_HOST_OS -import System.Posix.Env +#ifdef __ANDROID__ +import System.Posix.Env (getEnv) +#else +import System.Environment (getEnvironment) #endif import Common.Annex @@ -290,12 +292,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/Content.hs b/Annex/Content.hs index ad04bdba1..5ec3c1b3f 100755 --- 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..1aa3c9105 100644..100755 --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -33,6 +33,8 @@ import Utility.TempFile import Logs.Location import Utility.InodeCache +import System.PosixCompat.Files + {- Absolute FilePaths of Files in the tree that are associated with a key. -} associatedFiles :: Key -> Annex [FilePath] associatedFiles key = do diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 596c90994..5d679eee6 100644..100755 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -27,6 +27,8 @@ import Utility.InodeCache import Utility.CopyFile import Annex.Perms +import System.PosixCompat.Files + {- Uses git ls-files to find files that need to be committed, and stages - them into the index. Returns True if some changes were staged. -} stageDirect :: Annex Bool diff --git a/Annex/Environment.hs b/Annex/Environment.hs index fef6989ee..fd757ee2c 100755 --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -10,10 +10,12 @@ module Annex.Environment where import Common.Annex +#ifndef __WINDOWS__ import Utility.UserInfo +#endif import qualified Git.Config -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Env #endif import Network.BSD @@ -28,7 +30,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 @@ -42,3 +47,4 @@ checkEnvironmentIO = do -- in runshell instead. ensureEnv _ _ = noop #endif +#endif diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 2df5294ee..f86d03cf6 100644..100755 --- 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 @@ -77,13 +79,23 @@ fileJournal = replace "//" "_" . replace "_" "/" - 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..0a72f75ca 100644..100755 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -19,6 +19,8 @@ import qualified Git.UpdateIndex import qualified Annex.Queue import Git.Types +import System.PosixCompat.Files + type LinkTarget = String {- Checks if a file is a link to a key. -} diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs index 45fc55b3c..d8bc08485 100644..100755 --- 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/Perms.hs b/Annex/Perms.hs index f5925b741..de01ae0f8 100644..100755 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -22,6 +22,7 @@ import qualified Annex import Config import System.Posix.Types +import System.PosixCompat.Files withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = maybe startup a =<< Annex.getState Annex.shared diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 1846fd342..56109774b 100755 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -14,7 +14,7 @@ module Annex.Ssh ( ) where import qualified Data.Map as M -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Env #endif @@ -78,7 +78,11 @@ sshCacheDir ) | otherwise = return Nothing where +#ifndef __WINDOWS__ gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR" +#else + gettmpdir = return Nothing +#endif usetmpdir tmpdir = liftIO $ catchMaybeIO $ do createDirectoryIfMissing True tmpdir return tmpdir @@ -97,6 +101,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 @@ -112,6 +117,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/Backend/SHA.hs b/Backend/SHA.hs index a735ce1e5..f906dd3bb 100644..100755 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -18,6 +18,7 @@ import qualified Build.SysConfig as SysConfig import Data.Digest.Pure.SHA import qualified Data.ByteString.Lazy as L import Data.Char +import System.PosixCompat.Files type SHASize = Int diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 3471eedc1..03c7f9899 100644..100755 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -12,6 +12,8 @@ import Types.Backend import Types.Key import Types.KeySource +import System.PosixCompat.Files + backends :: [Backend] backends = [backend] diff --git a/CmdLine.hs b/CmdLine.hs index b7b8b70f2..8f4c99269 100755 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -17,7 +17,7 @@ import qualified Control.Exception as E import qualified Data.Map as M import Control.Exception (throw) import System.Console.GetOpt -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Signals #endif @@ -118,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..100755 --- 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/Fix.hs b/Command/Fix.hs index 6aedbad6e..c6b4df257 100644..100755 --- 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..100755 --- 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 c63bc3ea0..fe1d35162 100755 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -9,6 +9,8 @@ module Command.Fsck where +import System.PosixCompat.Files + import Common.Annex import Command import qualified Annex @@ -30,8 +32,10 @@ import qualified Option import Types.Key import Utility.HumanTime -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Process (getProcessID) +#else +import System.Random (getStdRandom, random) #endif import Data.Time.Clock.POSIX import Data.Time @@ -142,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 @@ -453,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..100755 --- 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..100755 --- 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..100755 --- 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..100755 --- 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..100755 --- 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/TransferKeys.hs b/Command/TransferKeys.hs index 2f5ea1fe4..d83170bbc 100644..100755 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -9,6 +9,8 @@ module Command.TransferKeys where +import System.PosixCompat.Files + import Common.Annex import Command import Annex.Content diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 53b593f20..6674b37d2 100644..100755 --- 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 @@ -109,12 +109,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 +#else +setEnvCredPair _ _ = error "setEnvCredPair TODO" +#endif writeCacheCredPair :: CredPair -> CredPairStorage -> Annex () writeCacheCredPair credpair storage = @@ -32,7 +32,7 @@ module Git ( ) where import Network.URI (uriPath, uriScheme, unEscapeString) -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Files #endif diff --git a/Git/Config.hs b/Git/Config.hs index adc75a208..adc75a208 100644..100755 --- a/Git/Config.hs +++ b/Git/Config.hs diff --git a/Git/Construct.hs b/Git/Construct.hs index f7aca6130..1ed91a017 100755 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -23,7 +23,7 @@ module Git.Construct ( checkForRepo, ) where -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.User #endif import qualified Data.Map as M hiding (map, split) @@ -196,6 +196,9 @@ repoAbsPath d = do return $ h </> d' expandTilde :: FilePath -> IO FilePath +#ifdef __WINDOWS__ +expandTilde = return +#else expandTilde = expandt True where expandt _ [] = return "" @@ -216,6 +219,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 b2c15c23f..4b8c1fca8 100755 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -9,7 +9,7 @@ module Git.CurrentRepo where -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Env (getEnv, unsetEnv) #endif @@ -39,18 +39,24 @@ get = do case wt of Nothing -> return r Just d -> do +#ifndef __WINDOWS__ cwd <- getCurrentDirectory unless (d `dirContains` cwd) $ changeWorkingDirectory d +#endif return $ addworktree wt r where pathenv s = do +#ifndef __WINDOWS__ v <- getEnv s case v of Just d -> do 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/GitAnnex.hs b/GitAnnex.hs index 211d79ef3..ef6e0303a 100644..100755 --- 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 df0bf4c5d..6f03ac73b 100755 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -5,13 +5,9 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module GitAnnexShell where -#ifndef mingw32_HOST_OS -import System.Posix.Env -#endif +import System.Environment import System.Console.GetOpt import Common.Annex @@ -149,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 @@ -179,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, @@ -34,11 +36,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 @@ -113,6 +119,9 @@ preCommitScript = unlines probeCrippledFileSystem :: Annex Bool probeCrippledFileSystem = do +#ifdef __WINDOWS__ + return True +#else tmp <- fromRepo gitAnnexTmpDir let f = tmp </> "gaprobe" liftIO $ do @@ -132,6 +141,7 @@ probeCrippledFileSystem = do preventWrite f allowWrite f return True +#endif checkCrippledFileSystem :: Annex () checkCrippledFileSystem = whenM probeCrippledFileSystem $ do @@ -149,6 +159,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 +172,7 @@ probeFifoSupport = do getFileStatus f nukeFile f return $ either (const False) isNamedPipe ms +#endif checkFifoSupport :: Annex () checkFifoSupport = unlessM probeFifoSupport $ do diff --git a/Limit.hs b/Limit.hs index 56887a5fb..1da282c91 100644..100755 --- a/Limit.hs +++ b/Limit.hs @@ -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/Logs/Transfer.hs b/Logs/Transfer.hs index cfe9e49a0..3f36311a2 100644..100755 --- 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 @@ -18,6 +20,7 @@ import Utility.Percentage import Utility.QuickCheck import System.Posix.Types +import System.PosixCompat.Files import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time @@ -122,6 +125,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 +138,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 +206,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 +221,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/Remote/Directory.hs b/Remote/Directory.hs index d3885e89e..c960bb1b4 100644..100755 --- 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..0cc4da40c 100644..100755 --- 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, @@ -341,6 +343,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 +353,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 +400,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 +423,9 @@ rsyncOrCopyFile rsyncparams src dest p = p sz watchfilesize sz _ -> watchfilesize oldsz +#endif + dorsync = rsyncHelper (Just p) $ + rsyncparams ++ [Param src, Param 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..100755 --- 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 1c4b1d112..768c15777 100755 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -11,8 +11,10 @@ module Remote.Rsync (remote) where import qualified Data.ByteString.Lazy as L import qualified Data.Map as M -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix.Process (getProcessID) +#else +import System.Random (getStdRandom, random) #endif import Common.Annex @@ -219,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 @@ -273,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 @@ -11,6 +11,8 @@ module Seek where +import System.PosixCompat.Files + import Common.Annex import Types.Command import Types.Key @@ -5,19 +5,15 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Test where import Test.HUnit import Test.QuickCheck import Test.QuickCheck.Test -#ifndef mingw32_HOST_OS import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Files import System.Posix.Env -#endif import Control.Exception.Extensible import qualified Data.Map as M import System.IO.HVFS (SystemFS(..)) diff --git a/Upgrade.hs b/Upgrade.hs index 705b190d8..30f2b7ed8 100644..100755 --- 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..e048b3db8 100644..100755 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index fb8c61f75..a01b078b8 100755 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -12,9 +12,10 @@ module Utility.Daemon where import Common import Utility.LogFile -#ifndef mingw32_HOST_OS +#ifndef __WINDOWS__ import System.Posix #endif +import System.Posix.Types {- Run an action as a daemon, with all output sent to a file descriptor. - @@ -23,6 +24,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 @@ -44,11 +46,15 @@ daemonize logfd pidfile changedirectory a = do a out out = exitImmediately ExitSuccess +#else +daemonize = error "daemonize TODO" +#endif {- Locks the pid file, with an exclusive, non-blocking lock. - Writes the pid to the file, fully atomically. - Fails if the pid file is already locked by another process. -} lockPidFile :: FilePath -> IO () +#ifndef __WINDOWS__ lockPidFile file = do createDirectoryIfMissing True (parentDir file) fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags @@ -65,6 +71,9 @@ lockPidFile file = do closeFd fd where newfile = file ++ ".new" +#else +lockPidFile = error "lockPidFile TODO" +#endif alreadyRunning :: IO () alreadyRunning = error "Daemon is already running." @@ -74,6 +83,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 @@ -92,10 +102,17 @@ checkDaemon pidfile = do "stale pid in " ++ pidfile ++ " (got " ++ show pid' ++ "; expected " ++ show pid ++ " )" +#else +checkDaemon = error "checkDaemon TODO" +#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 TODO" +#endif diff --git a/Utility/Env.hs b/Utility/Env.hs new file mode 100755 index 000000000..713360154 --- /dev/null +++ b/Utility/Env.hs @@ -0,0 +1,39 @@ +{- 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 __WINDOWS__ +import qualified System.Environment as E +import Utility.Exception +#else +import qualified System.Posix.Environment as E +#endif + +{- Posix getEnv is faster than the one in System.Environment, + - so use when available. -} +getEnv :: String -> IO (Maybe String) +#ifndef __WINDOWS__ +getEnv = E.getEnv +#else +getEnv = catchMaybeIO . E.getEnv +#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 -> IO Bool +#ifndef __WINDOWS__ +setEnv var val = do + E.setEnv var val + return True +#else +setEnv _ _ = return False +#endif diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index b63575499..e9701d967 100755 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -113,10 +113,10 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -#endif 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/InodeCache.hs b/Utility/InodeCache.hs index e08abc6ad..ec0f206d3 100644..100755 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -8,7 +8,8 @@ module Utility.InodeCache where import Common -import System.Posix.Types +import System.PosixCompat.Types +import System.PosixCompat.Files import Utility.QuickCheck data InodeCachePrim = InodeCachePrim FileID FileOffset EpochTime diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index c6faee028..ccda429fc 100755 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -11,15 +11,18 @@ module Utility.LogFile where import Common -#ifndef mingw32_HOST_OS -import System.Posix -#endif +import System.Posix.Types +import System.PosixCompat.Files 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 @@ -48,11 +51,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/Misc.hs b/Utility/Misc.hs index da4da0a60..39d0e3de0 100755 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -122,16 +122,18 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -#ifndef mingw32_HOST_OS {- Reaps any zombie git processes. - - Warning: Not thread safe. Anything that was expecting to wait - on a process and get back an exit status is going to be confused - if this reap gets there first. -} reapZombies :: IO () +#ifndef mingw32_HOST_OS reapZombies = 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/Url.hs b/Utility/Url.hs index b831b3f01..97862e370 100644..100755 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -20,6 +20,7 @@ import Network.URI import qualified Network.Browser as Browser import Network.HTTP import Data.Either +import System.PosixCompat.Files import qualified Build.SysConfig diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index c0925ecb8..9781f584e 100755 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,45 +14,31 @@ module Utility.UserInfo ( ) where import Control.Applicative -#ifndef mingw32_HOST_OS -import System.Posix.User -import System.Posix.Env -#endif +import System.Posix.Types +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 -#ifndef mingw32_HOST_OS myHomeDir = myVal ["HOME"] homeDirectory -#else -myHomeDir = error "myHomeDir TODO" -#endif {- Current user's user name. -} myUserName :: IO String -#ifndef mingw32_HOST_OS myUserName = myVal ["USER", "LOGNAME"] userName -#else -myUserName = error "myUserName TODO" -#endif myUserGecos :: IO String #ifdef __ANDROID__ myUserGecos = return "" -- userGecos crashes on Android #else -#ifndef mingw32_HOST_OS myUserGecos = myVal [] userGecos -#else -myUserGecos = error "myUserGecos TODO" -#endif #endif -#ifndef mingw32_HOST_OS myVal :: [String] -> (UserEntry -> String) -> IO String myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars where check [] = return Nothing check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v getpwent = getUserEntryForID =<< getEffectiveUserID -#endif diff --git a/git-annex.hs b/git-annex.hs index 0f45f53eb..b8b05a27c 100644..100755 --- 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 |