{-# 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 [] Maybe Depth
forall a. Maybe a
Nothing Maybe Manager
forall a. Default a => a
def Maybe ByteString
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 (Applicative (DAVT m)
Applicative (DAVT m) =>
(forall a. DAVT m a)
-> (forall a. DAVT m a -> DAVT m a -> DAVT m a)
-> (forall a. DAVT m a -> DAVT m [a])
-> (forall a. DAVT m a -> DAVT m [a])
-> Alternative (DAVT m)
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
$cempty :: forall (m :: * -> *) a. Monad m => DAVT m a
empty :: forall a. DAVT m a
$c<|> :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
<|> :: forall a. DAVT m a -> DAVT m a -> DAVT m a
$csome :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
some :: forall a. DAVT m a -> DAVT m [a]
$cmany :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
many :: forall a. DAVT m a -> DAVT m [a]
Alternative, Functor (DAVT m)
Functor (DAVT m) =>
(forall a. a -> DAVT m a)
-> (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 a b. DAVT m a -> DAVT m b -> DAVT m b)
-> (forall a b. DAVT m a -> DAVT m b -> DAVT m a)
-> Applicative (DAVT m)
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
$cpure :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
pure :: forall a. a -> DAVT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
DAVT m (a -> b) -> DAVT m a -> DAVT m b
<*> :: forall a b. DAVT m (a -> b) -> DAVT m a -> DAVT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
liftA2 :: forall a b c. (a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> DAVT m b -> DAVT m b
*> :: 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 a
<* :: forall a b. DAVT m a -> DAVT m b -> DAVT m a
Applicative, (forall a b. (a -> b) -> DAVT m a -> DAVT m b)
-> (forall a b. a -> DAVT m b -> DAVT m a) -> Functor (DAVT m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DAVT m a -> DAVT m b
fmap :: forall a b. (a -> b) -> DAVT m a -> DAVT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> DAVT m b -> DAVT m a
<$ :: forall a b. a -> DAVT m b -> DAVT m a
Functor, Applicative (DAVT m)
Applicative (DAVT m) =>
(forall a b. DAVT m a -> (a -> DAVT m b) -> DAVT m b)
-> (forall a b. DAVT m a -> DAVT m b -> DAVT m b)
-> (forall a. a -> DAVT m a)
-> Monad (DAVT m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
DAVT m a -> (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 -> DAVT m b -> DAVT m b
>> :: forall a b. DAVT m a -> DAVT m b -> DAVT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
return :: forall a. a -> DAVT m a
Monad, MonadBase b, MonadError String, Monad (DAVT m)
Monad (DAVT m) =>
(forall a. (a -> DAVT m a) -> DAVT m a) -> MonadFix (DAVT m)
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
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> DAVT m a) -> DAVT m a
mfix :: forall a. (a -> DAVT m a) -> DAVT m a
MonadFix, Monad (DAVT m)
Monad (DAVT m) => (forall a. IO a -> DAVT m a) -> MonadIO (DAVT m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> DAVT m a
liftIO :: forall a. IO a -> DAVT m a
MonadIO, Monad (DAVT m)
Alternative (DAVT m)
(Alternative (DAVT m), Monad (DAVT m)) =>
(forall a. DAVT m a)
-> (forall a. DAVT m a -> DAVT m a -> DAVT m a)
-> MonadPlus (DAVT m)
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
$cmzero :: forall (m :: * -> *) a. Monad m => DAVT m a
mzero :: forall a. DAVT m a
$cmplus :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m a -> DAVT m a
mplus :: forall a. DAVT m a -> DAVT m a -> DAVT m a
MonadPlus, MonadState DAVContext)
instance MonadCatch m => MonadCatch (DAVT m) where
catch :: forall e a.
(HasCallStack, 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 = ExceptT String (StateT DAVContext m) a -> DAVT m a
forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT (ExceptT String (StateT DAVContext m) a -> DAVT m a)
-> ExceptT String (StateT DAVContext m) a -> DAVT m a
forall a b. (a -> b) -> a -> b
$ ExceptT String (StateT DAVContext m) a
-> (e -> ExceptT String (StateT DAVContext m) a)
-> ExceptT String (StateT DAVContext m) a
forall e a.
(HasCallStack, Exception e) =>
ExceptT String (StateT DAVContext m) a
-> (e -> ExceptT String (StateT DAVContext m) a)
-> ExceptT String (StateT DAVContext m) a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
MonadCatch.catch ExceptT String (StateT DAVContext m) a
m (DAVT m a -> ExceptT String (StateT DAVContext m) a
forall (m :: * -> *) a.
DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT (DAVT m a -> ExceptT String (StateT DAVContext m) a)
-> (e -> DAVT m a) -> e -> ExceptT String (StateT DAVContext m) a
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. (HasCallStack, Exception e) => e -> DAVT m a
throwM = m a -> DAVT m a
forall (m :: * -> *) a. Monad m => m a -> DAVT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DAVT m a) -> (e -> m a) -> e -> DAVT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM
instance MonadTrans DAVT where
lift :: forall (m :: * -> *) a. Monad m => m a -> DAVT m a
lift = ExceptT String (StateT DAVContext m) a -> DAVT m a
forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT (ExceptT String (StateT DAVContext m) a -> DAVT m a)
-> (m a -> ExceptT String (StateT DAVContext m) a)
-> m a
-> DAVT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT DAVContext m a -> ExceptT String (StateT DAVContext m) a
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT DAVContext m a -> ExceptT String (StateT DAVContext m) a)
-> (m a -> StateT DAVContext m a)
-> m a
-> ExceptT String (StateT DAVContext m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT DAVContext m a
forall (m :: * -> *) a. Monad m => m a -> StateT DAVContext m a
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
ctx <- String -> m DAVContext
forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u
r <- (evalStateT . runExceptT . runDAVT) f ctx
closeDAVContext ctx
return r
mkDAVContext :: MonadIO m => DAVURL -> m DAVContext
mkDAVContext :: forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u = IO DAVContext -> m DAVContext
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DAVContext -> m DAVContext) -> IO DAVContext -> m DAVContext
forall a b. (a -> b) -> a -> b
$ do
mgr <- IO Manager -> IO Manager
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> IO Manager) -> IO Manager -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
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 :: forall (m :: * -> *). MonadIO m => DAVContext -> m ()
closeDAVContext DAVContext
_ = () -> m ()
forall a. a -> m a
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 = String -> m DAVContext
forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u m DAVContext -> (DAVContext -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
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 = (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a, DAVContext)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a, DAVContext))
-> (DAVT m a -> StateT DAVContext m (Either String a))
-> DAVT m a
-> DAVContext
-> m (Either String a, DAVContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (StateT DAVContext m) a
-> StateT DAVContext m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (StateT DAVContext m) a
-> StateT DAVContext m (Either String a))
-> (DAVT m a -> ExceptT String (StateT DAVContext m) a)
-> DAVT m a
-> StateT DAVContext m (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DAVT m a -> ExceptT String (StateT DAVContext m) a
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 = (ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext
Lens' DAVContext ByteString
basicusername ((ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext)
-> ByteString -> DAVT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
u DAVT m () -> DAVT m () -> DAVT m ()
forall a b. DAVT m a -> DAVT m b -> DAVT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext
Lens' DAVContext ByteString
basicpassword ((ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext)
-> ByteString -> DAVT m ()
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 = (Maybe Depth -> Identity (Maybe Depth))
-> DAVContext -> Identity DAVContext
Lens' DAVContext (Maybe Depth)
depth ((Maybe Depth -> Identity (Maybe Depth))
-> DAVContext -> Identity DAVContext)
-> Maybe Depth -> DAVT m ()
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 = (ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext
Lens' DAVContext ByteString
userAgent ((ByteString -> Identity ByteString)
-> DAVContext -> Identity DAVContext)
-> ByteString -> DAVT m ()
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 = (Request -> Identity Request) -> DAVContext -> Identity DAVContext
Lens' DAVContext Request
baseRequest ((Request -> Identity Request)
-> DAVContext -> Identity DAVContext)
-> (Request -> Request) -> DAVT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Request
x -> Request
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 :: forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest ByteString
meth RequestHeaders
addlhdrs RequestBody
rbody = do
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let hdrs = [Maybe (CI ByteString, ByteString)] -> RequestHeaders
forall a. [Maybe a] -> [a]
catMaybes
[ (CI ByteString, ByteString) -> Maybe (CI ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"User-Agent", DAVContext
ctx DAVContext
-> Getting ByteString DAVContext ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString DAVContext ByteString
Lens' DAVContext ByteString
userAgent)
, (Depth -> (CI ByteString, ByteString))
-> Maybe Depth -> Maybe (CI ByteString, ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"Depth") (ByteString -> (CI ByteString, ByteString))
-> (Depth -> ByteString) -> Depth -> (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC8.pack (String -> ByteString) -> (Depth -> String) -> Depth -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Depth -> String
forall a. Show a => a -> String
show) (DAVContext
ctx DAVContext
-> Getting (Maybe Depth) DAVContext (Maybe Depth) -> Maybe Depth
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Depth) DAVContext (Maybe Depth)
Lens' DAVContext (Maybe Depth)
depth)
] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
addlhdrs
req = (DAVContext
ctx DAVContext -> Getting Request DAVContext Request -> Request
forall s a. s -> Getting a s a -> a
^. Getting Request DAVContext Request
Lens' DAVContext Request
baseRequest) { method = meth, requestHeaders = hdrs, requestBody = rbody }
authreq = if ByteString -> Bool
B.null (DAVContext
ctx DAVContext
-> Getting ByteString DAVContext ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString DAVContext ByteString
Lens' DAVContext ByteString
basicusername) Bool -> Bool -> Bool
&& ByteString -> Bool
B.null (DAVContext
ctx DAVContext
-> Getting ByteString DAVContext ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString DAVContext ByteString
Lens' DAVContext ByteString
basicpassword)
then Request
req
else ByteString -> ByteString -> Request -> Request
applyBasicAuth (DAVContext
ctx DAVContext
-> Getting ByteString DAVContext ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString DAVContext ByteString
Lens' DAVContext ByteString
basicusername) (DAVContext
ctx DAVContext
-> Getting ByteString DAVContext ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString DAVContext ByteString
Lens' DAVContext ByteString
basicpassword) Request
req
return 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 = Request -> DAVT m (Response ByteString)
forall {m :: * -> *}.
MonadIO m =>
Request -> DAVT m (Response ByteString)
go (Request -> DAVT m (Response ByteString))
-> DAVT m Request -> DAVT m (Response ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
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
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
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 :: Status -> HttpException -> Maybe ()
matchStatusCodeException Status
want (HttpExceptionRequest Request
_ (StatusCodeException Response ()
resp ByteString
_))
| Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
want = () -> Maybe ()
forall a. a -> Maybe a
Just ()
#else
matchStatusCodeException want (StatusCodeException s _ _)
| s == want = Just ()
#endif
| Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing
matchStatusCodeException Status
_ HttpException
_ = Maybe ()
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 (ByteString -> RequestBody)
-> (Document -> ByteString) -> Document -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
XML.renderLBS RenderSettings
forall a. Default a => a
XML.def
getOptions :: MonadIO m => DAVT m ()
getOptions :: forall (m :: * -> *). MonadIO m => DAVT m ()
getOptions = do
optresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"OPTIONS" [] RequestBody
emptyBody
let meths = ((Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==(Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) Char
',') (ByteString -> [ByteString])
-> (Response ByteString -> ByteString)
-> Response ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty (Maybe ByteString -> ByteString)
-> (Response ByteString -> Maybe ByteString)
-> Response ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Allow" (RequestHeaders -> Maybe ByteString)
-> (Response ByteString -> RequestHeaders)
-> Response ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
optresp
let cclass = ((Word8 -> Bool) -> ByteString -> [ByteString]
B.splitWith (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==(Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) Char
',') (ByteString -> [ByteString])
-> (Response ByteString -> ByteString)
-> Response ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
B.empty (Maybe ByteString -> ByteString)
-> (Response ByteString -> Maybe ByteString)
-> Response ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"DAV" (RequestHeaders -> Maybe ByteString)
-> (Response ByteString -> RequestHeaders)
-> Response ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
optresp
complianceClasses .= cclass
allowedMethods .= 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\""), (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"Depth", ByteString
"0"), (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"Timeout", ByteString
"Second-300")]
let ahs :: RequestHeaders
ahs = if Bool
nocreate then (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"If-Match", ByteString
"*")(CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:RequestHeaders
ahs' else RequestHeaders
ahs'
lockresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"LOCK" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
locky)
let hdrtoken = (CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Lock-Token" (RequestHeaders -> Maybe ByteString)
-> (Response ByteString -> RequestHeaders)
-> Response ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders) Response ByteString
lockresp
lockToken .= hdrtoken
unlockResource :: MonadIO m => DAVT m ()
unlockResource :: forall (m :: * -> *). MonadIO m => DAVT m ()
unlockResource = do
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
case _lockToken d of
Maybe ByteString
Nothing -> () -> DAVT m ()
forall a. a -> DAVT m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
tok -> do let ahs :: RequestHeaders
ahs = [(ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"Lock-Token", ByteString
tok)]
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"UNLOCK" RequestHeaders
ahs RequestBody
emptyBody
lockToken .= Nothing
supportsLocking :: DAVContext -> Bool
supportsLocking :: DAVContext -> Bool
supportsLocking = (Bool -> Bool -> Bool)
-> ([ByteString] -> Bool)
-> ([ByteString] -> Bool)
-> [ByteString]
-> Bool
forall a b c.
(a -> b -> c)
-> ([ByteString] -> a) -> ([ByteString] -> b) -> [ByteString] -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (ByteString
"LOCK" ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (ByteString
"UNLOCK" ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([ByteString] -> Bool)
-> (DAVContext -> [ByteString]) -> DAVContext -> Bool
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\"")]
propresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"PROPFIND" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
propname)
return $ (XML.parseLBS_ XML.def . responseBody) propresp
getContentM :: MonadIO m => DAVT m (Maybe B.ByteString, BL.ByteString)
getContentM :: forall (m :: * -> *).
MonadIO m =>
DAVT m (Maybe ByteString, ByteString)
getContentM = do
resp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"GET" [] RequestBody
emptyBody
let ct = CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType (Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
resp)
return (ct, responseBody 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
req <- ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest ByteString
"GET" [] RequestBody
emptyBody
ctx <- get
maybe (DAVT $ throwE "Can't handle response without manager") (\Manager
mgr -> IO a -> DAVT m a
forall a. IO a -> DAVT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> DAVT m a) -> IO a -> DAVT m a
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
mgr Response BodyReader -> IO a
handleresponse) (ctx ^. httpManager)
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) = (Maybe ByteString, RequestBody) -> DAVT m ()
forall (m :: * -> *).
MonadIO m =>
(Maybe ByteString, RequestBody) -> DAVT m ()
putContentM' (Maybe ByteString
ct, ByteString -> RequestBody
RequestBodyLBS ByteString
body)
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
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let ahs' = RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((CI ByteString, ByteString) -> RequestHeaders
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((CI ByteString, ByteString) -> RequestHeaders)
-> (ByteString -> (CI ByteString, ByteString))
-> ByteString
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"If") (ByteString -> (CI ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
parenthesize) (DAVContext
d DAVContext
-> Getting (Maybe ByteString) DAVContext (Maybe ByteString)
-> Maybe ByteString
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ByteString) DAVContext (Maybe ByteString)
Lens' DAVContext (Maybe ByteString)
lockToken)
let ahs = RequestHeaders
ahs' RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((CI ByteString, ByteString) -> RequestHeaders
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((CI ByteString, ByteString) -> RequestHeaders)
-> (ByteString -> (CI ByteString, ByteString))
-> ByteString
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) CI ByteString
hContentType) Maybe ByteString
ct
_ <- davRequest "PUT" ahs requestbody
return ()
delContentM :: MonadIO m => DAVT m ()
delContentM :: forall (m :: * -> *). MonadIO m => DAVT m ()
delContentM = do
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"DELETE" [] RequestBody
emptyBody
return ()
moveContentM :: MonadIO m => B.ByteString -> DAVT m ()
moveContentM :: forall (m :: * -> *). MonadIO m => ByteString -> DAVT m ()
moveContentM ByteString
newurl = do
let ahs :: RequestHeaders
ahs = [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"Destination", ByteString
newurl) ]
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"MOVE" RequestHeaders
ahs RequestBody
emptyBody
return ()
mkCol' :: MonadIO m => DAVT m ()
mkCol' :: forall (m :: * -> *). MonadIO m => DAVT m ()
mkCol' = do
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"MKCOL" [] RequestBody
emptyBody
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 = (HttpException -> Maybe ())
-> DAVT m Bool -> (() -> DAVT m Bool) -> DAVT m Bool
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust
(Status -> HttpException -> Maybe ()
matchStatusCodeException Status
conflict409)
(DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
mkCol' DAVT m () -> DAVT m Bool -> DAVT m Bool
forall a b. DAVT m a -> DAVT m b -> DAVT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> DAVT m Bool
forall a. a -> DAVT m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
(\()
_ -> Bool -> DAVT m Bool
forall a. a -> DAVT m a
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
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let ah' = (CI ByteString
hContentType, ByteString
"application/xml; charset=\"utf-8\"")
let ahs = (CI ByteString, ByteString)
ah'(CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((CI ByteString, ByteString) -> RequestHeaders
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((CI ByteString, ByteString) -> RequestHeaders)
-> (ByteString -> (CI ByteString, ByteString))
-> ByteString
-> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"If") (ByteString -> (CI ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
parenthesize) (DAVContext -> Maybe ByteString
_lockToken DAVContext
d)
_ <- davRequest "PROPPATCH" ahs ((RequestBodyLBS . props2patch) props)
return ()
props2patch :: XML.Document -> BL.ByteString
props2patch :: Document -> ByteString
props2patch = RenderSettings -> Document -> ByteString
XML.renderLBS RenderSettings
forall a. Default a => a
XML.def (Document -> ByteString)
-> (Document -> Document) -> Document -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Document
patch ([Node] -> Document)
-> (Document -> [Node]) -> Document -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor Node -> [Node]
props (Cursor Node -> [Node])
-> (Document -> Cursor Node) -> Document -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Cursor Node
fromDocument
where
props :: Cursor Node -> [Node]
props Cursor Node
cursor = (Cursor Node -> Node) -> [Cursor Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Cursor Node -> Node
forall node. Cursor node -> node
node (Cursor Node
cursor Cursor Node -> (Cursor Node -> [Cursor Node]) -> [Cursor Node]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}response" (Cursor Node -> [Cursor Node])
-> (Cursor Node -> [Cursor Node]) -> Cursor Node -> [Cursor Node]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}propstat" (Cursor Node -> [Cursor Node])
-> (Cursor Node -> [Cursor Node]) -> Cursor Node -> [Cursor Node]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor Node -> [Cursor Node]
element Name
"{DAV:}prop" (Cursor Node -> [Cursor Node])
-> (Cursor Node -> [Cursor Node]) -> Cursor Node -> [Cursor Node]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ (Name -> Bool) -> Cursor Node -> [Cursor Node]
forall b. Boolean b => (Name -> b) -> Cursor Node -> [Cursor Node]
checkName (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [Name] -> Bool) -> [Name] -> Name -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 [] Maybe Doctype
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 (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:set" Map Name Text
forall k a. Map k a
Map.empty
[ Element -> Node
XML.NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:prop" Map Name Text
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" ([(Name, Text)] -> Map Name Text
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\"")]
calrresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest ByteString
"REPORT" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
calendarquery)
return $ (XML.parseLBS_ XML.def . responseBody) calrresp
getOptionsOnce :: MonadIO m => DAVT m ()
getOptionsOnce :: forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce = DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
getOptions
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
DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
o <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
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 :: forall (m :: * -> *) a.
(MonadIO m, MonadBase IO m) =>
Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete Bool
nocreate DAVT m a
f = do
DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
o <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
when (supportsLocking o) (lockResource nocreate)
catchError f (\String
e -> Bool -> DAVT m () -> DAVT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
unlockResource DAVT m () -> DAVT m a -> DAVT m a
forall a b. DAVT m a -> DAVT m b -> DAVT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> DAVT m a
forall a. String -> DAVT m a
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 [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
root []
where
root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:propfind" ([(Name, Text)] -> Map Name Text
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 [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
root []
where
root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"D:lockinfo" ([(Name, Text)] -> Map Name Text
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 [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
root []
where
root :: Element
root = Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"C:calendar-query" ([(Name, Text)] -> Map Name Text
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">
|]
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
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let r = DAVContext
ctx DAVContext -> Getting Request DAVContext Request -> Request
forall s a. s -> Getting a s a -> a
^. Getting Request DAVContext Request
Lens' DAVContext Request
baseRequest
r' = Request
r { path = adjustpath r }
ctx' = (Request -> Identity Request) -> DAVContext -> Identity DAVContext
Lens' DAVContext Request
baseRequest ((Request -> Identity Request)
-> DAVContext -> Identity DAVContext)
-> Request -> DAVContext -> DAVContext
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Request
r' (DAVContext -> DAVContext) -> DAVContext -> DAVContext
forall a b. (a -> b) -> a -> b
$ DAVContext
ctx
lift $ either error return =<< (evalStateT . runExceptT . runDAVT) a ctx'
where
adjustpath :: Request -> ByteString
adjustpath = String -> ByteString
UTF8B.fromString (String -> ByteString)
-> (Request -> String) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Request -> String) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8B.toString (ByteString -> String)
-> (Request -> ByteString) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
path
getDAVLocation :: Monad m => DAVT m String
getDAVLocation :: forall (m :: * -> *). Monad m => DAVT m String
getDAVLocation = do
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
return (UTF8B.toString $ path $ ctx ^. baseRequest)