-- DAV.hs: WebDAV client library
-- Copyright © 2012-2016  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 <http://www.gnu.org/licenses/>.

{-# 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
def = [ByteString]
-> Request
-> ByteString
-> ByteString
-> [ByteString]
-> Maybe Depth
-> Maybe Manager
-> Maybe ByteString
-> ByteString
-> DAVContext
DAVContext [] Request
defaultRequest ByteString
B.empty ByteString
B.empty [] forall a. Maybe a
Nothing forall a. Default a => a
def forall a. Maybe a
Nothing ByteString
"hDav-using application"
#else
    def = DAVContext [] def B.empty B.empty [] Nothing def Nothing "hDav-using application"
#endif

newtype DAVT m a = DAVT { forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT :: ExceptT String (StateT DAVContext m) a }
    deriving (forall a. DAVT m a
forall a. DAVT m a -> DAVT m [a]
forall a. DAVT m a -> DAVT m a -> DAVT m a
forall {m :: * -> *}. Monad m => Applicative (DAVT m)
forall (m :: * -> *) a. Monad m => DAVT m a
forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. DAVT m a -> DAVT m [a]
$cmany :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
some :: forall a. DAVT m a -> DAVT m [a]
$csome :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
<|> :: forall a. DAVT m a -> DAVT m a -> DAVT m a
$c<|> :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
empty :: forall a. DAVT m a
$cempty :: forall (m :: * -> *) a. Monad m => DAVT m a
Alternative, forall a. a -> DAVT m a
forall a b. DAVT m a -> DAVT m b -> DAVT m a
forall a b. DAVT m a -> DAVT m b -> DAVT m b
forall a b. DAVT m (a -> b) -> DAVT m a -> DAVT m b
forall a b c. (a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
forall {m :: * -> *}. Monad m => Functor (DAVT m)
forall (m :: * -> *) a. Monad m => a -> DAVT m a
forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m a
forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m b
forall (m :: * -> *) a b.
Monad m =>
DAVT m (a -> b) -> DAVT m a -> DAVT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. DAVT m a -> DAVT m b -> DAVT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m a
*> :: forall a b. DAVT m a -> DAVT m b -> DAVT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m b
liftA2 :: forall a b c. (a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
<*> :: forall a b. DAVT m (a -> b) -> DAVT m a -> DAVT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
DAVT m (a -> b) -> DAVT m a -> DAVT m b
pure :: forall a. a -> DAVT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
Applicative, forall a b. a -> DAVT m b -> DAVT m a
forall a b. (a -> b) -> DAVT m a -> DAVT m b
forall (m :: * -> *) a b. Functor m => a -> DAVT m b -> DAVT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DAVT m a -> DAVT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DAVT m b -> DAVT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> DAVT m b -> DAVT m a
fmap :: forall a b. (a -> b) -> DAVT m a -> DAVT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DAVT m a -> DAVT m b
Functor, forall a. a -> DAVT m a
forall a b. DAVT m a -> DAVT m b -> DAVT m b
forall a b. DAVT m a -> (a -> DAVT m b) -> DAVT m b
forall {m :: * -> *}. Monad m => Applicative (DAVT m)
forall (m :: * -> *) a. Monad m => a -> DAVT m a
forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m b
forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> (a -> DAVT m b) -> DAVT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> DAVT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
>> :: forall a b. DAVT m a -> DAVT m b -> DAVT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m b
>>= :: forall a b. DAVT m a -> (a -> DAVT m b) -> DAVT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> (a -> DAVT m b) -> DAVT m b
Monad, MonadBase b, MonadError String, forall a. (a -> DAVT m a) -> DAVT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (DAVT m)
forall (m :: * -> *) a. MonadFix m => (a -> DAVT m a) -> DAVT m a
mfix :: forall a. (a -> DAVT m a) -> DAVT m a
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> DAVT m a) -> DAVT m a
MonadFix, forall a. IO a -> DAVT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (DAVT m)
forall (m :: * -> *) a. MonadIO m => IO a -> DAVT m a
liftIO :: forall a. IO a -> DAVT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> DAVT m a
MonadIO, forall a. DAVT m a
forall a. DAVT m a -> DAVT m a -> DAVT m a
forall (m :: * -> *). Monad m => Monad (DAVT m)
forall (m :: * -> *). Monad m => Alternative (DAVT m)
forall (m :: * -> *) a. Monad m => DAVT m a
forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. DAVT m a -> DAVT m a -> DAVT m a
$cmplus :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
mzero :: forall a. DAVT m a
$cmzero :: forall (m :: * -> *) a. Monad m => DAVT m a
MonadPlus, MonadState DAVContext)

instance MonadCatch m => MonadCatch (DAVT m) where
    catch :: forall e a. Exception e => DAVT m a -> (e -> DAVT m a) -> DAVT m a
catch (DAVT ExceptT String (StateT DAVContext m) a
m) e -> DAVT m a
f = forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MonadCatch.catch ExceptT String (StateT DAVContext m) a
m (forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> DAVT m a
f)

instance MonadThrow m => MonadThrow (DAVT m) where
    throwM :: forall e a. Exception e => e -> DAVT m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance MonadTrans DAVT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> DAVT m a
lift = forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

type DAVURL = String

evalDAVT :: MonadIO m => DAVURL -> DAVT m a -> m (Either String a)
evalDAVT :: forall (m :: * -> *) a.
MonadIO m =>
String -> DAVT m a -> m (Either String a)
evalDAVT String
u DAVT m a
f = do
    DAVContext
ctx <- forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u
    Either String a
r <- (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT) DAVT m a
f DAVContext
ctx
    forall (m :: * -> *). MonadIO m => DAVContext -> m ()
closeDAVContext DAVContext
ctx
    forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
r

mkDAVContext :: MonadIO m => DAVURL -> m DAVContext
mkDAVContext :: forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Manager
mgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
#if MIN_VERSION_http_client(0,5,0)
    Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
u
#else
    req <- liftIO $ parseUrl u
#endif
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def { _baseRequest :: Request
_baseRequest = Request
req, _httpManager :: Maybe Manager
_httpManager = forall a. a -> Maybe a
Just Manager
mgr }

{-# DEPRECATED closeDAVContext "deprecated because http-client deprecated closeManager" #-}
closeDAVContext :: MonadIO m => DAVContext -> m ()
closeDAVContext :: forall (m :: * -> *). MonadIO m => DAVContext -> m ()
closeDAVContext DAVContext
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

withDAVContext :: MonadIO m => DAVURL -> (DAVContext -> m a) -> m a
withDAVContext :: forall (m :: * -> *) a.
MonadIO m =>
String -> (DAVContext -> m a) -> m a
withDAVContext String
u DAVContext -> m a
f = forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DAVContext -> m a
f

runDAVContext :: MonadIO m => DAVContext -> DAVT m a -> m (Either String a, DAVContext)
runDAVContext :: forall (m :: * -> *) a.
MonadIO m =>
DAVContext -> DAVT m a -> m (Either String a, DAVContext)
runDAVContext DAVContext
ctx DAVT m a
f = (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT) DAVT m a
f DAVContext
ctx

setCreds :: MonadIO m => B.ByteString -> B.ByteString -> DAVT m ()
setCreds :: forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> DAVT m ()
setCreds ByteString
u ByteString
p = Lens' DAVContext ByteString
basicusername forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
u forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Lens' DAVContext ByteString
basicpassword forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
p

setDepth :: MonadIO m => Maybe Depth -> DAVT m ()
setDepth :: forall (m :: * -> *). MonadIO m => Maybe Depth -> DAVT m ()
setDepth Maybe Depth
d = Lens' DAVContext (Maybe Depth)
depth forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe Depth
d

setUserAgent :: MonadIO m => B.ByteString -> DAVT m ()
setUserAgent :: forall (m :: * -> *). MonadIO m => ByteString -> DAVT m ()
setUserAgent ByteString
ua = Lens' DAVContext ByteString
userAgent forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
ua

setResponseTimeout :: MonadIO m => Maybe Int -> DAVT m ()
#if MIN_VERSION_http_client(0,5,0)
setResponseTimeout :: forall (m :: * -> *). MonadIO m => Maybe Int -> DAVT m ()
setResponseTimeout Maybe Int
rt = Lens' DAVContext Request
baseRequest forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Request
x -> Request
x { responseTimeout :: ResponseTimeout
responseTimeout = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
responseTimeoutNone Int -> ResponseTimeout
responseTimeoutMicro Maybe Int
rt }
#else
setResponseTimeout rt = baseRequest %= \x -> x { responseTimeout = rt }
#endif

mkDavRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest :: forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest ByteString
meth RequestHeaders
addlhdrs RequestBody
rbody = do
    DAVContext
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
    let hdrs :: RequestHeaders
hdrs = forall a. [Maybe a] -> [a]
catMaybes
               [ forall a. a -> Maybe a
Just (forall s. FoldCase s => s -> CI s
mk ByteString
"User-Agent", DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext ByteString
userAgent)
               , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (forall s. FoldCase s => s -> CI s
mk ByteString
"Depth") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext (Maybe Depth)
depth)
               ] forall a. [a] -> [a] -> [a]
++ RequestHeaders
addlhdrs
        req :: Request
req = (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext Request
baseRequest) { method :: ByteString
method = ByteString
meth, requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdrs, requestBody :: RequestBody
requestBody = RequestBody
rbody }
        authreq :: Request
authreq = if ByteString -> Bool
B.null (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext ByteString
basicusername) Bool -> Bool -> Bool
&& ByteString -> Bool
B.null (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext ByteString
basicpassword)
            then Request
req
            else ByteString -> ByteString -> Request -> Request
applyBasicAuth (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext ByteString
basicusername) (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext ByteString
basicpassword) Request
req
    forall (m :: * -> *) a. Monad m => a -> m a
return Request
authreq

davRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m (Response BL.ByteString)
davRequest :: forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
meth RequestHeaders
addlhdrs RequestBody
rbody = forall {m :: * -> *}.
MonadIO m =>
Request -> DAVT m (Response ByteString)
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest ByteString
meth RequestHeaders
addlhdrs RequestBody
rbody
  where
    go :: Request -> DAVT m (Response ByteString)
go Request
req = do
      DAVContext
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Can't perform request without manager") (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Response ByteString)
httpLbs Request
req) (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext (Maybe Manager)
httpManager)

matchStatusCodeException :: Status -> HttpException -> Maybe ()
#if MIN_VERSION_http_client(0,5,0)
matchStatusCodeException :: Status -> HttpException -> Maybe ()
matchStatusCodeException Status
want (HttpExceptionRequest Request
_ (StatusCodeException Response ()
resp ByteString
_))
    | forall body. Response body -> Status
responseStatus Response ()
resp forall a. Eq a => a -> a -> Bool
== Status
want = forall a. a -> Maybe a
Just ()
#else
matchStatusCodeException want (StatusCodeException s _ _)
    | s == want = Just ()
#endif
    | Bool
otherwise = forall a. Maybe a
Nothing
matchStatusCodeException Status
_ HttpException
_ = forall a. Maybe a
Nothing

emptyBody :: RequestBody
emptyBody :: RequestBody
emptyBody = ByteString -> RequestBody
RequestBodyLBS ByteString
BL.empty

xmlBody :: XML.Document -> RequestBody
xmlBody :: Document -> RequestBody
xmlBody = ByteString -> RequestBody
RequestBodyLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
XML.renderLBS forall a. Default a => a
XML.def

getOptions :: MonadIO m => DAVT m ()
getOptions :: forall (m :: * -> *). MonadIO m => DAVT m ()
getOptions = do
    Response ByteString
optresp <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"OPTIONS" [] RequestBody
emptyBody
    let meths :: [ByteString]
meths = ((Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (forall a. Eq a => a -> a -> Bool
==(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Allow" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
optresp
    let cclass :: [ByteString]
cclass = ((Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (forall a. Eq a => a -> a -> Bool
==(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"DAV" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
optresp
    Lens' DAVContext [ByteString]
complianceClasses forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [ByteString]
cclass
    Lens' DAVContext [ByteString]
allowedMethods forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [ByteString]
meths

lockResource :: MonadIO m => Bool -> DAVT m ()
lockResource :: forall (m :: * -> *). MonadIO m => Bool -> DAVT m ()
lockResource Bool
nocreate = do
    let ahs' :: RequestHeaders
ahs' = [(CI ByteString
hContentType, ByteString
"application/xml; charset=\"utf-8\""), (forall s. FoldCase s => s -> CI s
mk ByteString
"Depth", ByteString
"0"), (forall s. FoldCase s => s -> CI s
mk ByteString
"Timeout", ByteString
"Second-300")]
    let ahs :: RequestHeaders
ahs = if Bool
nocreate then (forall s. FoldCase s => s -> CI s
mk ByteString
"If-Match", ByteString
"*")forall a. a -> [a] -> [a]
:RequestHeaders
ahs' else RequestHeaders
ahs'
    Response ByteString
lockresp <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"LOCK" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
locky)
    let hdrtoken :: Maybe ByteString
hdrtoken = (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Lock-Token" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
lockresp
    Lens' DAVContext (Maybe ByteString)
lockToken forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe ByteString
hdrtoken

unlockResource :: MonadIO m => DAVT m ()
unlockResource :: forall (m :: * -> *). MonadIO m => DAVT m ()
unlockResource = do
    DAVContext
d <- forall s (m :: * -> *). MonadState s m => m s
get
    case DAVContext -> Maybe ByteString
_lockToken DAVContext
d of
        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ByteString
tok -> do let ahs :: RequestHeaders
ahs = [(forall s. FoldCase s => s -> CI s
mk ByteString
"Lock-Token", ByteString
tok)]
                       Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"UNLOCK" RequestHeaders
ahs RequestBody
emptyBody
                       Lens' DAVContext (Maybe ByteString)
lockToken forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Maybe a
Nothing

supportsLocking :: DAVContext -> Bool
supportsLocking :: DAVContext -> Bool
supportsLocking = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (ByteString
"LOCK" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (ByteString
"UNLOCK" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DAVContext -> [ByteString]
_allowedMethods

getPropsM :: MonadIO m => DAVT m XML.Document
getPropsM :: forall (m :: * -> *). MonadIO m => DAVT m Document
getPropsM = do
    let ahs :: RequestHeaders
ahs = [(CI ByteString
hContentType, ByteString
"application/xml; charset=\"utf-8\"")]
    Response ByteString
propresp <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"PROPFIND" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
propname)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ParseSettings -> ByteString -> Document
XML.parseLBS_ forall a. Default a => a
XML.def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody) Response ByteString
propresp

-- | Note that the entire request body is buffered in memory.
-- To stream large files use withContentM instead.
getContentM :: MonadIO m => DAVT m (Maybe B.ByteString, BL.ByteString)
getContentM :: forall (m :: * -> *).
MonadIO m =>
DAVT m (Maybe ByteString, ByteString)
getContentM = do
    Response ByteString
resp <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"GET" [] RequestBody
emptyBody
    let ct :: Maybe ByteString
ct = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType (forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
resp)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, forall body. Response body -> body
responseBody Response ByteString
resp)

withContentM :: MonadIO m => (Response BodyReader -> IO a) -> DAVT m a
withContentM :: forall (m :: * -> *) a.
MonadIO m =>
(Response BodyReader -> IO a) -> DAVT m a
withContentM Response BodyReader -> IO a
handleresponse = do
    Request
req <- forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest ByteString
"GET" [] RequestBody
emptyBody
    DAVContext
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Can't handle response without manager") (\Manager
mgr -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
mgr Response BodyReader -> IO a
handleresponse) (DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext (Maybe Manager)
httpManager)

-- | Note that the entire request body is buffered in memory; not suitable
-- for large files.
putContentM :: MonadIO m => (Maybe B.ByteString, BL.ByteString) -> DAVT m ()
putContentM :: forall (m :: * -> *).
MonadIO m =>
(Maybe ByteString, ByteString) -> DAVT m ()
putContentM (Maybe ByteString
ct, ByteString
body) = forall (m :: * -> *).
MonadIO m =>
(Maybe ByteString, RequestBody) -> DAVT m ()
putContentM' (Maybe ByteString
ct, ByteString -> RequestBody
RequestBodyLBS ByteString
body)

-- | To send a large file, pass eg a RequestBodyStream containing the
-- file's content.
putContentM' :: MonadIO m => (Maybe B.ByteString, RequestBody) -> DAVT m ()
putContentM' :: forall (m :: * -> *).
MonadIO m =>
(Maybe ByteString, RequestBody) -> DAVT m ()
putContentM' (Maybe ByteString
ct, RequestBody
requestbody) = do
    DAVContext
d <- forall s (m :: * -> *). MonadState s m => m s
get
    let ahs' :: RequestHeaders
ahs' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (forall s. FoldCase s => s -> CI s
mk ByteString
"If") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
parenthesize) (DAVContext
d forall s a. s -> Getting a s a -> a
^. Lens' DAVContext (Maybe ByteString)
lockToken)
    let ahs :: RequestHeaders
ahs = RequestHeaders
ahs' forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) CI ByteString
hContentType) Maybe ByteString
ct
    Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"PUT" RequestHeaders
ahs RequestBody
requestbody
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

delContentM :: MonadIO m => DAVT m ()
delContentM :: forall (m :: * -> *). MonadIO m => DAVT m ()
delContentM = do
    Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"DELETE" [] RequestBody
emptyBody
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

moveContentM :: MonadIO m => B.ByteString -> DAVT m ()
moveContentM :: forall (m :: * -> *). MonadIO m => ByteString -> DAVT m ()
moveContentM ByteString
newurl = do
    let ahs :: RequestHeaders
ahs = [ (forall s. FoldCase s => s -> CI s
mk ByteString
"Destination", ByteString
newurl) ]
    Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"MOVE" RequestHeaders
ahs RequestBody
emptyBody
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

mkCol' :: MonadIO m => DAVT m ()
mkCol' :: forall (m :: * -> *). MonadIO m => DAVT m ()
mkCol' = do
    Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"MKCOL" [] RequestBody
emptyBody
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

mkCol :: (MonadIO m, MonadBase IO m, MonadCatch m) => DAVT m Bool
mkCol :: forall (m :: * -> *).
(MonadIO m, MonadBase IO m, MonadCatch m) =>
DAVT m Bool
mkCol = forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
        (Status -> HttpException -> Maybe ()
matchStatusCodeException Status
conflict409)
        (forall (m :: * -> *). MonadIO m => DAVT m ()
mkCol' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
        (\()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

parenthesize :: B.ByteString -> B.ByteString
parenthesize :: ByteString -> ByteString
parenthesize ByteString
x = [ByteString] -> ByteString
B.concat [ByteString
"(", ByteString
x, ByteString
")"]

putPropsM :: MonadIO m => XML.Document -> DAVT m ()
putPropsM :: forall (m :: * -> *). MonadIO m => Document -> DAVT m ()
putPropsM Document
props = do
    DAVContext
d <- forall s (m :: * -> *). MonadState s m => m s
get
    let ah' :: (CI ByteString, ByteString)
ah' = (CI ByteString
hContentType, ByteString
"application/xml; charset=\"utf-8\"")
    let ahs :: RequestHeaders
ahs = (CI ByteString, ByteString)
ah'forall a. a -> [a] -> [a]
:forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (forall s. FoldCase s => s -> CI s
mk ByteString
"If") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
parenthesize) (DAVContext -> Maybe ByteString
_lockToken DAVContext
d)
    Response ByteString
_ <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"PROPPATCH" RequestHeaders
ahs ((ByteString -> RequestBody
RequestBodyLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> ByteString
props2patch) Document
props) -- FIXME: should diff and remove props from target
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

props2patch :: XML.Document -> BL.ByteString
props2patch :: Document -> ByteString
props2patch = RenderSettings -> Document -> ByteString
XML.renderLBS forall a. Default a => a
XML.def forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Document
patch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor Node -> [Node]
props forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Cursor Node
fromDocument
   where
       props :: Cursor Node -> [Node]
props Cursor Node
cursor = forall a b. (a -> b) -> [a] -> [b]
map forall node. Cursor node -> node
node (Cursor Node
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}response" forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}propstat" forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}prop" forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ forall b. Boolean b => (Name -> b) -> Cursor Node -> [Cursor Node]
checkName (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Name]
blacklist))
       patch :: [Node] -> Document
patch [Node]
prop = Prologue -> Element -> [Miscellaneous] -> Document
XML.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] forall a. Maybe a
Nothing []) ([Node] -> Element
root [Node]
prop) []
       root :: [Node] -> Element
root [] = [Node] -> Element
propertyupdate []
       root [Node]
prop = [Node] -> Element
propertyupdate
           [ Element -> Node
XML.NodeElement forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:set" forall k a. Map k a
Map.empty
             [ Element -> Node
XML.NodeElement forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:prop" forall k a. Map k a
Map.empty [Node]
prop ]
           ]
       propertyupdate :: [Node] -> Element
propertyupdate = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:propertyupdate" (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"xmlns:D", Text
"DAV:")])
       blacklist :: [Name]
blacklist = [ Name
"{DAV:}creationdate"
                   , Name
"{DAV:}displayname"
                   , Name
"{DAV:}getcontentlength"
                   , Name
"{DAV:}getcontenttype"
                   , Name
"{DAV:}getetag"
                   , Name
"{DAV:}getlastmodified"
                   , Name
"{DAV:}lockdiscovery"
                   , Name
"{DAV:}resourcetype"
                   , Name
"{DAV:}supportedlock"
                   ]

caldavReportM :: MonadIO m => DAVT m XML.Document
caldavReportM :: forall (m :: * -> *). MonadIO m => DAVT m Document
caldavReportM = do
    let ahs :: RequestHeaders
ahs = [(CI ByteString
hContentType, ByteString
"application/xml; charset=\"utf-8\"")]
    Response ByteString
calrresp <- forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"REPORT" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
calendarquery)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ParseSettings -> ByteString -> Document
XML.parseLBS_ forall a. Default a => a
XML.def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody) Response ByteString
calrresp

getOptionsOnce :: MonadIO m => DAVT m ()
getOptionsOnce :: forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce = forall (m :: * -> *). MonadIO m => DAVT m ()
getOptions -- this should only happen once

withLockIfPossible :: (MonadIO m, MonadBase IO m) => Bool -> DAVT m a -> DAVT m a
withLockIfPossible :: forall (m :: * -> *) a.
(MonadIO m, MonadBase IO m) =>
Bool -> DAVT m a -> DAVT m a
withLockIfPossible Bool
nocreate DAVT m a
f = do
    forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
    DAVContext
o <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) (forall (m :: * -> *). MonadIO m => Bool -> DAVT m ()
lockResource Bool
nocreate)
    a
res <- DAVT m a
f
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) forall (m :: * -> *). MonadIO m => DAVT m ()
unlockResource
    forall (m :: * -> *) a. Monad m => a -> m a
return a
res

withLockIfPossibleForDelete :: (MonadIO m, MonadBase IO m) => Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete :: forall (m :: * -> *) a.
(MonadIO m, MonadBase IO m) =>
Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete Bool
nocreate DAVT m a
f = do
    forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
    DAVContext
o <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) (forall (m :: * -> *). MonadIO m => Bool -> DAVT m ()
lockResource Bool
nocreate)
    -- a successful delete destroys locks, so only unlock on error
    forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError DAVT m a
f (\String
e -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) forall (m :: * -> *). MonadIO m => DAVT m ()
unlockResource forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
e)

propname :: XML.Document
propname :: Document
propname = Prologue -> Element -> [Miscellaneous] -> Document
XML.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] forall a. Maybe a
Nothing []) Element
root []
    where
        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:propfind" (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"xmlns:D", Text
"DAV:")]) [xml|
<D:allprop>
|]

locky :: XML.Document
locky :: Document
locky = Prologue -> Element -> [Miscellaneous] -> Document
XML.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] forall a. Maybe a
Nothing []) Element
root []
    where
        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:lockinfo" (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"xmlns:D", Text
"DAV:")]) [xml|
<D:lockscope>
  <D:exclusive>
<D:locktype>
  <D:write>
<D:owner>Haskell DAV user
|]

calendarquery :: XML.Document
calendarquery :: Document
calendarquery = Prologue -> Element -> [Miscellaneous] -> Document
XML.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] forall a. Maybe a
Nothing []) Element
root []
    where
        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"C:calendar-query" (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name
"xmlns:D", Text
"DAV:"),(Name
"xmlns:C", Text
"urn:ietf:params:xml:ns:caldav")]) [xml|
<D:prop>
  <D:getetag>
  <C:calendar-data>
<C:filter>
  <C:comp-filter name="VCALENDAR">
|]

-- | Normally, DAVT actions act on the url that is provided to eg, evalDAVT.
-- Sometimes, it's useful to adjust the url that is acted on, while
-- remaining in the same DAV session.
--
-- inLocation temporarily adjusts the url's path, while performing a
-- DAVT action.
--
-- For example:
--
-- > import System.FilePath.Posix -- posix for url path manipulation
-- >
-- > mkColRecursive d = do
-- >   let parent = takeDirectory d
-- >   when (parent /= d) $
-- >     mkColRecursive parent
-- >   inDAVLocation (</> d) mkCol
--
-- Note that operations that modify the DAVContext
-- (such as setCreds and setCreds) can be run inside davLocation,
-- but will not have any effect on the calling DAVContext.
inDAVLocation :: MonadIO m => (String -> String) -> DAVT m a -> DAVT m a
inDAVLocation :: forall (m :: * -> *) a.
MonadIO m =>
(String -> String) -> DAVT m a -> DAVT m a
inDAVLocation String -> String
f DAVT m a
a = do
    DAVContext
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
    let r :: Request
r = DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext Request
baseRequest
        r' :: Request
r' = Request
r { path :: ByteString
path = Request -> ByteString
adjustpath Request
r }
        ctx' :: DAVContext
ctx' = Lens' DAVContext Request
baseRequest forall s t a b. ASetter s t a b -> b -> s -> t
.~ Request
r' forall a b. (a -> b) -> a -> b
$ DAVContext
ctx
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT) DAVT m a
a DAVContext
ctx'
  where
    adjustpath :: Request -> ByteString
adjustpath = String -> ByteString
UTF8B.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8B.toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
path

-- | Gets the path of the url that DAVT actions will act on.
getDAVLocation :: Monad m => DAVT m String
getDAVLocation :: forall (m :: * -> *). Monad m => DAVT m String
getDAVLocation = do
    DAVContext
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
UTF8B.toString forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path forall a b. (a -> b) -> a -> b
$ DAVContext
ctx forall s a. s -> Getting a s a -> a
^. Lens' DAVContext Request
baseRequest)