DAV 0.6 → 0.6.1
raw patch · 3 files changed
+25/−20 lines, 3 filesdep +eitherdep +errorsdep ~monad-controldep ~optparse-applicative
Dependencies added: either, errors
Dependency ranges changed: monad-control, optparse-applicative
Files
- DAV.cabal +10/−6
- Network/Protocol/HTTP/DAV.hs +10/−9
- hdav.hs +5/−5
DAV.cabal view
@@ -1,5 +1,5 @@ name: DAV-version: 0.6+version: 0.6.1 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning@@ -15,7 +15,7 @@ license-file: LICENSE author: Clint Adams maintainer: clint@debian.org-copyright: Copyright (C) 2012-2013 Clint Adams+copyright: Copyright (C) 2012-2014 Clint Adams category: Web build-type: Simple cabal-version: >=1.8@@ -29,12 +29,14 @@ , bytestring , case-insensitive >= 0.4 , containers+ , either >= 4.1+ , errors , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 , lifted-base >= 0.1- , monad-control+ , monad-control >= 0.3.2 , mtl >= 2.1 , transformers >= 0.3 , transformers-base@@ -48,15 +50,17 @@ , bytestring , case-insensitive >= 0.4 , containers+ , either >= 4.1+ , errors , http-client >= 0.2 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 , lifted-base >= 0.1- , monad-control+ , monad-control >= 0.3.2 , mtl >= 2.1 , network >= 2.3- , optparse-applicative+ , optparse-applicative >= 0.5.0 , transformers >= 0.3 , transformers-base , xml-conduit >= 1.0 && <= 1.2@@ -70,4 +74,4 @@ source-repository this type: git location: git://anonscm.debian.org/users/clint/DAV.git- tag: DAV/0.6+ tag: DAV/0.6.1
Network/Protocol/HTTP/DAV.hs view
@@ -1,5 +1,5 @@ -- DAV.hs: WebDAV client library--- Copyright © 2012-2013 Clint Adams+-- Copyright © 2012-2014 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -53,11 +53,12 @@ import Network.Protocol.HTTP.DAV.TH import Control.Applicative (liftA2, Applicative)+import Control.Error (EitherT(..)) import Control.Exception.Lifted (catchJust, finally, bracketOnError) import Control.Lens ((^.), (.=), (%=)) import Control.Monad (liftM, liftM2, when, MonadPlus) import Control.Monad.Base (MonadBase(..))-import Control.Monad.Error (ErrorT, MonadError, runErrorT)+import Control.Monad.Error (MonadError) import Control.Monad.Fix (MonadFix) import Control.Monad.Trans (lift, MonadTrans) import Control.Monad.IO.Class (liftIO, MonadIO)@@ -81,11 +82,11 @@ import Data.CaseInsensitive (mk) -newtype DAVT m a = DAVT { runDAVT :: ErrorT String (StateT DAVContext m) a }+newtype DAVT m a = DAVT { runDAVT :: EitherT String (StateT DAVContext m) a } deriving (Applicative, Functor, Monad, MonadBase b, MonadError String, MonadFix, MonadIO, MonadPlus, MonadState DAVContext) instance MonadBaseControl b m => MonadBaseControl b (DAVT m) where- newtype StM (DAVT m) a = StDAVT { unStDAVT :: StM (ErrorT String (StateT DAVContext m)) a }+ newtype StM (DAVT m) a = StDAVT { unStDAVT :: StM (EitherT String (StateT DAVContext m)) a } liftBaseWith f = DAVT . liftBaseWith $ \r -> f $ liftM StDAVT . r . runDAVT restoreM = DAVT . restoreM . unStDAVT @@ -96,7 +97,7 @@ evalDAVT u f = do mgr <- liftIO $ newManager tlsManagerSettings req <- liftIO $ parseUrl u- r <- (evalStateT . runErrorT . runDAVT) f $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application"+ r <- (evalStateT . runEitherT . runDAVT) f $ DAVContext [] req B.empty B.empty [] Nothing mgr Nothing "hDav-using application" liftIO $ closeManager mgr return r @@ -127,10 +128,10 @@ , fmap ((,) (mk "Depth") . BC8.pack . show) (ctx ^. depth) ] ++ addlhdrs req = (ctx ^. baseRequest) { method = meth, requestHeaders = hdrs, requestBody = rbody }- authreq = applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req- liftIO (catchJust (matchStatusCodeException unauthorized401)- (httpLbs req (ctx ^. httpManager))- (\_ -> httpLbs authreq (ctx ^. httpManager)))+ authreq = if B.null (ctx ^. basicusername) && B.null (ctx ^. basicpassword)+ then req+ else applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req+ liftIO (httpLbs authreq (ctx ^. httpManager)) matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _)
hdav.hs view
@@ -1,5 +1,5 @@ -- hdav.hs: WebDAV client--- Copyright © 2012-2013 Clint Adams+-- Copyright © 2012-2014 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -34,8 +34,8 @@ import Network.Protocol.HTTP.DAV (DAVT, evalDAVT, setCreds, setDepth, setUserAgent, getPropsM, getContentM, putContentM, putPropsM, delContentM, moveContentM, mkCol, Depth(..), caldavReportM, withLockIfPossible, withLockIfPossibleForDelete) -import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, option, progDesc, str, strOption, subparser)-import Options.Applicative.Extra (execParser)+import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, option, prefs, progDesc, showHelpOnError, str, strOption, subparser)+import Options.Applicative.Extra (customExecParser) import Options.Applicative.Types (Parser) data Options = Options {@@ -163,12 +163,12 @@ main :: IO () main = withSocketsDo $ do- putStrLn $ "hDAV version " ++ showVersion version ++ ", Copyright (C) 2012-2013 Clint Adams\n\+ putStrLn $ "hDAV version " ++ showVersion version ++ ", Copyright (C) 2012-2014 Clint Adams\n\ \hDAV comes with ABSOLUTELY NO WARRANTY.\n\ \This is free software, and you are welcome to redistribute it\n\ \under certain conditions.\n" - execParser (info cmd idm) >>= dispatch+ customExecParser (prefs showHelpOnError) (info cmd idm) >>= dispatch cmd :: Parser Command cmd = subparser