Merge branch 'master' into ghc7.4
Conflicts: Utility/Misc.hs
This commit is contained in:
Joey Hess
commit
44b115e0b1
16 changed files with 78 additions and 100 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
39
Utility/Exception.hs
Normal file
39
Utility/Exception.hs
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
{- Simple IO exception handling
|
||||
-
|
||||
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
||||
<pre>
|
||||
import Codec.Binary.UTF8.String
|
||||
import System.Environment
|
||||
|
||||
main = do
|
||||
args <- getArgs
|
||||
let file = decodeString $ head args
|
||||
putStrLn $ "file is: " ++ file
|
||||
putStr =<< readFile file
|
||||
</pre>
|
||||
|
||||
If I pass this a filename like 'ü', it will fail, and notice
|
||||
the bad encoding of the filename in the error message:
|
||||
|
||||
<pre>
|
||||
$ echo hi > ü; runghc foo.hs ü
|
||||
file is: ü
|
||||
foo.hs: <20>: openFile: does not exist (No such file or directory)
|
||||
</pre>
|
||||
|
||||
On the other hand, if I remove the decodeString, it prints the filename
|
||||
wrong, while accessing it right:
|
||||
|
||||
<pre>
|
||||
$ runghc foo.hs ü
|
||||
file is: üa
|
||||
hi
|
||||
</pre>
|
||||
|
||||
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.
|
||||
|
|
|
|||
|
|
@ -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":
|
||||
<http://www.haskell.org/ghc/docs/6.6/html/building/platforms.html>
|
||||
I don't know where to get one. Did find this:
|
||||
<http://copilotco.com/mail-archives/haskell-cafe.2007/msg00824.html>
|
||||
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
|
||||
</pre>
|
||||
|
||||
A good starting point is
|
||||
<http://hackage.haskell.org/package/unix-compat-0.3.0.1>. However, note
|
||||
that its implementations of stuff like `createSymbolicLink` are stubs.
|
||||
--[[Joey]]
|
||||
|
|
|
|||
Loading…
Reference in a new issue