diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Clint Adams +Joey Hess diff --git a/DAV.cabal b/DAV.cabal --- a/DAV.cabal +++ b/DAV.cabal @@ -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 diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs --- a/Network/Protocol/HTTP/DAV.hs +++ b/Network/Protocol/HTTP/DAV.hs @@ -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 [] diff --git a/hdav.hs b/hdav.hs --- a/hdav.hs +++ b/hdav.hs @@ -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) }