-- DAV.hs: WebDAV client library -- Copyright © 2012-2013 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 -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts, QuasiQuotes #-} module Network.Protocol.HTTP.DAV ( DAVState , DAVContext(..) , getProps , getPropsAndContent , putContentAndProps , putContent , deleteContent , moveContent , makeCollection , caldavReport , module Network.Protocol.HTTP.DAV.TH ) where import Network.Protocol.HTTP.DAV.TH import Control.Applicative (liftA2) 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 qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, closeManager, ManagerSettings(..), HttpException(..)) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409) import qualified Text.XML as XML import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName) import Text.Hamlet.XML (xml) import Data.CaseInsensitive (mk) type DAVState m a = StateT DAVContext (ResourceT m) a 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 closeDS :: DAVContext -> IO () closeDS = closeManager . _httpManager 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 davRequest :: MonadResourceBase m => Method -> RequestHeaders -> RequestBody -> DAVState m (Response BL.ByteString) davRequest meth addlhdrs rbody = do ctx <- get let hdrs = catMaybes [ Just (mk "User-Agent", (BC8.pack ("hDav-using application"))) , 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 matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _) | s == want = Just () | otherwise = Nothing matchStatusCodeException _ _ = Nothing emptyBody :: RequestBody emptyBody = RequestBodyLBS BL.empty xmlBody :: XML.Document -> RequestBody xmlBody = RequestBodyLBS . XML.renderLBS XML.def getOptions :: MonadResourceBase m => DAVState 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) lockResource :: MonadResourceBase m => Bool -> DAVState 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) unlockResource :: MonadResourceBase m => DAVState 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) supportsLocking :: DAVContext -> Bool supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods supportsCalDAV :: DAVContext -> Bool supportsCalDAV = ("calendar-access" `elem`) . _complianceClasses getPropsM :: MonadResourceBase m => DAVState 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 = do resp <- davRequest "GET" [] emptyBody let ct = lookup (hContentType) (responseHeaders resp) return $ (ct, responseBody resp) putContentM :: MonadResourceBase m => (Maybe B.ByteString, BL.ByteString) -> DAVState 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) _ <- davRequest "PUT" ahs (RequestBodyLBS body) return () delContentM :: MonadResourceBase m => DAVState m () delContentM = do _ <- davRequest "DELETE" [] emptyBody return () moveContentM :: MonadResourceBase m => B.ByteString -> DAVState m () moveContentM 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, ")"] putPropsM :: MonadResourceBase m => XML.Document -> DAVState 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)) _ <- davRequest "PROPPATCH" ahs ((RequestBodyLBS . props2patch) props) -- FIXME: should diff and remove props from target return () 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 blacklist)) patch prop = XML.Document (XML.Prologue [] Nothing []) (root prop) [] root [] = propertyupdate [] root prop = propertyupdate [ XML.NodeElement $ XML.Element "D:set" Map.empty [ XML.NodeElement $ XML.Element "D:prop" Map.empty prop ] ] propertyupdate = XML.Element "D:propertyupdate" (Map.fromList [("xmlns:D", "DAV:")]) blacklist = [ "{DAV:}creationdate" , "{DAV:}displayname" , "{DAV:}getcontentlength" , "{DAV:}getcontenttype" , "{DAV:}getetag" , "{DAV:}getlastmodified" , "{DAV:}lockdiscovery" , "{DAV:}resourcetype" , "{DAV:}supportedlock" ] caldavReportM :: MonadResourceBase m => DAVState 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 getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document getProps url username password md = withDS url username password md getPropsM 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) 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) 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) 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) moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO () moveContent url newurl username password = withDS url username password Nothing $ moveContentM newurl caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document caldavReport url username password = withDS url username password (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.) 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) propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root [] where 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" (Map.fromList [("xmlns:D", "DAV:")]) [xml| Haskell DAV user |] calendarquery :: XML.Document calendarquery = XML.Document (XML.Prologue [] Nothing []) root [] where root = XML.Element "C:calendar-query" (Map.fromList [("xmlns:D", "DAV:"),("xmlns:C", "urn:ietf:params:xml:ns:caldav")]) [xml| |]