remove uses of warningIO

It's not concurrent-output safe, and doesn't support
--json-error-messages.

Using Annex.makeRunner is a bit scary, because what if it's run in a
different thread from an active annex action? Normally the same Annex
state is not used concurrently in several threads, and it's not designed
to be fully concurrency safe. (Annex.Concurrent exists to deal with
that.) I think it will be ok in these simple cases though. Eg,
when buffering a warning message to json, Annex.changeState is used,
and it modifies the MVar in a concurrency safe way.

The only warningIO remaining is not a problem.
This commit is contained in:
Joey Hess 2020-12-02 14:57:43 -04:00
parent 1858b65d88
commit 63839532c9
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 28 additions and 22 deletions

View file

@ -28,6 +28,7 @@ import Annex.Common
import Types.Remote
import Types.Export
import qualified Git
import qualified Annex
import Config
import Config.Cost
import Annex.SpecialRemote.Config
@ -139,8 +140,9 @@ webdavSetup _ mu mcreds c gc = do
store :: DavHandleVar -> ChunkConfig -> Storer
store hv (LegacyChunks chunksize) = fileStorer $ \k f p ->
withDavHandle hv $ \dav -> liftIO $
withMeteredFile f p $ storeLegacyChunked chunksize k dav
withDavHandle hv $ \dav -> do
annexrunner <- Annex.makeRunner
liftIO $ withMeteredFile f p $ storeLegacyChunked annexrunner chunksize k dav
store hv _ = httpStorer $ \k reqbody ->
withDavHandle hv $ \dav -> liftIO $ goDAV dav $ do
let tmp = keyTmpLocation k
@ -448,15 +450,15 @@ prepDAV user pass = do
-- Legacy chunking code, to be removed eventually.
--
storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO ()
storeLegacyChunked chunksize k dav b =
storeLegacyChunked :: (Annex () -> IO ()) -> ChunkSize -> Key -> DavHandle -> L.ByteString -> IO ()
storeLegacyChunked annexrunner chunksize k dav b =
Legacy.storeChunks k tmp dest storer recorder finalizer
where
storehttp l b' = void $ goDAV dav $ do
maybe noop (void . mkColRecursive) (locationParent l)
debugDav $ "putContent " ++ l
inLocation l $ putContentM (contentType, b')
storer locs = Legacy.storeChunked chunksize locs storehttp b
storer locs = Legacy.storeChunked annexrunner chunksize locs storehttp b
recorder l s = storehttp l (L8.fromString s)
finalizer tmp' dest' = goDAV dav $
finalizeStore dav tmp' (fromJust $ locationParent dest')