summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex.hs61
-rw-r--r--Annex/Exception.hs29
-rw-r--r--Assistant/Monad.hs4
-rw-r--r--Command/Add.hs8
-rw-r--r--Utility/State.hs26
-rw-r--r--debian/changelog2
-rw-r--r--debian/control3
-rw-r--r--doc/install/fromscratch.mdwn3
-rw-r--r--git-annex.cabal2
9 files changed, 60 insertions, 78 deletions
diff --git a/Annex.hs b/Annex.hs
index f9cbfef0d..b0a67899f 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -1,6 +1,6 @@
{- git-annex monad
-
- - 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.
-}
@@ -16,7 +16,6 @@ module Annex (
newState,
run,
eval,
- exec,
getState,
changeState,
setFlag,
@@ -35,10 +34,10 @@ module Annex (
withCurrentState,
) where
-import "mtl" Control.Monad.State.Strict
-import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
-import Control.Monad.Base (liftBase, MonadBase)
+import "mtl" Control.Monad.Reader
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
import System.Posix.Types (Fd)
+import Control.Concurrent
import Common
import qualified Git
@@ -56,32 +55,24 @@ import Types.TrustLevel
import Types.Group
import Types.Messages
import Types.UUID
-import Utility.State
import qualified Utility.Matcher
import qualified Data.Map as M
import qualified Data.Set as S
--- git-annex's monad
-newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
+{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
+ - This allows modifying the state in an exception-safe fashion.
+ - The MVar is not exposed outside this module.
+ -}
+newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
deriving (
Monad,
MonadIO,
- MonadState AnnexState,
+ MonadReader (MVar AnnexState),
+ MonadCatchIO,
Functor,
Applicative
)
-instance MonadBase IO Annex where
- liftBase = Annex . liftBase
-
-instance MonadBaseControl IO Annex where
- newtype StM Annex a = StAnnex (StM (StateT AnnexState IO) a)
- liftBaseWith f = Annex $ liftBaseWith $ \runInIO ->
- f $ liftM StAnnex . runInIO . runAnnex
- restoreM = Annex . restoreM . unStAnnex
- where
- unStAnnex (StAnnex st) = st
-
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
data FileInfo = FileInfo
@@ -156,13 +147,32 @@ newState gitrepo = AnnexState
new :: Git.Repo -> IO AnnexState
new = newState <$$> Git.Config.read
-{- performs an action in the Annex monad -}
+{- Performs an action in the Annex monad from a starting state,
+ - returning a new state. -}
run :: AnnexState -> Annex a -> IO (a, AnnexState)
-run s a = runStateT (runAnnex a) s
+run s a = do
+ mvar <- newMVar s
+ r <- runReaderT (runAnnex a) mvar
+ s' <- takeMVar mvar
+ return (r, s')
+
+{- Performs an action in the Annex monad from a starting state,
+ - and throws away the new state. -}
eval :: AnnexState -> Annex a -> IO a
-eval s a = evalStateT (runAnnex a) s
-exec :: AnnexState -> Annex a -> IO AnnexState
-exec s a = execStateT (runAnnex a) s
+eval s a = do
+ mvar <- newMVar s
+ runReaderT (runAnnex a) mvar
+
+getState :: (AnnexState -> v) -> Annex v
+getState selector = do
+ mvar <- ask
+ s <- liftIO $ readMVar mvar
+ return $ selector s
+
+changeState :: (AnnexState -> AnnexState) -> Annex ()
+changeState modifier = do
+ mvar <- ask
+ liftIO $ modifyMVar_ mvar $ return . modifier
{- Sets a flag to True -}
setFlag :: String -> Annex ()
@@ -204,6 +214,7 @@ inRepo a = liftIO . a =<< gitRepo
fromRepo :: (Git.Repo -> a) -> Annex a
fromRepo a = a <$> gitRepo
+{- Calculates a value from an annex's git repository and its GitConfig. -}
calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
calcRepo a = do
s <- getState id
diff --git a/Annex/Exception.hs b/Annex/Exception.hs
index de6a23611..f06f568a4 100644
--- a/Annex/Exception.hs
+++ b/Annex/Exception.hs
@@ -1,36 +1,37 @@
{- exception handling in the git-annex monad
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Note that when an Annex action fails and the exception is handled
+ - by these functions, any changes the action has made to the
+ - AnnexState are retained. This works because the Annex monad
+ - internally stores the AnnexState in a MVar.
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Exception (
bracketIO,
- handle,
tryAnnex,
throw,
+ catchAnnex,
) where
-import Control.Exception.Lifted (handle, try)
-import Control.Monad.Trans.Control (liftBaseOp)
-import Control.Exception hiding (handle, try, throw)
+import Prelude hiding (catch)
+import "MonadCatchIO-transformers" Control.Monad.CatchIO (bracket, try, throw, catch)
+import Control.Exception hiding (handle, try, throw, bracket, catch)
import Common.Annex
-{- Runs an Annex action, with setup and cleanup both in the IO monad.
- -
- - Warning: Currently if the Annex action fails, any changes it has made
- - to Annex state are discarded.
- -}
+{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a
bracketIO setup cleanup go =
- liftBaseOp (Control.Exception.bracket setup cleanup) (const go)
+ bracket (liftIO setup) (liftIO . cleanup) (const go)
{- try in the Annex monad -}
tryAnnex :: Annex a -> Annex (Either SomeException a)
tryAnnex = try
-{- Throws an exception in the Annex monad. -}
-throw :: Control.Exception.Exception e => e -> Annex a
-throw = liftIO . throwIO
+{- catch in the Annex monad -}
+catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
+catchAnnex = catch
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index b8a471566..4b73061f9 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -26,7 +26,6 @@ module Assistant.Monad (
) where
import "mtl" Control.Monad.Reader
-import Control.Monad.Base (liftBase, MonadBase)
import System.Log.Logger
import Common.Annex
@@ -53,9 +52,6 @@ newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
Applicative
)
-instance MonadBase IO Assistant where
- liftBase = Assistant . liftBase
-
data AssistantData = AssistantData
{ threadName :: ThreadName
, threadState :: ThreadState
diff --git a/Command/Add.hs b/Command/Add.hs
index be7c6e75e..543d37136 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -130,8 +130,8 @@ ingest (Just source) = do
go k cache = ifM isDirect ( godirect k cache , goindirect k cache )
goindirect (Just (key, _)) _ = do
- handle (undo (keyFilename source) key) $
- moveAnnex key $ contentLocation source
+ catchAnnex (moveAnnex key $ contentLocation source)
+ (undo (keyFilename source) key)
liftIO $ nukeFile $ keyFilename source
return $ Just key
goindirect Nothing _ = failure "failed to generate a key"
@@ -172,7 +172,7 @@ undo :: FilePath -> Key -> IOException -> Annex a
undo file key e = do
whenM (inAnnex key) $ do
liftIO $ nukeFile file
- handle tryharder $ fromAnnex key file
+ catchAnnex (fromAnnex key file) tryharder
logStatus key InfoMissing
throw e
where
@@ -184,7 +184,7 @@ undo file key e = do
{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Bool -> Annex String
-link file key hascontent = handle (undo file key) $ do
+link file key hascontent = flip catchAnnex (undo file key) $ do
l <- inRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l
diff --git a/Utility/State.hs b/Utility/State.hs
deleted file mode 100644
index ad38db542..000000000
--- a/Utility/State.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{- state monad support
- -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Utility.State where
-
-import "mtl" Control.Monad.State.Strict
-
-{- Modifies Control.Monad.State's state, forcing a strict update.
- - This avoids building thunks in the state and leaking.
- - Why it's not the default, I don't know.
- -
- - Example: changeState $ \s -> s { foo = bar }
- -}
-changeState :: MonadState s m => (s -> s) -> m ()
-changeState f = do
- x <- get
- put $! f x
-
-{- Gets a value from the internal state, selected by the passed value
- - constructor. -}
-getState :: MonadState s m => (s -> a) -> m a
-getState = gets
diff --git a/debian/changelog b/debian/changelog
index 4d40c43b1..9ee201ab0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -2,6 +2,8 @@ git-annex (4.20130517) UNRELEASED; urgency=low
* Sanitize debian changelog version before putting it into cabal file.
Closes: #708619
+ * Switch to MonadCatchIO-transformers for better handling of state while
+ catching exceptions.
-- Joey Hess <joeyh@debian.org> Fri, 17 May 2013 11:17:03 -0400
diff --git a/debian/control b/debian/control
index 4fdee49f9..2a914fc0b 100644
--- a/debian/control
+++ b/debian/control
@@ -16,7 +16,7 @@ Build-Depends:
libghc-dav-dev (>= 0.3) [amd64 i386 kfreebsd-amd64 kfreebsd-i386 sparc],
libghc-quickcheck2-dev,
libghc-monad-control-dev (>= 0.3),
- libghc-lifted-base-dev,
+ libghc-monadcatchio-transformers-dev,
libghc-unix-compat-dev,
libghc-dlist-dev,
libghc-uuid-dev,
@@ -38,7 +38,6 @@ Build-Depends:
libghc-wai-logger-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64],
libghc-case-insensitive-dev,
libghc-http-types-dev,
- libghc-transformers-dev,
libghc-blaze-builder-dev,
libghc-crypto-api-dev,
libghc-network-multicast-dev,
diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn
index 7986ee002..8af51327e 100644
--- a/doc/install/fromscratch.mdwn
+++ b/doc/install/fromscratch.mdwn
@@ -9,7 +9,6 @@ quite a lot.
* [SHA](http://hackage.haskell.org/package/SHA)
* [dataenc](http://hackage.haskell.org/package/dataenc)
* [monad-control](http://hackage.haskell.org/package/monad-control)
- * [lifted-base](http://hackage.haskell.org/package/lifted-base)
* [QuickCheck 2](http://hackage.haskell.org/package/QuickCheck)
* [json](http://hackage.haskell.org/package/json)
* [IfElse](http://hackage.haskell.org/package/IfElse)
@@ -34,7 +33,6 @@ quite a lot.
* [data-default](http://hackage.haskell.org/package/data-default)
* [case-insensitive](http://hackage.haskell.org/package/case-insensitive)
* [http-types](http://hackage.haskell.org/package/http-types)
- * [transformers](http://hackage.haskell.org/package/transformers)
* [wai](http://hackage.haskell.org/package/wai)
* [wai-logger](http://hackage.haskell.org/package/wai-logger)
* [warp](http://hackage.haskell.org/package/warp)
@@ -50,6 +48,7 @@ quite a lot.
* [async](http://hackage.haskell.org/package/async)
* [HTTP](http://hackage.haskell.org/package/HTTP)
* [unix-compat](http://hackage.haskell.org/package/unix-compat)
+ * [MonadCatchIO-transformers](http://hackage.haskell.org/package/MonadCatchIO-transformers)
* 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 6d4fb4834..a9f229697 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -71,7 +71,7 @@ Executable git-annex
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,
+ base (>= 4.5 && < 4.8), monad-control, MonadCatchIO-transformers,
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,
SafeSemaphore, uuid, random, dlist, unix-compat
-- Need to list these because they're generated from .hsc files.
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 02:40:48 +0000