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
