DAV 0.8 → 1.0
raw patch · 3 files changed
+87/−97 lines, 3 filesdep +data-defaultdep +exceptionsdep +utf8-stringdep −lifted-basedep −monad-controldep ~network
Dependencies added: data-default, exceptions, utf8-string
Dependencies removed: lifted-base, monad-control
Dependency ranges changed: network
Files
- DAV.cabal +8/−6
- Network/Protocol/HTTP/DAV.hs +78/−90
- Network/Protocol/HTTP/DAV/TH.hs +1/−1
DAV.cabal view
@@ -1,5 +1,5 @@ name: DAV-version: 0.8+version: 1.0 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning@@ -29,17 +29,18 @@ , bytestring , case-insensitive >= 0.4 , containers+ , data-default , either >= 4.1 , errors+ , exceptions , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0- , lifted-base >= 0.1- , monad-control >= 0.3.2 , mtl >= 2.1 , transformers >= 0.3 , transformers-base+ , utf8-string , xml-conduit >= 1.0 && < 1.3 , xml-hamlet >= 0.4 && < 0.5 executable hdav@@ -50,19 +51,20 @@ , bytestring , case-insensitive >= 0.4 , containers+ , data-default , either >= 4.1 , errors+ , exceptions , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0- , lifted-base >= 0.1- , monad-control >= 0.3.2 , mtl >= 2.1 , network >= 2.3 , optparse-applicative >= 0.5.0 , transformers >= 0.3 , transformers-base+ , utf8-string , xml-conduit >= 1.0 && < 1.3 , xml-hamlet >= 0.4 && < 0.5 @@ -74,4 +76,4 @@ source-repository this type: git location: git://anonscm.debian.org/users/clint/DAV.git- tag: DAV/0.8+ tag: DAV/1.0
Network/Protocol/HTTP/DAV.hs view
@@ -31,14 +31,6 @@ , setResponseTimeout , setUserAgent , DAVContext(..)- , getProps- , getPropsAndContent- , putContentAndProps- , putContent- , deleteContent- , moveContent- , makeCollection- , caldavReport , caldavReportM , delContentM , getPropsM@@ -51,6 +43,10 @@ , putContentM' , withLockIfPossible , withLockIfPossibleForDelete+ , inDAVLocation+ , getDAVLocation+ , mkDAVContext+ , closeDAVContext , module Network.Protocol.HTTP.DAV.TH ) where @@ -58,25 +54,28 @@ import Control.Applicative (liftA2, Applicative) import Control.Error (EitherT(..))-import Control.Exception.Lifted (catchJust, finally, bracket, bracketOnError)-import Control.Lens ((^.), (.=), (%=))-import Control.Monad (liftM, liftM2, when, MonadPlus)+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.Fix (MonadFix)-import Control.Monad.Trans (lift, MonadTrans)+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)-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 Data.Default (Default, def) 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) @@ -86,14 +85,31 @@ import Data.CaseInsensitive (mk) +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 } deriving (Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext) -instance MonadBaseControl b m => MonadBaseControl b (DAVT m) where- newtype StM (DAVT m) a = StDAVT { unStDAVT :: StM (EitherT String (StateT DAVContext m)) a }- liftBaseWith f = DAVT . liftBaseWith $ \r -> f $ liftM StDAVT . r . runDAVT- restoreM = DAVT . restoreM . unStDAVT+-- 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 MonadCatch m => MonadCatch (DAVT m) where+ catch (DAVT m) f = DAVT $ MonadCatch.catch m (runDAVT . f)++instance MonadMask m => MonadMask (DAVT m) where+ mask a = DAVT $ mask $ \u -> runDAVT (a $ q u)+ where q u = DAVT . u . runDAVT+ uninterruptibleMask a = DAVT $ uninterruptibleMask $ \u -> runDAVT (a $ q u)+ where q u = DAVT . u . runDAVT++instance MonadThrow m => MonadThrow (DAVT m) where+ throwM = lift . throwM+ instance MonadTrans DAVT where lift = DAVT . lift . lift @@ -110,24 +126,17 @@ mkDAVContext u = liftIO $ do mgr <- liftIO $ newManager tlsManagerSettings req <- liftIO $ parseUrl u- return $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"+ return $ def { _baseRequest = req, _httpManager = Just mgr } closeDAVContext :: MonadIO m => DAVContext -> m ()-closeDAVContext ctx = liftIO $ closeManager (ctx ^. httpManager)+closeDAVContext ctx = liftIO $ maybe (return ()) closeManager (ctx ^. httpManager) -withDAVContext :: (MonadIO m, MonadBaseControl IO m) => DAVURL -> (DAVContext -> m a) -> m a+withDAVContext :: (MonadIO m, MonadMask 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- x <- f- case x of- Left e -> error e- Right r -> return r- setCreds :: MonadIO m => B.ByteString -> B.ByteString -> DAVT m () setCreds u p = basicusername .= u >> basicpassword .= p @@ -158,7 +167,7 @@ where go req = do ctx <- get- liftIO (httpLbs req (ctx ^. httpManager))+ maybe (DAVT $ left "Can't perform request without manager") (liftIO . httpLbs req) (ctx ^. httpManager) matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _)@@ -221,7 +230,7 @@ withContentM handleresponse = do req <- mkDavRequest "GET" [] emptyBody ctx <- get- liftIO $ withResponse req (ctx ^. httpManager) handleresponse+ maybe (DAVT $ left "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.@@ -254,7 +263,7 @@ _ <- davRequest "MKCOL" [] emptyBody return () -mkCol :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => DAVT m Bool+mkCol :: (MonadIO m, MonadBase IO m, MonadCatch m) => DAVT m Bool mkCol = catchJust (matchStatusCodeException conflict409) (mkCol' >> return True)@@ -302,14 +311,14 @@ getOptionsOnce :: MonadIO m => DAVT m () getOptionsOnce = getOptions -- this should only happen once -withLockIfPossible :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => Bool -> DAVT m a -> DAVT m a+withLockIfPossible :: (MonadIO m, MonadBase IO m, MonadCatch m, MonadMask m) => Bool -> DAVT m a -> DAVT m a withLockIfPossible nocreate f = do getOptionsOnce o <- get when (supportsLocking o) (lockResource nocreate) f `finally` when (supportsLocking o) unlockResource -withLockIfPossibleForDelete :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => Bool -> DAVT m a -> DAVT m a+withLockIfPossibleForDelete :: (MonadIO m, MonadBase IO m, MonadCatch m, MonadMask m) => Bool -> DAVT m a -> DAVT m a withLockIfPossibleForDelete nocreate f = do getOptionsOnce o <- get@@ -318,63 +327,6 @@ let unlock = when (supportsLocking o) unlockResource bracketOnError lock (const unlock) (const f) -{-# DEPRECATED getProps "This function will be removed in favor of getPropsM" #-}-getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document-getProps url username password md = choke $ evalDAVT url $ do- setCreds username password- setDepth md- getPropsM--{-# DEPRECATED getPropsAndContent "This function will be removed in favor of getPropsM and getContentM" #-}-getPropsAndContent :: String -> B.ByteString -> B.ByteString -> IO (XML.Document, (Maybe B.ByteString, BL.ByteString))-getPropsAndContent url username password = choke $ evalDAVT url $ do- setCreds username password- setDepth (Just Depth0)- withLockIfPossible True $ liftM2 (,) getPropsM getContentM--{-# DEPRECATED putContent "This function will be removed in favor of putContentM" #-}-putContent :: String -> B.ByteString -> B.ByteString -> (Maybe B.ByteString, BL.ByteString) -> IO ()-putContent url username password b = choke $ evalDAVT url $ do- setCreds username password- withLockIfPossible False $ putContentM b--{-# DEPRECATED putContentAndProps "This function will be removed in favor of putContentM and putPropsM" #-}-putContentAndProps :: String -> B.ByteString -> B.ByteString -> (XML.Document, (Maybe B.ByteString, BL.ByteString)) -> IO ()-putContentAndProps url username password (p, b) = choke $ evalDAVT url $ do- setCreds username password- withLockIfPossible False $ do putContentM b- putPropsM p--{-# DEPRECATED deleteContent "This function will be removed in favor of delContentM" #-}-deleteContent :: String -> B.ByteString -> B.ByteString -> IO ()-deleteContent url username password = choke $ evalDAVT url $ do- setCreds username password- withLockIfPossibleForDelete False delContentM--{-# DEPRECATED moveContent "This function will be removed in favor of moveContentM" #-}-moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO ()-moveContent url newurl username password = choke $ evalDAVT url $ do- setCreds username password- moveContentM newurl--{-# DEPRECATED caldavReport "This function will be removed in favor of caldavReportM" #-}-caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document-caldavReport url username password = choke $ evalDAVT url $ do- setCreds username password- setDepth (Just Depth1)- caldavReportM---- | Creates a WebDAV collection, which is similar to a directory.------ Returns False if the collection could not be made due to an intermediate--- collection not existing. (Ie, collection /a/b/c/d cannot be made until--- collection /a/b/c exists.)-{-# DEPRECATED makeCollection "This function will be removed in favor of mkCol" #-}-makeCollection :: String -> B.ByteString -> B.ByteString -> IO Bool-makeCollection url username password = choke $ evalDAVT url $ do- setCreds username password- mkCol- propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root [] where@@ -403,3 +355,39 @@ <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+ r' = r { path = adjustpath r }+ ctx' = baseRequest .~ r' $ ctx+ 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)
Network/Protocol/HTTP/DAV/TH.hs view
@@ -43,7 +43,7 @@ , _basicpassword :: B.ByteString , _complianceClasses :: [B.ByteString] , _depth :: Maybe Depth- , _httpManager :: Manager+ , _httpManager :: Maybe Manager , _lockToken :: Maybe B.ByteString , _userAgent :: B.ByteString }