module Network.Protocol.HTTP.DAV (
DAVState
, DAVContext(..)
, getProps
, getPropsAndContent
, putContentAndProps
, putContent
, deleteContent
, moveContent
, makeCollection
, caldavReport
, module Network.Protocol.HTTP.DAV.TH
) where
import Paths_DAV (version)
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.Trans (lift)
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 Data.Version (showVersion)
import Network.HTTP.Conduit (httpLbs, parseUrl, applyBasicAuth, Request(..), RequestBody(..), Response(..), newManager, closeManager, ManagerSettings(..), def, HttpException(..))
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 m) (ResourceT m) a
initialDS :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> ManagerSettings -> IO (DAVContext a)
initialDS u username password md s = do
mgr <- newManager s
req <- parseUrl u
return $ DAVContext [] req [] mgr Nothing username password md
closeDS :: DAVContext a -> 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 def) closeDS
evalStateT f ds
davRequest :: MonadResourceBase m => Method -> RequestHeaders -> RequestBody (ResourceT m) -> DAVState m (Response BL.ByteString)
davRequest meth addlhdrs rbody = do
ctx <- get
let hdrs = catMaybes
[ Just (mk "User-Agent", (BC8.pack ("hDav " ++ showVersion version)))
, 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 <- lift (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 m
emptyBody = RequestBodyLBS BL.empty
xmlBody :: XML.Document -> RequestBody m
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 a -> Bool
supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods
supportsCalDAV :: DAVContext a -> 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_ 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)
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_ 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)
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
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|
<D:allprop>
|]
locky :: XML.Document
locky = XML.Document (XML.Prologue [] Nothing []) root []
where
root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml|
<D:lockscope>
<D:exclusive>
<D:locktype>
<D:write>
<D:owner>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|
<D:prop>
<D:getetag>
<C:calendardata>
<C:filter>
<C:compfilter name="VCALENDAR">
|]