diff --git a/DAV.cabal b/DAV.cabal --- a/DAV.cabal +++ b/DAV.cabal @@ -1,5 +1,5 @@ name: DAV -version: 1.2 +version: 1.3 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-2015 Clint Adams +copyright: Copyright (C) 2012-2016 Clint Adams category: Web build-type: Simple cabal-version: >=1.8 @@ -25,6 +25,10 @@ description: Get Network.URI from the network-uri package default: True +flag mtl-compat + description: Get Control.Monad.Except from the mtl-compat package + default: False + library exposed-modules: Network.Protocol.HTTP.DAV other-modules: Network.Protocol.HTTP.DAV.TH @@ -39,14 +43,17 @@ , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 - , mtl >= 2.1 - , mtl-compat , transformers >= 0.3 , transformers-base , transformers-compat >= 0.3 , utf8-string , xml-conduit >= 1.0 , xml-hamlet >= 0.4 && < 0.5 + if flag(mtl-compat) + build-depends: mtl >= 2.1 && < 2.2.1, mtl-compat + else + build-depends: mtl >= 2.2.1 + executable hdav main-is: hdav.hs ghc-options: -Wall @@ -57,12 +64,11 @@ , containers , data-default , exceptions >= 0.7 + , haskeline , http-client >= 0.4 , http-client-tls >= 0.2 , http-types >= 0.7 , lens >= 3.0 - , mtl >= 2.1 - , mtl-compat , optparse-applicative >= 0.10.0 , transformers >= 0.3 , transformers-base @@ -70,6 +76,10 @@ , utf8-string , xml-conduit >= 1.0 , xml-hamlet >= 0.4 && < 0.5 + if flag(mtl-compat) + build-depends: mtl >= 2.1 && < 2.2.1, mtl-compat + else + build-depends: mtl >= 2.2.1 if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else @@ -83,4 +93,4 @@ source-repository this type: git location: git://anonscm.debian.org/users/clint/DAV.git - tag: DAV/1.2 + tag: DAV/1.3 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-2015 Clint Adams +-- Copyright © 2012-2016 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -19,7 +19,7 @@ {-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts, QuasiQuotes, RankNTypes, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, - TypeFamilies #-} + TypeFamilies, CPP #-} module Network.Protocol.HTTP.DAV ( DAVT(..) @@ -52,12 +52,15 @@ import Network.Protocol.HTTP.DAV.TH -import Control.Applicative (liftA2, Alternative, Applicative) +#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 (bracket, bracketOnError, catchJust, finally, throwM, mask, uninterruptibleMask, MonadCatch, MonadThrow) +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) @@ -76,7 +79,7 @@ import Network.HTTP.Client (RequestBody(..), httpLbs, parseUrl, applyBasicAuth, Request(..), Response(..), newManager, HttpException(..), BodyReader, withResponse, path) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409) +import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, conflict409) import qualified Text.XML as XML import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName) diff --git a/hdav.hs b/hdav.hs --- a/hdav.hs +++ b/hdav.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} - -- hdav.hs: WebDAV client --- Copyright © 2012-2014 Clint Adams +-- Copyright © 2012-2016 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -18,20 +16,23 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -import qualified Data.ByteString.Char8 as BC8 +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} import Paths_DAV (version) -import Control.Applicative ((<$>),(<*>), optional, pure) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.UTF8 as BU +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>),(<*>), pure) +#endif +import Control.Applicative (optional) import Control.Monad (liftM2, unless) import Control.Monad.IO.Class (MonadIO) import Data.Version (showVersion) -import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Text.XML (renderLBS, def) -import qualified Data.ByteString.Lazy.Char8 as B import Network (withSocketsDo) - import Network.URI (normalizePathSegments) import Network.Protocol.HTTP.DAV (DAVT, evalDAVT, setCreds, setDepth, setUserAgent, getPropsM, getContentM, putContentM, putPropsM, delContentM, moveContentM, mkCol, Depth(..), caldavReportM, withLockIfPossible, withLockIfPossibleForDelete) @@ -40,13 +41,18 @@ import Options.Applicative.Extra (customExecParser) import Options.Applicative.Types (Parser) +import System.Console.Haskeline (runInputT, getPassword) +import qualified System.Console.Haskeline as SCH + +import Text.XML (renderLBS, def) + data Options = Options { url :: String , url2 :: String - , username :: String - , password :: String - , username2 :: String - , password2 :: String + , username :: Maybe String + , password :: Maybe String + , username2 :: Maybe String + , password2 :: Maybe String } data Command = Copy Options | Move Options | Delete Options | MakeCollection Options | GetProps Options (Maybe Depth) | Put FilePath Options | CaldavReport Options @@ -55,104 +61,108 @@ oneUUP = Options <$> argument str ( metavar "URL" ) <*> pure "" - <*> (fromMaybe "" <$> (optional $ strOption + <*> (optional $ strOption ( long "username" <> metavar "USERNAME" - <> help "username for URL" ))) - <*> (fromMaybe "" <$> (optional $ strOption + <> help "username for URL" )) + <*> (optional $ strOption ( long "password" <> metavar "PASSWORD" - <> help "password for URL" ))) - <*> pure "" - <*> pure "" + <> help "password for URL" )) + <*> pure Nothing + <*> pure Nothing twoUUP :: Parser Options twoUUP = Options <$> argument str ( metavar "SOURCEURL" ) <*> argument str ( metavar "TARGETURL" ) - <*> (fromMaybe "" <$> (optional $ strOption + <*> (optional $ strOption ( long "source-username" <> metavar "USERNAME" - <> help "username for source URL" ))) - <*> (fromMaybe "" <$> (optional $ strOption + <> help "username for source URL" )) + <*> (optional $ strOption ( long "source-password" <> metavar "PASSWORD" - <> help "password for source URL" ))) - <*> (fromMaybe "" <$> (optional $ strOption + <> help "password for source URL" )) + <*> (optional $ strOption ( long "target-username" <> metavar "USERNAME" - <> help "username for target URL" ))) - <*> (fromMaybe "" <$> (optional $ strOption + <> help "username for target URL" )) + <*> (optional $ strOption ( long "target-password" <> metavar "PASSWORD" - <> help "password for target URL" ))) + <> help "password for target URL" )) twoUoneUP :: Parser Options twoUoneUP = Options <$> argument str ( metavar "SOURCEURL" ) <*> argument str ( metavar "TARGETURL" ) - <*> (fromMaybe "" <$> (optional $ strOption + <*> (optional $ strOption ( long "username" <> metavar "USERNAME" - <> help "username for URL" ))) - <*> (fromMaybe "" <$> (optional $ strOption + <> help "username for URL" )) + <*> (optional $ strOption ( long "password" <> metavar "PASSWORD" - <> help "password for URL" ))) - <*> pure "" - <*> pure "" + <> help "password for URL" )) + <*> pure Nothing + <*> pure Nothing doCopy :: Options -> IO () doCopy o = do + (sourceUsername, sourcePassword) <- ingestCreds ("source URL " ++ sourceurl) (username o) (password o) + (targetUsername, targetPassword) <- ingestCreds ("target URL " ++ targeturl) (username2 o) (password2 o) (p, b) <- runDAV sourceurl $ setCreds sourceUsername sourcePassword >> setDepth (Just Depth0) >> withLockIfPossible True (liftM2 (,) getPropsM getContentM) runDAV targeturl $ setCreds targetUsername targetPassword >> withLockIfPossible False (putContentM b >> putPropsM p) where sourceurl = url o targeturl = url2 o - sourceUsername = BC8.pack $ username o - sourcePassword = BC8.pack $ password o - targetUsername = BC8.pack $ username2 o - targetPassword = BC8.pack $ password2 o doDelete :: Options -> IO () -doDelete o = runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> withLockIfPossibleForDelete False delContentM +doDelete o = do + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + runDAV (url o) $ setCreds u p >> withLockIfPossibleForDelete False delContentM doMove :: Options -> IO () -doMove o = runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> moveContentM (BC8.pack $ url2 o) +doMove o = do + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + runDAV (url o) $ setCreds u p >> moveContentM (BU.fromString $ url2 o) doMakeCollection :: Options -> IO () -doMakeCollection o = go (url o) +doMakeCollection o = do + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + go (url o) (u, p) where - u = BC8.pack . username $ o - p = BC8.pack . password $ o - - go url' = do - ok <- makeCollection url' + go url' (u, p) = do + ok <- makeCollection url' (u, p) unless ok $ do - go (parent url') - ok' <- makeCollection url' + go (parent url') (u, p) + ok' <- makeCollection url' (u, p) unless ok' $ error $ "failed creating " ++ url' parent url' = reverse $ dropWhile (== '/')$ reverse $ normalizePathSegments (url' ++ "/..") - makeCollection url' = runDAV url' $ setCreds u p >> mkCol + makeCollection url' (u, p) = runDAV url' $ setCreds u p >> mkCol doGetProps :: Options -> Maybe Depth -> IO () doGetProps o md = do - doc <- runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> setDepth md >> getPropsM - B.putStrLn (renderLBS def doc) + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + doc <- runDAV (url o) $ setCreds u p >> setDepth md >> getPropsM + BL.putStr (renderLBS def doc) doPut :: FilePath -> Options -> IO () doPut file o = do - bs <- B.readFile file - runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> putContentM (Nothing, bs) + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + bs <- BL.readFile file + runDAV (url o) $ setCreds u p >> putContentM (Nothing, bs) doReport :: Options -> IO () doReport o = do - doc <- runDAV (url o) $ setCreds (BC8.pack $ username o) (BC8.pack $ password o) >> setDepth (Just Depth1) >> caldavReportM - B.putStrLn (renderLBS def doc) + (u, p) <- ingestCreds ("URL " ++ url o) (username o) (password o) + doc <- runDAV (url o) $ setCreds u p >> setDepth (Just Depth1) >> caldavReportM + BL.putStr (renderLBS def doc) dispatch :: Command -> IO () dispatch (Copy o) = doCopy o @@ -165,10 +175,11 @@ main :: IO () main = withSocketsDo $ do - 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" + putStrLn $ concat [ + "hDAV version ", showVersion version, ", Copyright (C) 2012-2016 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"] customExecParser (prefs showHelpOnError) (info cmd idm) >>= dispatch @@ -187,6 +198,13 @@ depth = option auto ( long "depth" <> metavar "DEPTH" <> help "depth" ) :: Parser Depth runDAV :: MonadIO m => String -> DAVT m a -> m a -runDAV u f = evalDAVT u (setUserAgent (BC8.pack $ "hDAV/" ++ showVersion version) >> f) >>= \x -> case x of +runDAV u f = evalDAVT u (setUserAgent (BU.fromString $ "hDAV/" ++ showVersion version) >> f) >>= \x -> case x of Left e -> error e Right r -> return r + +ingestCreds :: String -> Maybe String -> Maybe String -> IO (B.ByteString, B.ByteString) +ingestCreds _ Nothing _ = return (B.empty, B.empty) +ingestCreds _ (Just u) (Just p) = return (BU.fromString u, BU.fromString p) +ingestCreds q (Just u) Nothing = do + mnewp <- runInputT SCH.defaultSettings $ getPassword (Just '*') (concat ["Password for ", u, " at ", q, ": "]) + return (BU.fromString u, maybe B.empty BU.fromString mnewp)