{-# 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 "hDav-using application"
#else
def = DAVContext [] def B.empty B.empty [] Nothing def Nothing "hDav-using application"
#endif
newtype DAVT m a = DAVT { DAVT m a -> ExceptT String (StateT DAVContext m) a
runDAVT :: ExceptT String (StateT DAVContext m) a }
deriving (Applicative (DAVT m)
DAVT m a
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)
DAVT m a -> DAVT m a -> DAVT m a
DAVT m a -> DAVT m [a]
DAVT m a -> DAVT m [a]
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 :: DAVT m a -> DAVT m [a]
$cmany :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [a]
some :: DAVT m a -> DAVT m [a]
$csome :: forall (m :: * -> *) a. Monad m => DAVT m a -> DAVT m [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 :: DAVT m a
$cempty :: forall (m :: * -> *) a. Monad m => DAVT m a
$cp1Alternative :: forall (m :: * -> *). Monad m => Applicative (DAVT m)
Alternative, Functor (DAVT m)
a -> DAVT m a
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)
DAVT m a -> DAVT m b -> DAVT m b
DAVT m a -> DAVT m b -> DAVT m a
DAVT m (a -> b) -> DAVT m a -> DAVT m b
(a -> b -> c) -> DAVT m a -> DAVT m b -> DAVT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> DAVT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (DAVT m)
Applicative, a -> DAVT m b -> DAVT m a
(a -> b) -> DAVT m a -> DAVT m b
(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
<$ :: a -> DAVT m b -> DAVT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> DAVT m b -> DAVT m a
fmap :: (a -> b) -> DAVT m a -> DAVT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> DAVT m a -> DAVT m b
Functor, Applicative (DAVT m)
a -> DAVT m a
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)
DAVT m a -> (a -> DAVT m b) -> DAVT m b
DAVT m a -> DAVT m b -> DAVT m b
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 :: a -> DAVT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> DAVT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (DAVT m)
Monad, MonadBase b, MonadError String, Monad (DAVT m)
Monad (DAVT m) =>
(forall a. (a -> DAVT m a) -> DAVT m a) -> MonadFix (DAVT m)
(a -> DAVT m a) -> DAVT m a
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 :: (a -> DAVT m a) -> DAVT m a
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> DAVT m a) -> DAVT m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (DAVT m)
MonadFix, Monad (DAVT m)
Monad (DAVT m) => (forall a. IO a -> DAVT m a) -> MonadIO (DAVT m)
IO a -> DAVT m a
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 :: IO a -> DAVT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> DAVT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (DAVT m)
MonadIO, Monad (DAVT m)
Alternative (DAVT m)
DAVT m a
(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)
DAVT m a -> DAVT m a -> DAVT m a
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 :: 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 :: DAVT m a
$cmzero :: forall (m :: * -> *) a. Monad m => DAVT m a
$cp2MonadPlus :: forall (m :: * -> *). Monad m => Monad (DAVT m)
$cp1MonadPlus :: forall (m :: * -> *). Monad m => Alternative (DAVT m)
MonadPlus, MonadState DAVContext)
instance MonadCatch m => MonadCatch (DAVT m) where
catch :: DAVT m a -> (e -> DAVT m a) -> DAVT m a
catch (DAVT m :: ExceptT String (StateT DAVContext m) a
m) f :: 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 (m :: * -> *) e a.
(MonadCatch m, 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 :: e -> DAVT m a
throwM = 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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
instance MonadTrans DAVT where
lift :: 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 (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 (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 :: String -> DAVT m a -> m (Either String a)
evalDAVT u :: String
u f :: DAVT m a
f = do
DAVContext
ctx <- String -> m DAVContext
forall (m :: * -> *). MonadIO m => String -> m DAVContext
mkDAVContext String
u
Either String a
r <- (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a))
-> (DAVT m a -> StateT DAVContext m (Either String a))
-> DAVT m a
-> DAVContext
-> m (Either String a)
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
DAVContext -> m ()
forall (m :: * -> *). MonadIO m => DAVContext -> m ()
closeDAVContext DAVContext
ctx
Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
r
mkDAVContext :: MonadIO m => DAVURL -> m DAVContext
mkDAVContext :: String -> m DAVContext
mkDAVContext u :: String
u = IO DAVContext -> m DAVContext
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
Manager
mgr <- IO Manager -> IO Manager
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)
Request
req <- IO Request -> IO Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> IO Request) -> IO Request -> IO Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
u
#else
req <- liftIO $ parseUrl u
#endif
DAVContext -> IO DAVContext
forall (m :: * -> *) a. Monad m => a -> m a
return (DAVContext -> IO DAVContext) -> DAVContext -> IO DAVContext
forall a b. (a -> b) -> a -> b
$ DAVContext
forall a. Default a => a
def { _baseRequest :: Request
_baseRequest = Request
req, _httpManager :: Maybe Manager
_httpManager = Manager -> Maybe Manager
forall a. a -> Maybe a
Just Manager
mgr }
{-# DEPRECATED closeDAVContext "deprecated because http-client deprecated closeManager" #-}
closeDAVContext :: MonadIO m => DAVContext -> m ()
closeDAVContext :: DAVContext -> m ()
closeDAVContext _ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
withDAVContext :: MonadIO m => DAVURL -> (DAVContext -> m a) -> m a
withDAVContext :: String -> (DAVContext -> m a) -> m a
withDAVContext u :: String
u f :: 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 (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 :: DAVContext -> DAVT m a -> m (Either String a, DAVContext)
runDAVContext ctx :: DAVContext
ctx f :: 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 :: ByteString -> ByteString -> DAVT m ()
setCreds u :: ByteString
u p :: 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 (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 :: Maybe Depth -> DAVT m ()
setDepth d :: 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 :: ByteString -> DAVT m ()
setUserAgent ua :: 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 :: Maybe Int -> DAVT m ()
setResponseTimeout rt :: 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 ()
%= \x :: Request
x -> Request
x { responseTimeout :: ResponseTimeout
responseTimeout = ResponseTimeout
-> (Int -> ResponseTimeout) -> Maybe Int -> 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 :: ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest meth :: ByteString
meth addlhdrs :: RequestHeaders
addlhdrs rbody :: RequestBody
rbody = do
DAVContext
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let hdrs :: RequestHeaders
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 "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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "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 :: Request
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 :: ByteString
method = ByteString
meth, requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdrs, requestBody :: RequestBody
requestBody = RequestBody
rbody }
authreq :: Request
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
Request -> DAVT m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
authreq
davRequest :: MonadIO m => Method -> RequestHeaders -> RequestBody -> DAVT m (Response BL.ByteString)
davRequest :: ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest meth :: ByteString
meth addlhdrs :: RequestHeaders
addlhdrs rbody :: 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 req :: Request
req = do
DAVContext
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
DAVT m (Response ByteString)
-> (Manager -> DAVT m (Response ByteString))
-> Maybe Manager
-> DAVT m (Response ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExceptT String (StateT DAVContext m) (Response ByteString)
-> DAVT m (Response ByteString)
forall (m :: * -> *) a.
ExceptT String (StateT DAVContext m) a -> DAVT m a
DAVT (ExceptT String (StateT DAVContext m) (Response ByteString)
-> DAVT m (Response ByteString))
-> ExceptT String (StateT DAVContext m) (Response ByteString)
-> DAVT m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> ExceptT String (StateT DAVContext m) (Response ByteString)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE "Can't perform request without manager") (IO (Response ByteString) -> DAVT m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> DAVT m (Response ByteString))
-> (Manager -> IO (Response ByteString))
-> Manager
-> DAVT m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Response ByteString)
httpLbs Request
req) (DAVContext
ctx DAVContext
-> Getting (Maybe Manager) DAVContext (Maybe Manager)
-> Maybe Manager
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Manager) DAVContext (Maybe Manager)
Lens' DAVContext (Maybe Manager)
httpManager)
matchStatusCodeException :: Status -> HttpException -> Maybe ()
#if MIN_VERSION_http_client(0,5,0)
matchStatusCodeException :: Status -> HttpException -> Maybe ()
matchStatusCodeException want :: Status
want (HttpExceptionRequest _ (StatusCodeException resp :: Response ()
resp _))
| 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 _ _ = 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 :: DAVT m ()
getOptions = do
Response ByteString
optresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "OPTIONS" [] RequestBody
emptyBody
let meths :: [ByteString]
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) ',') (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 "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 :: [ByteString]
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) ',') (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 "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
([ByteString] -> Identity [ByteString])
-> DAVContext -> Identity DAVContext
Lens' DAVContext [ByteString]
complianceClasses (([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]
cclass
([ByteString] -> Identity [ByteString])
-> DAVContext -> Identity DAVContext
Lens' DAVContext [ByteString]
allowedMethods (([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]
meths
lockResource :: MonadIO m => Bool -> DAVT m ()
lockResource :: Bool -> DAVT m ()
lockResource nocreate :: Bool
nocreate = do
let ahs' :: RequestHeaders
ahs' = [(CI ByteString
hContentType, "application/xml; charset=\"utf-8\""), (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "Depth", "0"), (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "Timeout", "Second-300")]
let ahs :: RequestHeaders
ahs = if Bool
nocreate then (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "If-Match", "*")(CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:RequestHeaders
ahs' else RequestHeaders
ahs'
Response ByteString
lockresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "LOCK" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
locky)
let hdrtoken :: Maybe ByteString
hdrtoken = (CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "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
(Maybe ByteString -> Identity (Maybe ByteString))
-> DAVContext -> Identity DAVContext
Lens' DAVContext (Maybe ByteString)
lockToken ((Maybe ByteString -> Identity (Maybe ByteString))
-> DAVContext -> Identity DAVContext)
-> Maybe ByteString -> DAVT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe ByteString
hdrtoken
unlockResource :: MonadIO m => DAVT m ()
unlockResource :: DAVT m ()
unlockResource = do
DAVContext
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
case DAVContext -> Maybe ByteString
_lockToken DAVContext
d of
Nothing -> () -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just tok :: ByteString
tok -> do let ahs :: RequestHeaders
ahs = [(ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "Lock-Token", ByteString
tok)]
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "UNLOCK" RequestHeaders
ahs RequestBody
emptyBody
(Maybe ByteString -> Identity (Maybe ByteString))
-> DAVContext -> Identity DAVContext
Lens' DAVContext (Maybe ByteString)
lockToken ((Maybe ByteString -> Identity (Maybe ByteString))
-> DAVContext -> Identity DAVContext)
-> Maybe ByteString -> DAVT m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe ByteString
forall a. Maybe a
Nothing
supportsLocking :: DAVContext -> Bool
supportsLocking :: DAVContext -> Bool
supportsLocking = (Bool -> Bool -> Bool)
-> ([ByteString] -> Bool)
-> ([ByteString] -> Bool)
-> [ByteString]
-> Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) ("LOCK" ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ("UNLOCK" ByteString -> [ByteString] -> 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 :: DAVT m Document
getPropsM = do
let ahs :: RequestHeaders
ahs = [(CI ByteString
hContentType, "application/xml; charset=\"utf-8\"")]
Response ByteString
propresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "PROPFIND" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
propname)
Document -> DAVT m Document
forall (m :: * -> *) a. Monad m => a -> m a
return (Document -> DAVT m Document) -> Document -> DAVT m Document
forall a b. (a -> b) -> a -> b
$ (ParseSettings -> ByteString -> Document
XML.parseLBS_ ParseSettings
forall a. Default a => a
XML.def (ByteString -> Document)
-> (Response ByteString -> ByteString)
-> Response ByteString
-> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall body. Response body -> body
responseBody) Response ByteString
propresp
getContentM :: MonadIO m => DAVT m (Maybe B.ByteString, BL.ByteString)
getContentM :: DAVT m (Maybe ByteString, ByteString)
getContentM = do
Response ByteString
resp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "GET" [] RequestBody
emptyBody
let ct :: Maybe ByteString
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)
(Maybe ByteString, ByteString)
-> DAVT m (Maybe ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp)
withContentM :: MonadIO m => (Response BodyReader -> IO a) -> DAVT m a
withContentM :: (Response BodyReader -> IO a) -> DAVT m a
withContentM handleresponse :: Response BodyReader -> IO a
handleresponse = do
Request
req <- ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
forall (m :: * -> *).
MonadIO m =>
ByteString -> RequestHeaders -> RequestBody -> DAVT m Request
mkDavRequest "GET" [] RequestBody
emptyBody
DAVContext
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
DAVT m a -> (Manager -> DAVT m a) -> Maybe Manager -> DAVT m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
$ String -> ExceptT String (StateT DAVContext m) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE "Can't handle response without manager") (\mgr :: Manager
mgr -> 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) (DAVContext
ctx DAVContext
-> Getting (Maybe Manager) DAVContext (Maybe Manager)
-> Maybe Manager
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Manager) DAVContext (Maybe Manager)
Lens' DAVContext (Maybe Manager)
httpManager)
putContentM :: MonadIO m => (Maybe B.ByteString, BL.ByteString) -> DAVT m ()
putContentM :: (Maybe ByteString, ByteString) -> DAVT m ()
putContentM (ct :: Maybe ByteString
ct, body :: 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' :: (Maybe ByteString, RequestBody) -> DAVT m ()
putContentM' (ct :: Maybe ByteString
ct, requestbody :: RequestBody
requestbody) = do
DAVContext
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let ahs' :: RequestHeaders
ahs' = RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((CI ByteString, ByteString) -> RequestHeaders
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 "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
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 (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
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "PUT" RequestHeaders
ahs RequestBody
requestbody
() -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
delContentM :: MonadIO m => DAVT m ()
delContentM :: DAVT m ()
delContentM = do
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "DELETE" [] RequestBody
emptyBody
() -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
moveContentM :: MonadIO m => B.ByteString -> DAVT m ()
moveContentM :: ByteString -> DAVT m ()
moveContentM newurl :: ByteString
newurl = do
let ahs :: RequestHeaders
ahs = [ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "Destination", ByteString
newurl) ]
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "MOVE" RequestHeaders
ahs RequestBody
emptyBody
() -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkCol' :: MonadIO m => DAVT m ()
mkCol' :: DAVT m ()
mkCol' = do
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "MKCOL" [] RequestBody
emptyBody
() -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkCol :: (MonadIO m, MonadBase IO m, MonadCatch m) => DAVT m Bool
mkCol :: DAVT m Bool
mkCol = (HttpException -> Maybe ())
-> DAVT m Bool -> (() -> DAVT m Bool) -> DAVT m Bool
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)
(DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
mkCol' DAVT m () -> DAVT m Bool -> DAVT m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> DAVT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
(\_ -> Bool -> DAVT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
parenthesize :: B.ByteString -> B.ByteString
parenthesize :: ByteString -> ByteString
parenthesize x :: ByteString
x = [ByteString] -> ByteString
B.concat ["(", ByteString
x, ")"]
putPropsM :: MonadIO m => XML.Document -> DAVT m ()
putPropsM :: Document -> DAVT m ()
putPropsM props :: Document
props = do
DAVContext
d <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let ah' :: (CI ByteString, ByteString)
ah' = (CI ByteString
hContentType, "application/xml; charset=\"utf-8\"")
let ahs :: RequestHeaders
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 (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 "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)
Response ByteString
_ <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "PROPPATCH" RequestHeaders
ahs ((ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody)
-> (Document -> ByteString) -> Document -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> ByteString
props2patch) Document
props)
() -> DAVT m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: 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 "{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 "{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 "{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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Name]
blacklist))
patch :: [Node] -> Document
patch prop :: [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 prop :: [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 "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 "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 "D:propertyupdate" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [("xmlns:D", "DAV:")])
blacklist :: [Name]
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 :: DAVT m Document
caldavReportM = do
let ahs :: RequestHeaders
ahs = [(CI ByteString
hContentType, "application/xml; charset=\"utf-8\"")]
Response ByteString
calrresp <- ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
ByteString
-> RequestHeaders -> RequestBody -> DAVT m (Response ByteString)
davRequest "REPORT" RequestHeaders
ahs (Document -> RequestBody
xmlBody Document
calendarquery)
Document -> DAVT m Document
forall (m :: * -> *) a. Monad m => a -> m a
return (Document -> DAVT m Document) -> Document -> DAVT m Document
forall a b. (a -> b) -> a -> b
$ (ParseSettings -> ByteString -> Document
XML.parseLBS_ ParseSettings
forall a. Default a => a
XML.def (ByteString -> Document)
-> (Response ByteString -> ByteString)
-> Response ByteString
-> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall body. Response body -> body
responseBody) Response ByteString
calrresp
getOptionsOnce :: MonadIO m => DAVT m ()
getOptionsOnce :: 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 :: Bool -> DAVT m a -> DAVT m a
withLockIfPossible nocreate :: Bool
nocreate f :: DAVT m a
f = do
DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
DAVContext
o <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
Bool -> DAVT m () -> DAVT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) (Bool -> DAVT m ()
forall (m :: * -> *). MonadIO m => Bool -> DAVT m ()
lockResource Bool
nocreate)
a
res <- DAVT m a
f
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
a -> DAVT m a
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 :: Bool -> DAVT m a -> DAVT m a
withLockIfPossibleForDelete nocreate :: Bool
nocreate f :: DAVT m a
f = do
DAVT m ()
forall (m :: * -> *). MonadIO m => DAVT m ()
getOptionsOnce
DAVContext
o <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
Bool -> DAVT m () -> DAVT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DAVContext -> Bool
supportsLocking DAVContext
o) (Bool -> DAVT m ()
forall (m :: * -> *). MonadIO m => Bool -> DAVT m ()
lockResource Bool
nocreate)
DAVT m a -> (String -> DAVT m a) -> DAVT m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError DAVT m a
f (\e :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 "D:propfind" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [("xmlns:D", "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 "D:lockinfo" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [("xmlns:D", "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 "C:calendar-query" ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
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 :: (String -> String) -> DAVT m a -> DAVT m a
inDAVLocation f :: String -> String
f a :: DAVT m a
a = do
DAVContext
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
let r :: Request
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' = Request
r { path :: ByteString
path = Request -> ByteString
adjustpath Request
r }
ctx' :: DAVContext
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
m a -> DAVT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DAVT m a) -> m a -> DAVT m a
forall a b. (a -> b) -> a -> b
$ (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m a
forall a. HasCallStack => String -> a
error a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m a) -> m (Either String a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT DAVContext m (Either String a)
-> DAVContext -> m (Either String a))
-> (DAVT m a -> StateT DAVContext m (Either String a))
-> DAVT m a
-> DAVContext
-> m (Either String a)
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
a DAVContext
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 :: DAVT m String
getDAVLocation = do
DAVContext
ctx <- DAVT m DAVContext
forall s (m :: * -> *). MonadState s m => m s
get
String -> DAVT m String
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
UTF8B.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
path (Request -> ByteString) -> Request -> ByteString
forall a b. (a -> b) -> a -> b
$ 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)