--- Begin Message ---
Source: haskell-dav
Severity: normal
Tags: patch
Please apply the two attached patches, which add stuff git-annex needs
to use DAV more efficiently.
--
see shy jo
From e9cc0657853024d32eb2c5a62d8e8a44882fe018 Mon Sep 17 00:00:00 2001
From: Joey Hess <[email protected]>
Date: Wed, 6 Aug 2014 16:16:44 -0400
Subject: [PATCH 1/2] add withDAVContext and runDAVContext
The use case for this is that I have code that cannot run in the DAV monad,
but I want it to run multiple DAV operations while reusing the context,
particularly the http manager's open connection.
---
Network/Protocol/HTTP/DAV.hs | 30 ++++++++++++++++++++++++------
1 file changed, 24 insertions(+), 6 deletions(-)
diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs
index c8d76ea..06d1ee9 100644
--- a/Network/Protocol/HTTP/DAV.hs
+++ b/Network/Protocol/HTTP/DAV.hs
@@ -24,6 +24,8 @@
module Network.Protocol.HTTP.DAV (
DAVT(..)
, evalDAVT
+ , withDAVContext
+ , runDAVContext
, setCreds
, setDepth
, setResponseTimeout
@@ -56,7 +58,7 @@ import Network.Protocol.HTTP.DAV.TH
import Control.Applicative (liftA2, Applicative)
import Control.Error (EitherT(..))
-import Control.Exception.Lifted (catchJust, finally, bracketOnError)
+import Control.Exception.Lifted (catchJust, finally, bracket, bracketOnError)
import Control.Lens ((^.), (.=), (%=))
import Control.Monad (liftM, liftM2, when, MonadPlus)
import Control.Monad.Base (MonadBase(..))
@@ -64,7 +66,7 @@ import Control.Monad.Error (MonadError)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans (lift, MonadTrans)
import Control.Monad.IO.Class (liftIO, MonadIO)
-import Control.Monad.State (evalStateT, get, MonadState, StateT)
+import Control.Monad.State (evalStateT, runStateT, get, MonadState, StateT)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import qualified Data.ByteString as B
@@ -95,13 +97,29 @@ instance MonadBaseControl b m => MonadBaseControl b (DAVT m) where
instance MonadTrans DAVT where
lift = DAVT . lift . lift
-evalDAVT :: MonadIO m => String -> DAVT m a -> m (Either String a)
+type DAVURL = String
+
+evalDAVT :: MonadIO m => DAVURL -> DAVT m a -> m (Either String a)
evalDAVT u f = do
+ ctx <- mkDAVContext u
+ r <- (evalStateT . runEitherT . runDAVT) f ctx
+ closeDAVContext ctx
+ return r
+
+mkDAVContext :: MonadIO m => DAVURL -> m DAVContext
+mkDAVContext u = liftIO $ do
mgr <- liftIO $ newManager tlsManagerSettings
req <- liftIO $ parseUrl u
- r <- (evalStateT . runEitherT . runDAVT) f $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"
- liftIO $ closeManager mgr
- return r
+ return $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"
+
+closeDAVContext :: MonadIO m => DAVContext -> m ()
+closeDAVContext ctx = liftIO $ closeManager (ctx ^. httpManager)
+
+withDAVContext :: (MonadIO m, MonadBaseControl IO m) => DAVURL -> (DAVContext -> m a) -> m a
+withDAVContext u = bracket (mkDAVContext u) closeDAVContext
+
+runDAVContext :: MonadIO m => DAVContext -> DAVT m a -> m (Either String a, DAVContext)
+runDAVContext ctx f = (runStateT . runEitherT . runDAVT) f ctx
choke :: IO (Either String a) -> IO a
choke f = do
--
2.1.0.rc1
From aa8fea0da0388fe8e76798587a915a75f731f548 Mon Sep 17 00:00:00 2001
From: Joey Hess <[email protected]>
Date: Wed, 6 Aug 2014 18:18:02 -0400
Subject: [PATCH 2/2] add inDAVLocation and getDAVLocation
inDAVLocation is useful for composing DAV monad actions that operate on
different locations within the same DAV repository.
getDAVLocation can be useful when writing code that might need to eg,
create the parent collection that will hold the current location.
Needed to pull in utf-8 string in order to convert from Request paths
to strings.
---
DAV.cabal | 4 +++-
Network/Protocol/HTTP/DAV.hs | 41 ++++++++++++++++++++++++++++++++++++++++-
debian/control | 3 +++
3 files changed, 46 insertions(+), 2 deletions(-)
diff --git a/DAV.cabal b/DAV.cabal
index bf54f44..85eb50e 100644
--- a/DAV.cabal
+++ b/DAV.cabal
@@ -1,5 +1,5 @@
name: DAV
-version: 0.6.2
+version: 0.7.0
synopsis: RFC 4918 WebDAV support
description:
This is a library for the Web Distributed Authoring and Versioning
@@ -40,6 +40,7 @@ library
, mtl >= 2.1
, transformers >= 0.3
, transformers-base
+ , utf8-string
, xml-conduit >= 1.0 && < 1.3
, xml-hamlet >= 0.4 && <= 0.5
executable hdav
@@ -63,6 +64,7 @@ executable hdav
, optparse-applicative >= 0.5.0
, transformers >= 0.3
, transformers-base
+ , utf8-string
, xml-conduit >= 1.0 && < 1.3
, xml-hamlet >= 0.4 && <= 0.5
diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs
index 06d1ee9..ca8fe59 100644
--- a/Network/Protocol/HTTP/DAV.hs
+++ b/Network/Protocol/HTTP/DAV.hs
@@ -51,6 +51,8 @@ module Network.Protocol.HTTP.DAV (
, putContentM'
, withLockIfPossible
, withLockIfPossibleForDelete
+ , inDAVLocation
+ , getDAVLocation
, module Network.Protocol.HTTP.DAV.TH
) where
@@ -72,11 +74,12 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.UTF8 as UTF8B
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe)
-import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, closeManager, HttpException(..), BodyReader, withResponse)
+import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, closeManager, HttpException(..), BodyReader, withResponse, path)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409)
@@ -403,3 +406,39 @@ calendarquery = XML.Document (XML.Prologue [] Nothing []) root []
<C:filter>
<C:comp-filter name="VCALENDAR">
|]
+
+-- | Normally, DAVT actions act on the url that is provided to eg, evalDAVT.
+-- Sometimes, it's useful to adjust the url that is acted on, while
+-- remaining in the same DAV session.
+--
+-- inLocation temporarily adjusts the url's path, while performing a
+-- DAVT action.
+--
+-- For example:
+--
+-- > import System.FilePath.Posix -- posix for url path manipulation
+-- >
+-- > mkColRecursive d = do
+-- > let parent = takeDirectory d
+-- > when (parent /= d) $
+-- > mkColRecursive parent
+-- > inDavLocation (</> d) mkCol
+--
+-- Note that operations that modify the DAVContext
+-- (such as setCreds and setCreds) can be run inside davLocation,
+-- but will not have any effect on the calling DAVContext.
+inDAVLocation :: MonadIO m => (String -> String) -> DAVT m a -> DAVT m a
+inDAVLocation f a = do
+ ctx <- get
+ let r = ctx ^. baseRequest
+ let r' = r { path = adjustpath r }
+ let ctx' = ctx { _baseRequest = r' }
+ lift $ either error return =<< (evalStateT . runEitherT . runDAVT) a ctx'
+ where
+ adjustpath = UTF8B.fromString . f . UTF8B.toString . path
+
+-- | Gets the path of the url that DAVT actions will act on.
+getDAVLocation :: Monad m => DAVT m String
+getDAVLocation = do
+ ctx <- get
+ return (UTF8B.toString $ path $ ctx ^. baseRequest)
diff --git a/debian/control b/debian/control
index e0f3ed3..d538a9b 100644
--- a/debian/control
+++ b/debian/control
@@ -37,6 +37,8 @@ Build-Depends: debhelper (>= 9)
, libghc-transformers-prof
, libghc-transformers-base-dev
, libghc-transformers-base-prof
+ , libghc-utf8-string-dev
+ , libghc-utf8-string-prof
, libghc-xml-conduit-dev (>= 1.0)
, libghc-xml-conduit-dev (<< 1.3)
, libghc-xml-conduit-prof
@@ -58,6 +60,7 @@ Build-Depends-Indep: ghc-doc
, libghc-optparse-applicative-doc
, libghc-transformers-doc
, libghc-transformers-base-doc
+ , libghc-utf8-string-doc
, libghc-xml-conduit-doc
, libghc-xml-hamlet-doc
Standards-Version: 3.9.5
--
2.1.0.rc1
signature.asc
Description: Digital signature
--- End Message ---
