DAV 0.1 → 0.2

raw patch · 4 files changed

+110/−7 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• AUTHORS +2/−0
• DAV.cabal +12/−1
• Network/Protocol/HTTP/DAV.hs +40/−5
• hdav.hs +56/−1

@@ -0,0 +1,2 @@+Clint Adams <clint@gnu.org>+Joey Hess <joey@kitenet.net>

@@ -1,5 +1,5 @@ name:                DAV-version:             0.1+version:             0.2 synopsis:            RFC 4918 WebDAV support description:    This is a library for the Web Distributed Authoring and Versioning@@ -19,6 +19,7 @@ category:            Web build-type:          Simple cabal-version:       >=1.8+extra-source-files:  AUTHORS  library   exposed-modules:  Network.Protocol.HTTP.DAV@@ -56,3 +57,13 @@                      , transformers >= 0.3                      , xml-conduit >= 1.0          && <= 1.1                      , xml-hamlet >= 0.4           && <= 0.5++source-repository head+  type:     git+  location: git://anonscm.debian.org/users/clint/DAV.git+  branch:   master++source-repository this+  type:     git+  location: git://anonscm.debian.org/users/clint/DAV.git+  tag:      DAV/0.2

@@ -21,9 +21,12 @@ module Network.Protocol.HTTP.DAV (     DAVState   , DAVContext(..)+  , getProps   , getPropsAndContent   , putContentAndProps   , deleteContent+  , moveContent+  , makeCollection   , module Network.Protocol.HTTP.DAV.TH ) where @@ -44,7 +47,7 @@ import Data.Maybe (fromMaybe)  import Network.HTTP.Conduit (httpLbs, parseUrl, applyBasicAuth, Request(..), RequestBody(..), Response(..), newManager, closeManager, ManagerSettings(..), def, HttpException(..))-import Network.HTTP.Types (hContentType, Method, RequestHeaders, unauthorized401)+import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409)  import qualified Text.XML as XML import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName)@@ -73,14 +76,16 @@     ctx <- get     let req = (ctx ^. baseRequest) { method = meth, requestHeaders = (mk "User-Agent", "hDav 9.0"):addlhdrs, requestBody = rbody }     let authreq = applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req-    resp <- lift (catchJust (is401Exception)+    resp <- lift (catchJust (matchStatusCodeException unauthorized401)                             (httpLbs req (ctx ^. httpManager))                             (\_ -> httpLbs authreq (ctx ^. httpManager)))     return resp -is401Exception :: HttpException -> Maybe ()-is401Exception (StatusCodeException s _) = if s == unauthorized401 then Just () else Nothing-is401Exception _ = Nothing+matchStatusCodeException :: Status -> HttpException -> Maybe ()+matchStatusCodeException want (StatusCodeException s _)+    | s == want = Just ()+    | otherwise = Nothing+matchStatusCodeException _ _ = Nothing  emptyBody :: RequestBody m emptyBody = RequestBodyLBS BL.empty@@ -141,6 +146,17 @@     _ <- davRequest "DELETE" [] emptyBody     return () +mvContent :: MonadResourceBase m => B.ByteString -> DAVState m ()+mvContent newurl = do+    let ahs = [ (mk "Destination", newurl) ]+    _ <- davRequest "MOVE" ahs emptyBody+    return ()++mkCol :: MonadResourceBase m => DAVState m ()+mkCol = do+    _ <- davRequest "MKCOL" [] emptyBody+    return ()+ parenthesize :: B.ByteString -> B.ByteString parenthesize x = B.concat ["(", x, ")"] @@ -174,6 +190,9 @@                    , "{DAV:}supportedlock"                    ] +getProps :: String -> B.ByteString -> B.ByteString -> IO XML.Document+getProps url username password = withDS url username password getAllProps+ getPropsAndContent :: String -> B.ByteString -> B.ByteString -> IO (XML.Document, (Maybe B.ByteString, BL.ByteString)) getPropsAndContent url username password = withDS url username password $ do     getOptions@@ -199,6 +218,22 @@     -- a successful delete destroys locks, so only unlock on error     let unlock = when (supportsLocking o) (unlockResource)     bracketOnError lock (\_ -> unlock) (\_ -> delContent)++moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO ()+moveContent url newurl username password = withDS url username password $+    mvContent newurl++-- | 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.)+makeCollection :: String -> B.ByteString -> B.ByteString -> IO Bool+makeCollection url username password = withDS url username password $+    catchJust+        (matchStatusCodeException conflict409)+        (mkCol >> return True)+        (\_ -> return False)  propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root []

@@ -21,12 +21,17 @@ import Paths_DAV (version) import Data.Version (showVersion) import Data.Maybe (fromMaybe, fromJust)+import Control.Monad (unless)+import Text.XML (renderLBS, def)+import qualified Data.ByteString.Lazy.Char8 as B  import Network (withSocketsDo) +import Network.URI (normalizePathSegments)+ import qualified System.Console.CmdArgs.Explicit as CA -import Network.Protocol.HTTP.DAV (getPropsAndContent, putContentAndProps, deleteContent)+import Network.Protocol.HTTP.DAV (getProps, getPropsAndContent, putContentAndProps, deleteContent, moveContent, makeCollection)  doCopy :: [(String, String)] -> IO () doCopy as = do@@ -46,10 +51,48 @@      let password = BC8.pack . fromMaybe "" . lookup "password" $ as      deleteContent url username password +doMove :: [(String, String)] -> IO ()+doMove as = do+     let url1 = fromJust . lookup "sourceurl" $ as+     let url2 = fromJust . lookup "targeturl" $ as+     let username = BC8.pack . fromMaybe "" . lookup "username" $ as+     let password = BC8.pack . fromMaybe "" . lookup "password" $ as+     moveContent url1 (BC8.pack url2) username password++doMakeCollection :: [(String, String)] -> IO ()+doMakeCollection as = do+     let url = fromJust . lookup "url" $ as+     go url+  where+     username = BC8.pack . fromMaybe "" . lookup "username" $ as+     password = BC8.pack . fromMaybe "" . lookup "password" $ as++     go url = do+       ok <- makeCollection url username password+       unless ok $ do+         go (parent url)+         ok' <- makeCollection url username password+         unless ok' $+           error $ "failed creating " ++ url++     parent url = reverse $ dropWhile (== '/')$ reverse $+        normalizePathSegments (url ++ "/..")++doGetProps :: [(String, String)] -> IO ()+doGetProps as = do+     let url = fromJust . lookup "url" $ as+     let username = BC8.pack . fromMaybe "" . lookup "username" $ as+     let password = BC8.pack . fromMaybe "" . lookup "password" $ as+     doc <- getProps url username password+     B.putStrLn (renderLBS def doc)+ dispatch :: String -> [(String, String)] -> IO () dispatch m as     | m == "copy" = doCopy as+    | m == "move" = doMove as     | m == "delete" = doDelete as+    | m == "makecollection" = doMakeCollection as+    | m == "getprops" = doGetProps as     | otherwise = fail "Unexpected condition."  showHelp :: IO ()@@ -77,7 +120,19 @@ 		, CA.flagReq ["target-username"] (upd "target-username") "USERNAME" "username for target URL" 		, CA.flagReq ["target-password"] (upd "target-password") "PASSWORD" "password for target URL" 		, CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "sourceurl") "SOURCEURL") { CA.argRequire = True }, (CA.flagArg (upd "targeturl") "TARGETURL") { CA.argRequire = True }], Nothing) }+              , (CA.mode "move" [("mode", "move")] "move" (CA.flagArg (upd "sourceurl") "SOURCEURL") [+	          CA.flagReq ["username"] (upd "username") "USERNAME" "username for source and target URL"+		, CA.flagReq ["password"] (upd "password") "PASSWORD" "password for source and target URL"+		, CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "sourceurl") "SOURCEURL") { CA.argRequire = True }, (CA.flagArg (upd "targeturl") "TARGETURL") { CA.argRequire = True }], Nothing) }               , (CA.mode "delete" [("mode", "delete")] "delete" (CA.flagArg (upd "url") "URL") [+	          CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL"+		, CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL"+		, CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) }+              , (CA.mode "makecollection" [("mode", "makecollection")] "makecollecton" (CA.flagArg (upd "url") "URL") [+	          CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL"+		, CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL"+		, CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) }+              , (CA.mode "getprops" [("mode", "getprops")] "getprops" (CA.flagArg (upd "url") "URL") [ 	          CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL" 		, CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL" 		, CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) }