diff --git a/Annex/Content.hs b/Annex/Content.hs index dcfd43866b..d10370bc9a 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -25,7 +25,6 @@ module Annex.Content ( preseedTmp, ) where -import System.IO.Error (try) import Control.Exception (bracket_) import System.Posix.Types @@ -79,7 +78,7 @@ lockContent key a = do where lock Nothing = return Nothing lock (Just l) = do - v <- try $ setLock l (WriteLock, AbsoluteSeek, 0, 0) + v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) case v of Left _ -> error "content is locked" Right _ -> return $ Just l diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 9c5be89b19..34c4d98c88 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -91,4 +91,4 @@ lockJournal a = do {- Runs an action, catching failure and running something to fix it up, and - retrying if necessary. -} doRedo :: IO a -> IO b -> IO a -doRedo a b = catch a $ const $ b >> a +doRedo a b = catchIO a $ const $ b >> a diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 14ea74e53e..d6f36e8689 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -11,7 +11,6 @@ module Annex.Ssh ( ) where import qualified Data.Map as M -import System.IO.Error (try) import Common.Annex import Annex.LockPool @@ -72,7 +71,8 @@ sshCleanup = do let lockfile = socket2lock socketfile unlockFile lockfile fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags - v <- liftIO $ try $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) case v of Left _ -> return () Right _ -> stopssh socketfile diff --git a/Backend.hs b/Backend.hs index 003d62bfcd..e351bb3b27 100644 --- a/Backend.hs +++ b/Backend.hs @@ -16,7 +16,6 @@ module Backend ( maybeLookupBackendName ) where -import System.IO.Error (try) import System.Posix.Files import Common.Annex @@ -77,7 +76,7 @@ genKey' (b:bs) file = do - by examining what the file symlinks to. -} lookupFile :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile file = do - tl <- liftIO $ try getsymlink + tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing Right l -> makekey l diff --git a/CmdLine.hs b/CmdLine.hs index 61e6c26bb8..18bb5fe51b 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -11,7 +11,6 @@ module CmdLine ( shutdown ) where -import qualified System.IO.Error as IO import qualified Control.Exception as E import Control.Exception (throw) import System.Console.GetOpt @@ -74,7 +73,7 @@ tryRun' errnum _ cmd [] | otherwise = return () tryRun' errnum state cmd (a:as) = run >>= handle where - run = IO.try $ Annex.run state $ do + run = tryIO $ Annex.run state $ do Annex.Queue.flushWhenFull a handle (Left err) = showerr err >> cont False state diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 59af29edb1..469fad749e 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -81,7 +81,7 @@ performRemote key file backend numcopies remote = do t <- fromRepo gitAnnexTmpDir let tmp = t "fsck" ++ show pid ++ "." ++ keyFile key liftIO $ createDirectoryIfMissing True t - let cleanup = liftIO $ catch (removeFile tmp) (const $ return ()) + let cleanup = liftIO $ catchIO (removeFile tmp) (const $ return ()) cleanup cleanup `after` a tmp getfile tmp = do diff --git a/Common.hs b/Common.hs index fb998214bc..cc6cf92527 100644 --- a/Common.hs +++ b/Common.hs @@ -21,6 +21,7 @@ import System.Posix.Process as X hiding (executeFile) import System.Exit as X import Utility.Misc as X +import Utility.Exception as X import Utility.SafeCommand as X import Utility.Path as X import Utility.Directory as X diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 9b54d8c855..50c3b10b39 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -8,7 +8,6 @@ module Remote.Bup (remote) where import qualified Data.ByteString.Lazy.Char8 as L -import System.IO.Error import qualified Data.Map as M import System.Process @@ -200,7 +199,7 @@ getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo) getBupUUID r u | Git.repoIsUrl r = return (u, r) | otherwise = liftIO $ do - ret <- try $ Git.Config.read r + ret <- tryIO $ Git.Config.read r case ret of Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r') Left _ -> return (NoUUID, r) diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index c5310c641a..c439c7caa2 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -7,8 +7,6 @@ module Upgrade.V0 where -import System.IO.Error (try) - import Common.Annex import Annex.Content import qualified Upgrade.V1 @@ -47,7 +45,7 @@ getKeysPresent0 dir = do return $ map fileKey0 files where present d = do - result <- try $ + result <- tryIO $ getFileStatus $ dir ++ "/" ++ takeFileName d case result of Right s -> return $ isRegularFile s diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index add50fcf3a..ca2bff6617 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -7,7 +7,6 @@ module Upgrade.V1 where -import System.IO.Error (try) import System.Posix.Types import Data.Char @@ -183,7 +182,7 @@ readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) [] lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile1 file = do - tl <- liftIO $ try getsymlink + tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing Right l -> makekey l @@ -216,7 +215,7 @@ getKeyFilesPresent1' dir = do liftIO $ filterM present files where present f = do - result <- try $ getFileStatus f + result <- tryIO $ getFileStatus f case result of Right s -> return $ isRegularFile s Left _ -> return False diff --git a/Utility/Directory.hs b/Utility/Directory.hs index b5fedb9c7d..e7b7c442b2 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,11 +16,12 @@ import Control.Monad.IfElse import Utility.SafeCommand import Utility.TempFile +import Utility.Exception {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = try (rename src dest) >>= onrename +moveFile src dest = tryIO (rename src dest) >>= onrename where onrename (Right _) = return () onrename (Left e) @@ -40,11 +41,10 @@ moveFile src dest = try (rename src dest) >>= onrename Param src, Param tmp] unless ok $ do -- delete any partial - _ <- try $ - removeFile tmp + _ <- tryIO $ removeFile tmp rethrow isdir f = do - r <- try (getFileStatus f) + r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s diff --git a/Utility/Exception.hs b/Utility/Exception.hs new file mode 100644 index 0000000000..7b6c9c999f --- /dev/null +++ b/Utility/Exception.hs @@ -0,0 +1,39 @@ +{- Simple IO exception handling + - + - Copyright 2011-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Exception where + +import Prelude hiding (catch) +import Control.Exception +import Control.Applicative + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: IO Bool -> IO Bool +catchBoolIO a = catchDefaultIO a False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: IO a -> IO (Maybe a) +catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: IO a -> a -> IO a +catchDefaultIO a def = catchIO a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: IO a -> IO (Either String a) +catchMsgIO a = dispatch <$> tryIO a + where + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v + +{- catch specialized for IO errors only -} +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = catch + +{- try specialized for IO errors only -} +tryIO :: IO a -> IO (Either IOException a) +tryIO = try diff --git a/Utility/Misc.hs b/Utility/Misc.hs index c4992e1428..9c284c826f 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -8,9 +8,7 @@ module Utility.Misc where import System.IO -import System.IO.Error (try) import Control.Monad -import Control.Applicative import GHC.IO.Encoding {- Sets a Handle to use the filesystem encoding. This causes data @@ -45,22 +43,3 @@ separate c l = unbreak $ break c l {- Breaks out the first line. -} firstLine :: String-> String firstLine = takeWhile (/= '\n') - -{- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool -catchBoolIO a = catchDefaultIO a False - -{- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing - -{- Catches IO errors and returns a default value. -} -catchDefaultIO :: IO a -> a -> IO a -catchDefaultIO a def = catch a (const $ return def) - -{- Catches IO errors and returns the error message. -} -catchMsgIO :: IO a -> IO (Either String a) -catchMsgIO a = dispatch <$> try a - where - dispatch (Left e) = Left $ show e - dispatch (Right v) = Right v diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs index 469d52e8ce..4dcbf1cca4 100644 --- a/Utility/TempFile.hs +++ b/Utility/TempFile.hs @@ -12,7 +12,7 @@ import System.IO import System.Posix.Process hiding (executeFile) import System.Directory -import Utility.Misc +import Utility.Exception import Utility.Path {- Runs an action like writeFile, writing to a temp file first and diff --git a/doc/bugs/problems_with_utf8_names.mdwn b/doc/bugs/problems_with_utf8_names.mdwn index b734ddecf7..fbdca41cd1 100644 --- a/doc/bugs/problems_with_utf8_names.mdwn +++ b/doc/bugs/problems_with_utf8_names.mdwn @@ -1,6 +1,12 @@ This bug is reopened to track some new UTF-8 filename issues caused by GHC -7.4. Older versions of GHC, like the 7.0.4 in debian unstable, are not -affected. See the comments for details about the new bug. --[[Joey]] +7.4. In this version of GHC, git-annex's hack to support filenames in any +encoding no longer works. Even unicode filenames fail to work when +git-annex is built with 7.4. --[[Joey]] + +I now have a `ghc7.4` branch in git that seems to solve this, +for all filename encodings, and all system encodings. It will +only build with the new GHC. If you have this problem, give it a try! +--[[Joey]] ---- @@ -74,39 +80,3 @@ It looks like the common latin1-to-UTF8 encoding. Functionality other than otupu > > On second thought, I switched to this. Any decoding of a filename > > is going to make someone unhappy; the previous approach broke > > non-utf8 filenames. - ----- - -Simpler test case: - -
-import Codec.Binary.UTF8.String
-import System.Environment
-
-main = do
-        args <- getArgs
-        let file = decodeString $ head args
-        putStrLn $ "file is: " ++ file
-        putStr =<< readFile file
-
- -If I pass this a filename like 'ü', it will fail, and notice -the bad encoding of the filename in the error message: - -
-$ echo hi > ü; runghc foo.hs ü
-file is: ü
-foo.hs: �: openFile: does not exist (No such file or directory)
-
- -On the other hand, if I remove the decodeString, it prints the filename -wrong, while accessing it right: - -
-$ runghc foo.hs ü
-file is: üa
-hi
-
- -The only way that seems to consistently work is to delay decoding the -filename to places where it's output. But then it's easy to miss some. diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn index 8df792fd6e..c64e6fce5c 100644 --- a/doc/todo/windows_support.mdwn +++ b/doc/todo/windows_support.mdwn @@ -1,25 +1,16 @@ -short answer: no +Can it be built on Windows? -Long answer, quoting from a mail to someone else: +short answer: not yet -Well, I can tell you that it assumes a POSIX system, both in available -utilities and system calls, So you'd need to use cygwin or something -like that. (Perhaps you already are for git, I think git also assumes a -POSIX system.) So you need a Haskell that can target that. What this -page refers to as "GHC-Cygwin": - -I don't know where to get one. Did find this: - +First, you need to get some unix utilities for windows. Git of course. +Also rsync, and a `cp` command that understands at least `cp -p`, and +`uuid`, and `xargs` and `sha1sum`. Note that some of these could be +replaced with haskell libraries to some degree. -(There are probably also still some places where it assumes / as a path -separator, although I fixed some. Probably almost all are fixed now.) +There are probably still some places where it assumes / as a path +separator, although I fixed probably almost all by now. -FWIW, git-annex works fine on OS X and other fine proprietary unixen. ;P ---[[Joey]] - ----- - -Alternatively, windows versions of these functions could be found, +Then windows versions of these functions could be found, which are all the ones that need POSIX, I think. A fair amount of this, the stuff to do with signals and users, could be empty stubs in windows. The file manipulation, particularly symlinks, would probably be the main @@ -63,3 +54,8 @@ sigCHLD sigINT unionFileModes + +A good starting point is +. However, note +that its implementations of stuff like `createSymbolicLink` are stubs. +--[[Joey]]