module Network.Protocol.HTTP.DAV (
DAVT(..)
, evalDAVT
, setCreds
, setDepth
, setResponseTimeout
, setUserAgent
, DAVContext(..)
, getProps
, getPropsAndContent
, putContentAndProps
, putContent
, deleteContent
, moveContent
, makeCollection
, caldavReport
, caldavReportM
, delContentM
, getPropsM
, getContentM
, mkCol
, moveContentM
, putPropsM
, putContentM
, withLockIfPossible
, withLockIfPossibleForDelete
, module Network.Protocol.HTTP.DAV.TH
) where
import Network.Protocol.HTTP.DAV.TH
import Control.Applicative (liftA2, Applicative)
import Control.Exception.Lifted (catchJust, finally, bracketOnError)
import Control.Lens ((^.), (.=), (%=))
import Control.Monad (liftM, liftM2, when, MonadPlus)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Error (ErrorT, MonadError, runErrorT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans (lift, MonadTrans)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.State (evalStateT, get, MonadState, StateT)
import Control.Monad.Trans.Control (MonadBaseControl(..))
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, 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)
newtype DAVT m a = DAVT { runDAVT :: ErrorT String (StateT DAVContext m) a }
deriving (Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext)
instance MonadBaseControl b m => MonadBaseControl b (DAVT m) where
newtype StM (DAVT m) a = StDAVT { unStDAVT :: StM (ErrorT String (StateT DAVContext m)) a }
liftBaseWith f = DAVT . liftBaseWith $ \r -> f $ liftM StDAVT . r . runDAVT
restoreM = DAVT . restoreM . unStDAVT
instance MonadTrans DAVT where
lift = DAVT . lift . lift
evalDAVT :: MonadIO m => String -> DAVT m a -> m (Either String a)
evalDAVT u f = do
mgr <- liftIO $ newManager tlsManagerSettings
req <- liftIO $ parseUrl u
r <- (evalStateT . runErrorT . runDAVT) f $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"
liftIO $ closeManager mgr
return r
choke :: IO (Either String a) -> IO a
choke f = do
x <- f
case x of
Left e -> error e
Right r -> return r
setCreds :: MonadIO m => B.ByteString -> B.ByteString -> DAVT m ()
setCreds u p = basicusername .= u >> basicpassword .= p
setDepth :: MonadIO m => Maybe Depth -> DAVT m ()
setDepth d = depth .= d
setUserAgent :: MonadIO m => B.ByteString -> DAVT m ()
setUserAgent ua = userAgent .= ua
setResponseTimeout :: MonadIO m => Maybe Int -> DAVT m ()
setResponseTimeout rt = baseRequest %= \x -> x { responseTimeout = rt }
davRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m (Response BL.ByteString)
davRequest meth addlhdrs rbody = do
ctx <- get
let hdrs = catMaybes
[ Just (mk "User-Agent", ctx ^. userAgent)
, 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
liftIO (catchJust (matchStatusCodeException unauthorized401)
(httpLbs req (ctx ^. httpManager))
(\_ -> httpLbs authreq (ctx ^. httpManager)))
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 :: MonadIO m => DAVT 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
complianceClasses .= cclass
allowedMethods .= meths
lockResource :: MonadIO m => Bool -> DAVT 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
lockToken .= hdrtoken
unlockResource :: MonadIO m => DAVT m ()
unlockResource = do
d <- get
case _lockToken d of
Nothing -> return ()
Just tok -> do let ahs = [(mk "Lock-Token", tok)]
_ <- davRequest "UNLOCK" ahs emptyBody
lockToken .= Nothing
supportsLocking :: DAVContext -> Bool
supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods
supportsCalDAV :: DAVContext -> Bool
supportsCalDAV = ("calendar-access" `elem`) . _complianceClasses
getPropsM :: MonadIO m => DAVT 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 :: MonadIO m => DAVT m (Maybe B.ByteString, BL.ByteString)
getContentM = do
resp <- davRequest "GET" [] emptyBody
let ct = lookup hContentType (responseHeaders resp)
return (ct, responseBody resp)
putContentM :: MonadIO m => (Maybe B.ByteString, BL.ByteString) -> DAVT m ()
putContentM (ct, body) = do
d <- get
let ahs' = maybe [] (return . (,) (mk "If") . parenthesize) (d ^. lockToken)
let ahs = ahs' ++ maybe [] (return . (,) hContentType) ct
_ <- davRequest "PUT" ahs (RequestBodyLBS body)
return ()
delContentM :: MonadIO m => DAVT m ()
delContentM = do
_ <- davRequest "DELETE" [] emptyBody
return ()
moveContentM :: MonadIO m => B.ByteString -> DAVT m ()
moveContentM newurl = do
let ahs = [ (mk "Destination", newurl) ]
_ <- davRequest "MOVE" ahs emptyBody
return ()
mkCol' :: MonadIO m => DAVT m ()
mkCol' = do
_ <- davRequest "MKCOL" [] emptyBody
return ()
mkCol :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => DAVT m Bool
mkCol = catchJust
(matchStatusCodeException conflict409)
(mkCol' >> return True)
(\_ -> return False)
parenthesize :: B.ByteString -> B.ByteString
parenthesize x = B.concat ["(", x, ")"]
putPropsM :: MonadIO m => XML.Document -> DAVT m ()
putPropsM props = do
d <- get
let ah' = (hContentType, "application/xml; charset=\"utf-8\"")
let ahs = ah':maybe [] (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 :: MonadIO m => DAVT 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
getOptionsOnce :: MonadIO m => DAVT m ()
getOptionsOnce = getOptions
withLockIfPossible :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => Bool -> DAVT m a -> DAVT m a
withLockIfPossible nocreate f = do
getOptionsOnce
o <- get
when (supportsLocking o) (lockResource nocreate)
f `finally` when (supportsLocking o) unlockResource
withLockIfPossibleForDelete :: (MonadIO m, MonadBase IO m, MonadBaseControl IO m) => Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete nocreate f = do
getOptionsOnce
o <- get
let lock = when (supportsLocking o) (lockResource nocreate)
let unlock = when (supportsLocking o) unlockResource
bracketOnError lock (const unlock) (const f)
getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document
getProps url username password md = choke $ evalDAVT url $ do
setCreds username password
setDepth md
getPropsM
getPropsAndContent :: String -> B.ByteString -> B.ByteString -> IO (XML.Document, (Maybe B.ByteString, BL.ByteString))
getPropsAndContent url username password = choke $ evalDAVT url $ do
setCreds username password
setDepth (Just Depth0)
withLockIfPossible True $ liftM2 (,) getPropsM getContentM
putContent :: String -> B.ByteString -> B.ByteString -> (Maybe B.ByteString, BL.ByteString) -> IO ()
putContent url username password b = choke $ evalDAVT url $ do
setCreds username password
withLockIfPossible False $ putContentM b
putContentAndProps :: String -> B.ByteString -> B.ByteString -> (XML.Document, (Maybe B.ByteString, BL.ByteString)) -> IO ()
putContentAndProps url username password (p, b) = choke $ evalDAVT url $ do
setCreds username password
withLockIfPossible False $ do putContentM b
putPropsM p
deleteContent :: String -> B.ByteString -> B.ByteString -> IO ()
deleteContent url username password = choke $ evalDAVT url $ do
setCreds username password
withLockIfPossibleForDelete False delContentM
moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO ()
moveContent url newurl username password = choke $ evalDAVT url $ do
setCreds username password
moveContentM newurl
caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document
caldavReport url username password = choke $ evalDAVT url $ do
setCreds username password
setDepth (Just Depth1)
caldavReportM
makeCollection :: String -> B.ByteString -> B.ByteString -> IO Bool
makeCollection url username password = choke $ evalDAVT url $ do
setCreds username password
mkCol
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">
|]