{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts,
QuasiQuotes, RankNTypes, GeneralizedNewtypeDeriving,
FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,
TypeFamilies, CPP #-}
module Network.Protocol.HTTP.DAV (
DAVT(..)
, evalDAVT
, withDAVContext
, runDAVContext
, setCreds
, setDepth
, setResponseTimeout
, setUserAgent
, DAVContext(..)
, caldavReportM
, delContentM
, getPropsM
, getContentM
, withContentM
, mkCol
, moveContentM
, putPropsM
, putContentM
, putContentM'
, withLockIfPossible
, withLockIfPossibleForDelete
, inDAVLocation
, getDAVLocation
, mkDAVContext
, closeDAVContext
, module Network.Protocol.HTTP.DAV.TH
) where
import Network.Protocol.HTTP.DAV.TH
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative)
#endif
import Control.Applicative (liftA2, Alternative)
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Lens ((^.), (.=), (%=), (.~))
import Control.Monad (when, MonadPlus)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (catchJust, throwM, MonadCatch, MonadThrow)
import qualified Control.Monad.Catch as MonadCatch
import Control.Monad.Except (MonadError, catchError, throwError)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans.Class (lift, MonadTrans)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.State (evalStateT, runStateT, get, MonadState, StateT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.UTF8 as UTF8B
import Data.Default (Default, def)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe)
#if MIN_VERSION_http_client(0,5,0)
import Network.HTTP.Client (defaultRequest, HttpExceptionContent(StatusCodeException), parseUrlThrow, responseTimeoutDefault, responseTimeoutMicro, responseTimeoutNone)
#else
import Network.HTTP.Client (parseUrl)
#endif
import Network.HTTP.Client (RequestBody(..), httpLbs, applyBasicAuth, Request(..), Response(..), newManager, HttpException(..), BodyReader, withResponse, path)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, conflict409)
import qualified Text.XML as XML
import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName)
import Text.Hamlet.XML (xml)
import Data.CaseInsensitive (mk)
instance Default DAVContext where
#if MIN_VERSION_http_client(0,5,0)
def = DAVContext [] defaultRequest B.empty B.empty [] Nothing def Nothing "hDav-using application"
#else
def = DAVContext [] def B.empty B.empty [] Nothing def Nothing "hDav-using application"
#endif
newtype DAVT m a = DAVT { runDAVT :: ExceptT String (StateT DAVContext m) a }
deriving (Alternative, Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext)
instance MonadCatch m => MonadCatch (DAVT m) where
catch (DAVT m) f = DAVT $ MonadCatch.catch m (runDAVT . f)
instance MonadThrow m => MonadThrow (DAVT m) where
throwM = lift . throwM
instance MonadTrans DAVT where
lift = DAVT . lift . lift
type DAVURL = String
evalDAVT :: MonadIO m => DAVURL -> DAVT m a -> m (Either String a)
evalDAVT u f = do
ctx <- mkDAVContext u
r <- (evalStateT . runExceptT . runDAVT) f ctx
closeDAVContext ctx
return r
mkDAVContext :: MonadIO m => DAVURL -> m DAVContext
mkDAVContext u = liftIO $ do
mgr <- liftIO $ newManager tlsManagerSettings
#if MIN_VERSION_http_client(0,5,0)
req <- liftIO $ parseUrlThrow u
#else
req <- liftIO $ parseUrl u
#endif
return $ def { _baseRequest = req, _httpManager = Just mgr }
{-# DEPRECATED closeDAVContext "deprecated because http-client deprecated closeManager" #-}
closeDAVContext :: MonadIO m => DAVContext -> m ()
closeDAVContext _ = return ()
withDAVContext :: MonadIO m => DAVURL -> (DAVContext -> m a) -> m a
withDAVContext u f = mkDAVContext u >>= f
runDAVContext :: MonadIO m => DAVContext -> DAVT m a -> m (Either String a, DAVContext)
runDAVContext ctx f = (runStateT . runExceptT . runDAVT) f ctx
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 ()
#if MIN_VERSION_http_client(0,5,0)
setResponseTimeout rt = baseRequest %= \x -> x { responseTimeout = maybe responseTimeoutNone responseTimeoutMicro rt }
#else
setResponseTimeout rt = baseRequest %= \x -> x { responseTimeout = rt }
#endif
mkDavRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest 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 = if B.null (ctx ^. basicusername) && B.null (ctx ^. basicpassword)
then req
else applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req
return authreq
davRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m (Response BL.ByteString)
davRequest meth addlhdrs rbody = go =<< mkDavRequest meth addlhdrs rbody
where
go req = do
ctx <- get
maybe (DAVT $ throwE "Can't perform request without manager") (liftIO . httpLbs req) (ctx ^. httpManager)
matchStatusCodeException :: Status -> HttpException -> Maybe ()
#if MIN_VERSION_http_client(0,5,0)
matchStatusCodeException want (HttpExceptionRequest _ (StatusCodeException resp _))
| responseStatus resp == want = Just ()
#else
matchStatusCodeException want (StatusCodeException s _ _)
| s == want = Just ()
#endif
| 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
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)
withContentM :: MonadIO m => (Response BodyReader -> IO a) -> DAVT m a
withContentM handleresponse = do
req <- mkDavRequest "GET" [] emptyBody
ctx <- get
maybe (DAVT $ throwE "Can't handle response without manager") (\mgr -> liftIO $ withResponse req mgr handleresponse) (ctx ^. httpManager)
putContentM :: MonadIO m => (Maybe B.ByteString, BL.ByteString) -> DAVT m ()
putContentM (ct, body) = putContentM' (ct, RequestBodyLBS body)
putContentM' :: MonadIO m => (Maybe B.ByteString, RequestBody) -> DAVT m ()
putContentM' (ct, requestbody) = do
d <- get
let ahs' = maybe [] (return . (,) (mk "If") . parenthesize) (d ^. lockToken)
let ahs = ahs' ++ maybe [] (return . (,) hContentType) ct
_ <- davRequest "PUT" ahs requestbody
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, MonadCatch 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) => Bool -> DAVT m a -> DAVT m a
withLockIfPossible nocreate f = do
getOptionsOnce
o <- get
when (supportsLocking o) (lockResource nocreate)
res <- f
when (supportsLocking o) unlockResource
return res
withLockIfPossibleForDelete :: (MonadIO m, MonadBase IO m) => Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete nocreate f = do
getOptionsOnce
o <- get
when (supportsLocking o) (lockResource nocreate)
catchError f (\e -> when (supportsLocking o) unlockResource >> throwError e)
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:calendar-data>
<C:filter>
<C:comp-filter name="VCALENDAR">
|]
inDAVLocation :: MonadIO m => (String -> String) -> DAVT m a -> DAVT m a
inDAVLocation f a = do
ctx <- get
let r = ctx ^. baseRequest
r' = r { path = adjustpath r }
ctx' = baseRequest .~ r' $ ctx
lift $ either error return =<< (evalStateT . runExceptT . runDAVT) a ctx'
where
adjustpath = UTF8B.fromString . f . UTF8B.toString . path
getDAVLocation :: Monad m => DAVT m String
getDAVLocation = do
ctx <- get
return (UTF8B.toString $ path $ ctx ^. baseRequest)