DAV 1.0.7 → 1.1
raw patch · 2 files changed
+24/−26 lines, 2 filesdep +mtl-compatdep +transformers-compatdep −eitherdep ~exceptionsdep ~http-client
Dependencies added: mtl-compat, transformers-compat
Dependencies removed: either
Dependency ranges changed: exceptions, http-client
Files
- DAV.cabal +8/−6
- Network/Protocol/HTTP/DAV.hs +16/−20
DAV.cabal view
@@ -1,5 +1,5 @@ name: DAV-version: 1.0.7+version: 1.1 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning@@ -34,15 +34,16 @@ , case-insensitive >= 0.4 , containers , data-default- , either >= 4.3- , exceptions+ , exceptions >= 0.7 , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 , mtl >= 2.1+ , mtl-compat , transformers >= 0.3 , transformers-base+ , transformers-compat >= 0.3 , utf8-string , xml-conduit >= 1.0 , xml-hamlet >= 0.4 && < 0.5@@ -55,16 +56,17 @@ , case-insensitive >= 0.4 , containers , data-default- , either >= 4.3- , exceptions+ , exceptions >= 0.7 , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 , mtl >= 2.1+ , mtl-compat , optparse-applicative >= 0.10.0 , transformers >= 0.3 , transformers-base+ , transformers-compat >= 0.3 , utf8-string , xml-conduit >= 1.0 , xml-hamlet >= 0.4 && < 0.5@@ -81,4 +83,4 @@ source-repository this type: git location: git://anonscm.debian.org/users/clint/DAV.git- tag: DAV/1.0.7+ tag: DAV/1.1
Network/Protocol/HTTP/DAV.hs view
@@ -53,16 +53,15 @@ import Network.Protocol.HTTP.DAV.TH import Control.Applicative (liftA2, Alternative, Applicative)-import Control.Monad.Trans.Either (EitherT(..))+import Control.Monad.Trans.Except (ExceptT(..), throwE) import Control.Lens ((^.), (.=), (%=), (.~)) import Control.Monad (when, MonadPlus) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (bracket, bracketOnError, catchJust, finally, throwM, mask, uninterruptibleMask, MonadCatch, MonadMask, MonadThrow) import qualified Control.Monad.Catch as MonadCatch-import Control.Monad.Error (MonadError)+import Control.Monad.Except (MonadError) import Control.Monad.Fix (MonadFix) import Control.Monad.Trans.Class (lift, MonadTrans)-import Control.Monad.Trans.Either (left) import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.State (evalStateT, runStateT, get, MonadState, StateT) @@ -88,15 +87,15 @@ instance Default DAVContext where def = DAVContext [] def B.empty B.empty [] Nothing def Nothing "hDav-using application" -newtype DAVT m a = DAVT { runDAVT :: EitherT String (StateT DAVContext m) a }+newtype DAVT m a = DAVT { runDAVT :: ExceptT String (StateT DAVContext m) a } deriving (Alternative, Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext) -- this orphan instance is probably a bad idea-instance MonadMask m => MonadMask (EitherT e m) where- mask a = EitherT $ mask $ \u -> runEitherT (a $ q u)- where q u = EitherT . u . runEitherT- uninterruptibleMask a = EitherT $ uninterruptibleMask $ \u -> runEitherT (a $ q u)- where q u = EitherT . u . runEitherT+instance MonadMask m => MonadMask (ExceptT e m) where+ mask a = ExceptT $ mask $ \u -> runExceptT (a $ q u)+ where q u = ExceptT . u . runExceptT+ uninterruptibleMask a = ExceptT $ uninterruptibleMask $ \u -> runExceptT (a $ q u)+ where q u = ExceptT . u . runExceptT instance MonadCatch m => MonadCatch (DAVT m) where catch (DAVT m) f = DAVT $ MonadCatch.catch m (runDAVT . f)@@ -118,7 +117,7 @@ evalDAVT :: MonadIO m => DAVURL -> DAVT m a -> m (Either String a) evalDAVT u f = do ctx <- mkDAVContext u- r <- (evalStateT . runEitherT . runDAVT) f ctx+ r <- (evalStateT . runExceptT . runDAVT) f ctx closeDAVContext ctx return r @@ -135,7 +134,7 @@ 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+runDAVContext ctx f = (runStateT . runExceptT . runDAVT) f ctx setCreds :: MonadIO m => B.ByteString -> B.ByteString -> DAVT m () setCreds u p = basicusername .= u >> basicpassword .= p@@ -167,7 +166,7 @@ where go req = do ctx <- get- maybe (DAVT $ left "Can't perform request without manager") (liftIO . httpLbs req) (ctx ^. httpManager)+ maybe (DAVT $ throwE "Can't perform request without manager") (liftIO . httpLbs req) (ctx ^. httpManager) matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _)@@ -202,16 +201,13 @@ d <- get case _lockToken d of Nothing -> return ()- Just tok -> do let ahs = [(mk "Lock-Token", tok)]+ Just tok -> do let ahs = [(mk "Lock-Token", tok)] _ <- davRequest "UNLOCK" ahs emptyBody lockToken .= Nothing supportsLocking :: DAVContext -> Bool supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods -supportsCalDAV :: DAVContext -> Bool-supportsCalDAV = ("calendar-access" `elem`) . _complianceClasses- getPropsM :: MonadIO m => DAVT m XML.Document getPropsM = do let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")]@@ -230,7 +226,7 @@ withContentM handleresponse = do req <- mkDavRequest "GET" [] emptyBody ctx <- get- maybe (DAVT $ left "Can't handle response without manager") (\mgr -> liftIO $ withResponse req mgr handleresponse) (ctx ^. httpManager)+ maybe (DAVT $ throwE "Can't handle response without manager") (\mgr -> liftIO $ withResponse req mgr handleresponse) (ctx ^. httpManager) -- | Note that the entire request body is buffered in memory; not suitable -- for large files.@@ -288,8 +284,8 @@ root [] = propertyupdate [] root prop = propertyupdate [ XML.NodeElement $ XML.Element "D:set" Map.empty- [ XML.NodeElement $ XML.Element "D:prop" Map.empty prop ]- ]+ [ XML.NodeElement $ XML.Element "D:prop" Map.empty prop ]+ ] propertyupdate = XML.Element "D:propertyupdate" (Map.fromList [("xmlns:D", "DAV:")]) blacklist = [ "{DAV:}creationdate" , "{DAV:}displayname"@@ -382,7 +378,7 @@ let r = ctx ^. baseRequest r' = r { path = adjustpath r } ctx' = baseRequest .~ r' $ ctx- lift $ either error return =<< (evalStateT . runEitherT . runDAVT) a ctx'+ lift $ either error return =<< (evalStateT . runExceptT . runDAVT) a ctx' where adjustpath = UTF8B.fromString . f . UTF8B.toString . path