DAV 0.5.1 → 0.6
raw patch · 4 files changed
+185/−104 lines, 4 filesdep +monad-controldep +transformers-basedep −resourcet
Dependencies added: monad-control, transformers-base
Dependencies removed: resourcet
Files
- DAV.cabal +6/−4
- Network/Protocol/HTTP/DAV.hs +151/−81
- Network/Protocol/HTTP/DAV/TH.hs +4/−3
- hdav.hs +24/−16
DAV.cabal view
@@ -1,5 +1,5 @@ name: DAV-version: 0.5.1+version: 0.6 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning@@ -34,9 +34,10 @@ , http-types >= 0.7 , lens >= 3.0 , lifted-base >= 0.1+ , monad-control , mtl >= 2.1- , resourcet >= 0.3 , transformers >= 0.3+ , transformers-base , xml-conduit >= 1.0 && <= 1.2 , xml-hamlet >= 0.4 && <= 0.5 executable hdav@@ -52,11 +53,12 @@ , http-types >= 0.7 , lens >= 3.0 , lifted-base >= 0.1+ , monad-control , mtl >= 2.1 , network >= 2.3 , optparse-applicative- , resourcet >= 0.3 , transformers >= 0.3+ , transformers-base , xml-conduit >= 1.0 && <= 1.2 , xml-hamlet >= 0.4 && <= 0.5 @@ -68,4 +70,4 @@ source-repository this type: git location: git://anonscm.debian.org/users/clint/DAV.git- tag: DAV/0.5.1+ tag: DAV/0.6
Network/Protocol/HTTP/DAV.hs view
@@ -16,10 +16,18 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts, QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts,+ QuasiQuotes, RankNTypes, GeneralizedNewtypeDeriving,+ FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,+ TypeFamilies #-} module Network.Protocol.HTTP.DAV (- DAVState+ DAVT(..)+ , evalDAVT+ , setCreds+ , setDepth+ , setResponseTimeout+ , setUserAgent , DAVContext(..) , getProps , getPropsAndContent@@ -29,18 +37,32 @@ , moveContent , makeCollection , caldavReport+ , caldavReportM+ , delContentM+ , getPropsM+ , getContentM+ , mkCol+ , moveContentM+ , putPropsM+ , putContentM+ , withLockIfPossible+ , withLockIfPossibleForDelete , module Network.Protocol.HTTP.DAV.TH ) where import Network.Protocol.HTTP.DAV.TH -import Control.Applicative (liftA2)+import Control.Applicative (liftA2, Applicative) import Control.Exception.Lifted (catchJust, finally, bracketOnError)-import Control.Lens ((.~), (^.))-import Control.Monad (when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)-import Control.Monad.Trans.State.Lazy (evalStateT, StateT, get, modify)+import Control.Lens ((^.), (.=), (%=))+import Control.Monad (liftM, liftM2, when, MonadPlus)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Error (ErrorT, MonadError, runErrorT)+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.Trans.Control (MonadBaseControl(..)) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8@@ -49,7 +71,7 @@ import Data.Maybe (catMaybes, fromMaybe) -import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, closeManager, ManagerSettings(..), HttpException(..))+import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, closeManager, HttpException(..)) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409) @@ -59,35 +81,56 @@ import Data.CaseInsensitive (mk) -type DAVState m a = StateT DAVContext (ResourceT m) a+newtype DAVT m a = DAVT { runDAVT :: ErrorT String (StateT DAVContext m) a }+ deriving (Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext) -initialDS :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> ManagerSettings -> IO DAVContext-initialDS u username password md s = do- mgr <- newManager s- req <- parseUrl u- return $ DAVContext [] req [] mgr Nothing username password md+instance MonadBaseControl b m => MonadBaseControl b (DAVT m) where+ newtype StM (DAVT m) a = StDAVT { unStDAVT :: StM (ErrorT String (StateT DAVContext m)) a }+ liftBaseWith f = DAVT . liftBaseWith $ \r -> f $ liftM StDAVT . r . runDAVT+ restoreM = DAVT . restoreM . unStDAVT -closeDS :: DAVContext -> IO ()-closeDS = closeManager . _httpManager+instance MonadTrans DAVT where+ lift = DAVT . lift . lift -withDS :: MonadResourceBase m => String -> B.ByteString -> B.ByteString -> Maybe Depth -> DAVState m a -> m a-withDS url username password md f = runResourceT $ do- (_, ds) <- allocate (initialDS url username password md tlsManagerSettings) closeDS- evalStateT f ds+evalDAVT :: MonadIO m => String -> DAVT m a -> m (Either String a)+evalDAVT u f = do+ mgr <- liftIO $ newManager tlsManagerSettings+ req <- liftIO $ parseUrl u+ r <- (evalStateT . runErrorT . runDAVT) f $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"+ liftIO $ closeManager mgr+ return r -davRequest :: MonadResourceBase m => Method -> RequestHeaders -> RequestBody -> DAVState m (Response BL.ByteString)+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++setDepth :: MonadIO m => Maybe Depth -> DAVT m ()+setDepth d = depth .= d++setUserAgent :: MonadIO m => B.ByteString -> DAVT m ()+setUserAgent ua = userAgent .= ua++setResponseTimeout :: MonadIO m => Maybe Int -> DAVT m ()+setResponseTimeout rt = baseRequest %= \x -> x { responseTimeout = rt }++davRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m (Response BL.ByteString) davRequest meth addlhdrs rbody = do ctx <- get let hdrs = catMaybes- [ Just (mk "User-Agent", (BC8.pack ("hDav-using application")))+ [ Just (mk "User-Agent", ctx ^. userAgent) , fmap ((,) (mk "Depth") . BC8.pack . show) (ctx ^. depth) ] ++ addlhdrs req = (ctx ^. baseRequest) { method = meth, requestHeaders = hdrs, requestBody = rbody } authreq = applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req- resp <- liftIO (catchJust (matchStatusCodeException unauthorized401)- (httpLbs req (ctx ^. httpManager))- (\_ -> httpLbs authreq (ctx ^. httpManager)))- return resp+ liftIO (catchJust (matchStatusCodeException unauthorized401)+ (httpLbs req (ctx ^. httpManager))+ (\_ -> httpLbs authreq (ctx ^. httpManager))) matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _)@@ -101,30 +144,30 @@ xmlBody :: XML.Document -> RequestBody xmlBody = RequestBodyLBS . XML.renderLBS XML.def -getOptions :: MonadResourceBase m => DAVState m ()+getOptions :: MonadIO m => DAVT m () getOptions = do optresp <- davRequest "OPTIONS" [] emptyBody let meths = (B.splitWith (==(fromIntegral . fromEnum) ',') . fromMaybe B.empty . lookup "Allow" . responseHeaders) optresp let cclass = (B.splitWith (==(fromIntegral . fromEnum) ',') . fromMaybe B.empty . lookup "DAV" . responseHeaders) optresp- modify (complianceClasses .~ cclass)- modify (allowedMethods .~ meths)+ complianceClasses .= cclass+ allowedMethods .= meths -lockResource :: MonadResourceBase m => Bool -> DAVState m ()+lockResource :: MonadIO m => Bool -> DAVT m () lockResource nocreate = do let ahs' = [(hContentType, "application/xml; charset=\"utf-8\""), (mk "Depth", "0"), (mk "Timeout", "Second-300")] let ahs = if nocreate then (mk "If-Match", "*"):ahs' else ahs' lockresp <- davRequest "LOCK" ahs (xmlBody locky) let hdrtoken = (lookup "Lock-Token" . responseHeaders) lockresp- modify (lockToken .~ hdrtoken)+ lockToken .= hdrtoken -unlockResource :: MonadResourceBase m => DAVState m ()+unlockResource :: MonadIO m => DAVT m () unlockResource = do d <- get case _lockToken d of Nothing -> return () Just tok -> do let ahs = [(mk "Lock-Token", tok)] _ <- davRequest "UNLOCK" ahs emptyBody- modify (lockToken .~ Nothing)+ lockToken .= Nothing supportsLocking :: DAVContext -> Bool supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods@@ -132,50 +175,56 @@ supportsCalDAV :: DAVContext -> Bool supportsCalDAV = ("calendar-access" `elem`) . _complianceClasses -getPropsM :: MonadResourceBase m => DAVState m XML.Document+getPropsM :: MonadIO m => DAVT m XML.Document getPropsM = do let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] propresp <- davRequest "PROPFIND" ahs (xmlBody propname) return $ (XML.parseLBS_ XML.def . responseBody) propresp -getContentM :: MonadResourceBase m => DAVState m (Maybe B.ByteString, BL.ByteString)+getContentM :: MonadIO m => DAVT m (Maybe B.ByteString, BL.ByteString) getContentM = do resp <- davRequest "GET" [] emptyBody- let ct = lookup (hContentType) (responseHeaders resp)- return $ (ct, responseBody resp)+ let ct = lookup hContentType (responseHeaders resp)+ return (ct, responseBody resp) -putContentM :: MonadResourceBase m => (Maybe B.ByteString, BL.ByteString) -> DAVState m ()+putContentM :: MonadIO m => (Maybe B.ByteString, BL.ByteString) -> DAVT m () putContentM (ct, body) = do d <- get- let ahs' = fromMaybe [] (fmap (return . (,) (mk "If") . parenthesize) (d ^. lockToken))- let ahs = ahs' ++ fromMaybe [] (fmap (return . (,) (hContentType)) ct)+ let ahs' = maybe [] (return . (,) (mk "If") . parenthesize) (d ^. lockToken)+ let ahs = ahs' ++ maybe [] (return . (,) hContentType) ct _ <- davRequest "PUT" ahs (RequestBodyLBS body) return () -delContentM :: MonadResourceBase m => DAVState m ()+delContentM :: MonadIO m => DAVT m () delContentM = do _ <- davRequest "DELETE" [] emptyBody return () -moveContentM :: MonadResourceBase m => B.ByteString -> DAVState m ()+moveContentM :: MonadIO m => B.ByteString -> DAVT m () moveContentM newurl = do let ahs = [ (mk "Destination", newurl) ] _ <- davRequest "MOVE" ahs emptyBody return () -mkCol :: MonadResourceBase m => DAVState m ()-mkCol = do+mkCol' :: MonadIO m => DAVT m ()+mkCol' = do _ <- davRequest "MKCOL" [] emptyBody return () +mkCol :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => DAVT m Bool+mkCol = catchJust+ (matchStatusCodeException conflict409)+ (mkCol' >> return True)+ (\_ -> return False)+ parenthesize :: B.ByteString -> B.ByteString parenthesize x = B.concat ["(", x, ")"] -putPropsM :: MonadResourceBase m => XML.Document -> DAVState m ()+putPropsM :: MonadIO m => XML.Document -> DAVT m () putPropsM props = do d <- get let ah' = (hContentType, "application/xml; charset=\"utf-8\"")- let ahs = ah':fromMaybe [] (fmap (return . (,) (mk "If") . parenthesize) (_lockToken d))+ let ahs = ah':maybe [] (return . (,) (mk "If") . parenthesize) (_lockToken d) _ <- davRequest "PROPPATCH" ahs ((RequestBodyLBS . props2patch) props) -- FIXME: should diff and remove props from target return () @@ -201,66 +250,87 @@ , "{DAV:}supportedlock" ] -caldavReportM :: MonadResourceBase m => DAVState m XML.Document+caldavReportM :: MonadIO m => DAVT m XML.Document caldavReportM = do let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] calrresp <- davRequest "REPORT" ahs (xmlBody calendarquery) return $ (XML.parseLBS_ XML.def . responseBody) calrresp +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 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 nocreate f = do+ getOptionsOnce+ o <- get+ let lock = when (supportsLocking o) (lockResource nocreate)+ -- a successful delete destroys locks, so only unlock on error+ 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 = withDS url username password md getPropsM+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 = withDS url username password (Just Depth0) $ do- getOptions- o <- get- when (supportsLocking o) (lockResource True)- (do props <- getPropsM- body <- getContentM- return (props, body)) `finally` when (supportsLocking o) (unlockResource)+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 = withDS url username password Nothing $ do- getOptions- o <- get- when (supportsLocking o) (lockResource False)- putContentM b `finally` when (supportsLocking o) (unlockResource)+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) = withDS url username password Nothing $ do- getOptions- o <- get- when (supportsLocking o) (lockResource False)- (do putContentM b- putPropsM p) `finally` when (supportsLocking o) (unlockResource)+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 = withDS url username password Nothing $ do- getOptions- o <- get- let lock = when (supportsLocking o) (lockResource False)- -- a successful delete destroys locks, so only unlock on error- let unlock = when (supportsLocking o) (unlockResource)- bracketOnError lock (\_ -> unlock) (\_ -> delContentM)+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 = withDS url username password Nothing $+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 = withDS url username password (Just Depth1) $ caldavReportM+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 = withDS url username password Nothing $- catchJust- (matchStatusCodeException conflict409)- (mkCol >> return True)- (\_ -> return False)+makeCollection url username password = choke $ evalDAVT url $ do+ setCreds username password+ mkCol propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root []
Network/Protocol/HTTP/DAV/TH.hs view
@@ -39,11 +39,12 @@ data DAVContext = DAVContext { _allowedMethods :: [B.ByteString] , _baseRequest :: Request- , _complianceClasses :: [B.ByteString]- , _httpManager :: Manager- , _lockToken :: Maybe B.ByteString , _basicusername :: B.ByteString , _basicpassword :: B.ByteString+ , _complianceClasses :: [B.ByteString] , _depth :: Maybe Depth+ , _httpManager :: Manager+ , _lockToken :: Maybe B.ByteString+ , _userAgent :: B.ByteString } makeLenses ''DAVContext
hdav.hs view
@@ -20,7 +20,8 @@ import Paths_DAV (version) import Control.Applicative ((<$>),(<*>), optional, pure)-import Control.Monad (unless)+import Control.Monad (liftM2, unless)+import Control.Monad.IO.Class (MonadIO) import Data.Version (showVersion) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))@@ -31,7 +32,7 @@ import Network.URI (normalizePathSegments) -import Network.Protocol.HTTP.DAV (getProps, getPropsAndContent, putContent, putContentAndProps, deleteContent, moveContent, makeCollection, Depth(..), caldavReport)+import Network.Protocol.HTTP.DAV (DAVT, evalDAVT, setCreds, setDepth, setUserAgent, getPropsM, getContentM, putContentM, putPropsM, delContentM, moveContentM, mkCol, Depth(..), caldavReportM, withLockIfPossible, withLockIfPossibleForDelete) import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, option, progDesc, str, strOption, subparser) import Options.Applicative.Extra (execParser)@@ -101,8 +102,8 @@ doCopy :: Options -> IO () doCopy o = do- (p, b) <- getPropsAndContent sourceurl sourceUsername sourcePassword- putContentAndProps targeturl targetUsername targetPassword (p, b)+ (p, b) <- runDAV sourceurl $ setCreds sourceUsername sourcePassword >> setDepth (Just Depth0) >> withLockIfPossible True (liftM2 (,) getPropsM getContentM)+ runDAV targeturl $ setCreds targetUsername targetPassword >> withLockIfPossible False (putContentM b >> putPropsM p) where sourceurl = url o targeturl = url2 o@@ -112,10 +113,10 @@ targetPassword = BC8.pack $ password2 o doDelete :: Options -> IO ()-doDelete o = deleteContent (url o) (BC8.pack $ username o) (BC8.pack $ password o)+doDelete o = runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> withLockIfPossibleForDelete False delContentM doMove :: Options -> IO ()-doMove o = moveContent (url o) (BC8.pack $ url2 o) (BC8.pack $ username o) (BC8.pack $ password o)+doMove o = runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> moveContentM (BC8.pack $ url2 o) doMakeCollection :: Options -> IO () doMakeCollection o = go (url o)@@ -123,30 +124,32 @@ u = BC8.pack . username $ o p = BC8.pack . password $ o - go url = do- ok <- makeCollection url u p+ go url' = do+ ok <- makeCollection url' unless ok $ do- go (parent url)- ok' <- makeCollection url u p+ go (parent url')+ ok' <- makeCollection url' unless ok' $- error $ "failed creating " ++ url+ error $ "failed creating " ++ url' - parent url = reverse $ dropWhile (== '/')$ reverse $- normalizePathSegments (url ++ "/..")+ parent url' = reverse $ dropWhile (== '/')$ reverse $+ normalizePathSegments (url' ++ "/..") + makeCollection url' = runDAV url' $ setCreds u p >> mkCol+ doGetProps :: Options -> Maybe Depth -> IO () doGetProps o md = do- doc <- getProps (url o) (BC8.pack $ username o) (BC8.pack $ password o) md+ doc <- runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> setDepth md >> getPropsM B.putStrLn (renderLBS def doc) doPut :: FilePath -> Options -> IO () doPut file o = do bs <- B.readFile file- putContent (url o) (BC8.pack $ username o) (BC8.pack $ password o) (Nothing, bs)+ runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> putContentM (Nothing, bs) doReport :: Options -> IO () doReport o = do- doc <- caldavReport (url o) (BC8.pack $ username o) (BC8.pack $ password o)+ doc <- runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> setDepth (Just Depth1) >> caldavReportM B.putStrLn (renderLBS def doc) dispatch :: Command -> IO ()@@ -178,3 +181,8 @@ <> command "caldav-report" (info ( CaldavReport <$> oneUUP ) ( progDesc "Get CalDAV report" )) )++runDAV :: MonadIO m => String -> DAVT m a -> m a+runDAV u f = evalDAVT u (setUserAgent (BC8.pack $ "hDAV/" ++ showVersion version) >> f) >>= \x -> case x of+ Left e -> error e+ Right r -> return r