diff --git a/DAV.cabal b/DAV.cabal --- a/DAV.cabal +++ b/DAV.cabal @@ -1,5 +1,5 @@ name: DAV -version: 0.0 +version: 0.0.1 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning @@ -24,32 +24,35 @@ exposed-modules: Network.Protocol.HTTP.DAV other-modules: Network.Protocol.HTTP.DAV.TH ghc-options: -Wall - build-depends: base ==4.5.* + build-depends: base >= 4.5 && <= 5 , bytestring , case-insensitive >= 0.4 + , containers , http-conduit >= 1.4 , http-types >= 0.6 - , lens >= 2.4 + , lens >= 3.0 , lifted-base >= 0.1 , mtl >= 2.1 , resourcet >= 0.3 , transformers >= 0.3 - , xml-conduit >= 0.7 && <= 0.7.0.3 - , xml-hamlet >= 0.3 && <= 0.3.0.1 + , xml-conduit >= 1.0 && <= 1.1 + , xml-hamlet >= 0.4 && <= 0.5 executable hdav main-is: hdav.hs ghc-options: -Wall - build-depends: base ==4.5.* + build-depends: base >= 4.5 && <= 5 , bytestring + , bytestring , case-insensitive >= 0.4 , cmdargs >= 0.9 + , containers , http-conduit >= 1.4 , http-types >= 0.6 - , lens >= 2.4 + , lens >= 3.0 , lifted-base >= 0.1 , mtl >= 2.1 , network >= 2.3 , resourcet >= 0.3 , transformers >= 0.3 - , xml-conduit >= 0.7 && <= 0.7.0.3 - , xml-hamlet >= 0.3 && <= 0.3.0.1 + , xml-conduit >= 1.0 && <= 1.1 + , xml-hamlet >= 0.4 && <= 0.5 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 @@ -1,6 +1,8 @@ -- DAV.hs: WebDAV client library -- Copyright © 2012 Clint Adams -- +-- vim: softtabstop=4:shiftwidth=4:expandtab +-- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or @@ -36,11 +38,12 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Network.HTTP.Conduit (httpLbs, parseUrl, applyBasicAuth, Request(..), RequestBody(..), Response(..), newManager, closeManager, ManagerSettings(..), def, HttpException(..)) -import Network.HTTP.Types (headerContentType, Method, RequestHeaders, unauthorized401) +import Network.HTTP.Types (hContentType, Method, RequestHeaders, unauthorized401) import qualified Text.XML as XML import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName) @@ -94,7 +97,7 @@ lockResource :: MonadResourceBase m => Bool -> DAVState m () lockResource nocreate = do - let ahs' = [headerContentType "application/xml; charset=\"utf-8\"", (mk "Depth", "0"), (mk "Timeout", "Second-300")] + 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 @@ -114,21 +117,21 @@ getAllProps :: MonadResourceBase m => DAVState m XML.Document getAllProps = do - let ahs = [headerContentType "application/xml; charset=\"utf-8\""] + let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] propresp <- davRequest "PROPFIND" ahs (xmlBody propname) return $ (XML.parseLBS_ def . responseBody) propresp getContent :: MonadResourceBase m => DAVState m (Maybe B.ByteString, BL.ByteString) getContent = do resp <- davRequest "GET" [] emptyBody - let ct = lookup (mk "Content-Type") (responseHeaders resp) + let ct = lookup (hContentType) (responseHeaders resp) return $ (ct, responseBody resp) putContent :: MonadResourceBase m => (Maybe B.ByteString, BL.ByteString) -> DAVState m () putContent (ct, body) = do d <- get let ahs' = fromMaybe [] (fmap (return . (,) (mk "If") . parenthesize) (d ^. lockToken)) - let ahs = ahs' ++ fromMaybe [] (fmap (return . (,) (mk "Content-Type")) ct) + let ahs = ahs' ++ fromMaybe [] (fmap (return . (,) (hContentType)) ct) _ <- davRequest "PUT" ahs (RequestBodyLBS body) return () @@ -138,7 +141,7 @@ putProps :: MonadResourceBase m => XML.Document -> DAVState m () putProps props = do d <- get - let ah' = headerContentType "application/xml; charset=\"utf-8\"" + let ah' = (hContentType, "application/xml; charset=\"utf-8\"") let ahs = ah':fromMaybe [] (fmap (return . (,) (mk "If") . parenthesize) (_lockToken d)) _ <- davRequest "PROPPATCH" ahs ((RequestBodyLBS . props2patch) props) -- FIXME: should diff and remove props from target return () @@ -146,12 +149,22 @@ props2patch :: XML.Document -> BL.ByteString props2patch = XML.renderLBS XML.def . patch . props . fromDocument where - props cursor = map node (cursor $/ element "{DAV:}response" &/ element "{DAV:}propstat" &/ element "{DAV:}prop" &/ checkName (not . flip elem ["{DAV:}creationdate", "{DAV:}displayname", "{DAV:}getcontentlength", "{DAV:}getcontenttype", "{DAV:}getetag", "{DAV:}getlastmodified", "{DAV:}lockdiscovery", "{DAV:}resourcetype", "{DAV:}supportedlock"])) + props cursor = map node (cursor $/ element "{DAV:}response" &/ element "{DAV:}propstat" &/ element "{DAV:}prop" &/ checkName (not . flip elem blacklist)) patch prop = XML.Document (XML.Prologue [] Nothing []) (root prop) [] - root prop = XML.Element "D:propertyupdate" [("xmlns:D", "DAV:")] - [ XML.NodeElement $ XML.Element "D:set" [] - [ XML.NodeElement $ XML.Element "D:prop" [] prop ] + root prop = XML.Element "D:propertyupdate" (Map.fromList [("xmlns:D", "DAV:")]) + [ XML.NodeElement $ XML.Element "D:set" Map.empty + [ XML.NodeElement $ XML.Element "D:prop" Map.empty prop ] ] + blacklist = [ "{DAV:}creationdate" + , "{DAV:}displayname" + , "{DAV:}getcontentlength" + , "{DAV:}getcontenttype" + , "{DAV:}getetag" + , "{DAV:}getlastmodified" + , "{DAV:}lockdiscovery" + , "{DAV:}resourcetype" + , "{DAV:}supportedlock" + ] getPropsAndContent :: String -> B.ByteString -> B.ByteString -> IO (XML.Document, (Maybe B.ByteString, BL.ByteString)) getPropsAndContent url username password = withDS url username password $ do @@ -173,14 +186,14 @@ propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root [] where - root = XML.Element "D:propfind" [("xmlns:D", "DAV:")] [xml| + root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) [xml| |] locky :: XML.Document locky = XML.Document (XML.Prologue [] Nothing []) root [] where - root = XML.Element "D:lockinfo" [("xmlns:D", "DAV:")] [xml| + root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml| diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs --- a/Network/Protocol/HTTP/DAV/TH.hs +++ b/Network/Protocol/HTTP/DAV/TH.hs @@ -1,6 +1,8 @@ -- TH.hs: WebDAV client library - bits using TH -- Copyright © 2012 Clint Adams -- +-- vim: softtabstop=4:shiftwidth=4:expandtab +-- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or diff --git a/hdav.hs b/hdav.hs --- a/hdav.hs +++ b/hdav.hs @@ -1,6 +1,8 @@ -- hdav.hs: WebDAV client -- Copyright © 2012 Clint Adams -- +-- vim: softtabstop=4:shiftwidth=4:expandtab +-- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or @@ -67,5 +69,3 @@ , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "sourceurl") "SOURCEURL") { CA.argRequire = True }, (CA.flagArg (upd "targeturl") "TARGETURL") { CA.argRequire = True }], Nothing) } ] where upd msg x v = Right $ (msg,x):v - --- vim: set softtabstop=4 shiftwidth=4 expandtab