diff --git a/DAV.cabal b/DAV.cabal --- a/DAV.cabal +++ b/DAV.cabal @@ -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 diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs --- a/Network/Protocol/HTTP/DAV.hs +++ b/Network/Protocol/HTTP/DAV.hs @@ -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 _ _) diff --git a/hdav.hs b/hdav.hs --- a/hdav.hs +++ b/hdav.hs @@ -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