DAV 0.0 → 0.0.1
raw patch · 4 files changed
+41/−23 lines, 4 filesdep +containersdep ~basedep ~lensdep ~xml-conduit
Dependencies added: containers
Dependency ranges changed: base, lens, xml-conduit, xml-hamlet
Files
- DAV.cabal +12/−9
- Network/Protocol/HTTP/DAV.hs +25/−12
- Network/Protocol/HTTP/DAV/TH.hs +2/−0
- hdav.hs +2/−2
DAV.cabal view
@@ -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
Network/Protocol/HTTP/DAV.hs view
@@ -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| <D:allprop> |] 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| <D:lockscope> <D:exclusive> <D:locktype>
Network/Protocol/HTTP/DAV/TH.hs view
@@ -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
hdav.hs view
@@ -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