diff --git a/DAV.cabal b/DAV.cabal --- a/DAV.cabal +++ b/DAV.cabal @@ -1,5 +1,5 @@ name: DAV -version: 0.3.1 +version: 0.4 synopsis: RFC 4918 WebDAV support description: This is a library for the Web Distributed Authoring and Versioning @@ -45,7 +45,6 @@ , bytestring , bytestring , case-insensitive >= 0.4 - , cmdargs >= 0.9 , containers , http-conduit >= 1.9.0 , http-types >= 0.7 @@ -53,6 +52,7 @@ , lifted-base >= 0.1 , mtl >= 2.1 , network >= 2.3 + , optparse-applicative , resourcet >= 0.3 , transformers >= 0.3 , xml-conduit >= 1.0 && <= 1.2 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 @@ -28,9 +28,11 @@ , deleteContent , moveContent , makeCollection + , caldavReport , module Network.Protocol.HTTP.DAV.TH ) where +import Paths_DAV (version) import Network.Protocol.HTTP.DAV.TH import Control.Applicative (liftA2) @@ -42,10 +44,12 @@ import Control.Monad.Trans.State.Lazy (evalStateT, StateT, get, modify) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Version (showVersion) import Network.HTTP.Conduit (httpLbs, parseUrl, applyBasicAuth, Request(..), RequestBody(..), Response(..), newManager, closeManager, ManagerSettings(..), def, HttpException(..)) import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unauthorized401, conflict409) @@ -58,25 +62,29 @@ type DAVState m a = StateT (DAVContext m) (ResourceT m) a -initialDS :: String -> B.ByteString -> B.ByteString -> ManagerSettings -> IO (DAVContext a) -initialDS u username password s = do +initialDS :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> ManagerSettings -> IO (DAVContext a) +initialDS u username password md s = do mgr <- newManager s req <- parseUrl u - return $ DAVContext [] req [] mgr Nothing username password + return $ DAVContext [] req [] mgr Nothing username password md closeDS :: DAVContext a -> IO () closeDS = closeManager . _httpManager -withDS :: MonadResourceBase m => String -> B.ByteString -> B.ByteString -> DAVState m a -> m a -withDS url username password f = runResourceT $ do - (_, ds) <- allocate (initialDS url username password def) closeDS +withDS :: MonadResourceBase m => String -> B.ByteString -> B.ByteString -> Maybe Depth -> DAVState m a -> m a +withDS url username password md f = runResourceT $ do + (_, ds) <- allocate (initialDS url username password md def) closeDS evalStateT f ds davRequest :: MonadResourceBase m => Method -> RequestHeaders -> RequestBody (ResourceT m) -> DAVState m (Response BL.ByteString) davRequest meth addlhdrs rbody = do ctx <- get - let req = (ctx ^. baseRequest) { method = meth, requestHeaders = (mk "User-Agent", "hDav 9.0"):addlhdrs, requestBody = rbody } - let authreq = applyBasicAuth (ctx ^. basicusername) (ctx ^. basicpassword) req + let hdrs = catMaybes + [ Just (mk "User-Agent", (BC8.pack ("hDav " ++ showVersion version))) + , 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 resp <- lift (catchJust (matchStatusCodeException unauthorized401) (httpLbs req (ctx ^. httpManager)) (\_ -> httpLbs authreq (ctx ^. httpManager))) @@ -122,6 +130,9 @@ supportsLocking :: DAVContext a -> Bool supportsLocking = liftA2 (&&) ("LOCK" `elem`) ("UNLOCK" `elem`) . _allowedMethods +supportsCalDAV :: DAVContext a -> Bool +supportsCalDAV = ("calendar-access" `elem`) . _complianceClasses + getPropsM :: MonadResourceBase m => DAVState m XML.Document getPropsM = do let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] @@ -191,11 +202,17 @@ , "{DAV:}supportedlock" ] -getProps :: String -> B.ByteString -> B.ByteString -> IO XML.Document -getProps url username password = withDS url username password getPropsM +caldavReportM :: MonadResourceBase m => DAVState m XML.Document +caldavReportM = do + let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] + calrresp <- davRequest "REPORT" ahs (xmlBody calendarquery) + return $ (XML.parseLBS_ def . responseBody) calrresp +getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document +getProps url username password md = withDS url username password md getPropsM + getPropsAndContent :: String -> B.ByteString -> B.ByteString -> IO (XML.Document, (Maybe B.ByteString, BL.ByteString)) -getPropsAndContent url username password = withDS url username password $ do +getPropsAndContent url username password = withDS url username password (Just Depth0) $ do getOptions o <- get when (supportsLocking o) (lockResource True) @@ -204,14 +221,14 @@ return (props, body)) `finally` when (supportsLocking o) (unlockResource) putContent :: String -> B.ByteString -> B.ByteString -> (Maybe B.ByteString, BL.ByteString) -> IO () -putContent url username password b = withDS url username password $ do +putContent url username password b = withDS url username password Nothing $ do getOptions o <- get when (supportsLocking o) (lockResource False) putContentM b `finally` when (supportsLocking o) (unlockResource) putContentAndProps :: String -> B.ByteString -> B.ByteString -> (XML.Document, (Maybe B.ByteString, BL.ByteString)) -> IO () -putContentAndProps url username password (p, b) = withDS url username password $ do +putContentAndProps url username password (p, b) = withDS url username password Nothing $ do getOptions o <- get when (supportsLocking o) (lockResource False) @@ -219,7 +236,7 @@ putPropsM p) `finally` when (supportsLocking o) (unlockResource) deleteContent :: String -> B.ByteString -> B.ByteString -> IO () -deleteContent url username password = withDS url username password $ do +deleteContent url username password = withDS url username password Nothing $ do getOptions o <- get let lock = when (supportsLocking o) (lockResource False) @@ -228,16 +245,19 @@ bracketOnError lock (\_ -> unlock) (\_ -> delContentM) moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO () -moveContent url newurl username password = withDS url username password $ +moveContent url newurl username password = withDS url username password Nothing $ moveContentM newurl +caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document +caldavReport url username password = withDS url username password (Just Depth1) $ caldavReportM + -- | Creates a WebDAV collection, which is similar to a directory. -- -- Returns False if the collection could not be made due to an intermediate -- collection not existing. (Ie, collection /a/b/c/d cannot be made until -- collection /a/b/c exists.) makeCollection :: String -> B.ByteString -> B.ByteString -> IO Bool -makeCollection url username password = withDS url username password $ +makeCollection url username password = withDS url username password Nothing $ catchJust (matchStatusCodeException conflict409) (mkCol >> return True) @@ -261,3 +281,13 @@ Haskell DAV user |] +calendarquery :: XML.Document +calendarquery = XML.Document (XML.Prologue [] Nothing []) root [] + where + root = XML.Element "C:calendar-query" (Map.fromList [("xmlns:D", "DAV:"),("xmlns:C", "urn:ietf:params:xml:ns:caldav")]) [xml| + + + + + +|] diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs --- a/Network/Protocol/HTTP/DAV/TH.hs +++ b/Network/Protocol/HTTP/DAV/TH.hs @@ -24,6 +24,18 @@ import qualified Data.ByteString as B import Network.HTTP.Conduit (Manager, Request) +data Depth = Depth0 | Depth1 | DepthInfinity +instance Read Depth where + readsPrec _ x + | x == "0" = [(Depth0, "")] + | x == "1" = [(Depth1, "")] + | x == "infinity" = [(DepthInfinity, "")] + | otherwise = fail "invalid" +instance Show Depth where + show Depth0 = "0" + show Depth1 = "1" + show DepthInfinity = "infinity" + data DAVContext a = DAVContext { _allowedMethods :: [B.ByteString] , _baseRequest :: Request a @@ -32,5 +44,6 @@ , _lockToken :: Maybe B.ByteString , _basicusername :: B.ByteString , _basicpassword :: B.ByteString + , _depth :: Maybe Depth } makeLenses ''DAVContext diff --git a/hdav.hs b/hdav.hs --- a/hdav.hs +++ b/hdav.hs @@ -19,9 +19,11 @@ import qualified Data.ByteString.Char8 as BC8 import Paths_DAV (version) -import Data.Version (showVersion) -import Data.Maybe (fromMaybe, fromJust) +import Control.Applicative ((<$>),(<*>), optional, pure) import Control.Monad (unless) +import Data.Version (showVersion) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Text.XML (renderLBS, def) import qualified Data.ByteString.Lazy.Char8 as B @@ -29,112 +31,150 @@ import Network.URI (normalizePathSegments) -import qualified System.Console.CmdArgs.Explicit as CA +import Network.Protocol.HTTP.DAV (getProps, getPropsAndContent, putContent, putContentAndProps, deleteContent, moveContent, makeCollection, Depth(..), caldavReport) -import Network.Protocol.HTTP.DAV (getProps, getPropsAndContent, putContentAndProps, deleteContent, moveContent, makeCollection) +import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, option, progDesc, str, strOption, subparser) +import Options.Applicative.Extra (execParser) +import Options.Applicative.Types (Parser) -doCopy :: [(String, String)] -> IO () -doCopy as = do - let url1 = fromJust . lookup "sourceurl" $ as - let url2 = fromJust . lookup "targeturl" $ as - let sourceUsername = BC8.pack . fromMaybe "" . lookup "source-username" $ as - let sourcePassword = BC8.pack . fromMaybe "" . lookup "source-password" $ as - let targetUsername = BC8.pack . fromMaybe "" . lookup "target-username" $ as - let targetPassword = BC8.pack . fromMaybe "" . lookup "target-password" $ as - (p, b) <- getPropsAndContent url1 sourceUsername sourcePassword - putContentAndProps url2 targetUsername targetPassword (p, b) +data Options = Options { + url :: String + , url2 :: String + , username :: String + , password :: String + , username2 :: String + , password2 :: String +} -doDelete :: [(String, String)] -> IO () -doDelete as = do - let url = fromJust . lookup "url" $ as - let username = BC8.pack . fromMaybe "" . lookup "username" $ as - let password = BC8.pack . fromMaybe "" . lookup "password" $ as - deleteContent url username password +data Command = Copy Options | Move Options | Delete Options | MakeCollection Options | GetProps Options (Maybe Depth) | Put FilePath Options | CaldavReport Options -doMove :: [(String, String)] -> IO () -doMove as = do - let url1 = fromJust . lookup "sourceurl" $ as - let url2 = fromJust . lookup "targeturl" $ as - let username = BC8.pack . fromMaybe "" . lookup "username" $ as - let password = BC8.pack . fromMaybe "" . lookup "password" $ as - moveContent url1 (BC8.pack url2) username password +oneUUP :: Parser Options +oneUUP = Options + <$> argument str ( metavar "URL" ) + <*> pure "" + <*> (fromMaybe "" <$> (optional $ strOption + ( long "username" + <> metavar "USERNAME" + <> help "username for URL" ))) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "password" + <> metavar "PASSWORD" + <> help "password for URL" ))) + <*> pure "" + <*> pure "" -doMakeCollection :: [(String, String)] -> IO () -doMakeCollection as = do - let url = fromJust . lookup "url" $ as - go url +twoUUP :: Parser Options +twoUUP = Options + <$> argument str ( metavar "SOURCEURL" ) + <*> argument str ( metavar "TARGETURL" ) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "source-username" + <> metavar "USERNAME" + <> help "username for source URL" ))) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "source-password" + <> metavar "PASSWORD" + <> help "password for source URL" ))) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "target-username" + <> metavar "USERNAME" + <> help "username for target URL" ))) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "target-password" + <> metavar "PASSWORD" + <> help "password for target URL" ))) + +twoUoneUP :: Parser Options +twoUoneUP = Options + <$> argument str ( metavar "SOURCEURL" ) + <*> argument str ( metavar "TARGETURL" ) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "username" + <> metavar "USERNAME" + <> help "username for URL" ))) + <*> (fromMaybe "" <$> (optional $ strOption + ( long "password" + <> metavar "PASSWORD" + <> help "password for URL" ))) + <*> pure "" + <*> pure "" + +doCopy :: Options -> IO () +doCopy o = do + (p, b) <- getPropsAndContent sourceurl sourceUsername sourcePassword + putContentAndProps targeturl targetUsername targetPassword (p, b) + 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 = deleteContent (url o) (BC8.pack $ username o) (BC8.pack $ password o) + +doMove :: Options -> IO () +doMove o = moveContent (url o) (BC8.pack $ url2 o) (BC8.pack $ username o) (BC8.pack $ password o) + +doMakeCollection :: Options -> IO () +doMakeCollection o = go (url o) where - username = BC8.pack . fromMaybe "" . lookup "username" $ as - password = BC8.pack . fromMaybe "" . lookup "password" $ as + u = BC8.pack . username $ o + p = BC8.pack . password $ o go url = do - ok <- makeCollection url username password + ok <- makeCollection url u p unless ok $ do go (parent url) - ok' <- makeCollection url username password + ok' <- makeCollection url u p unless ok' $ error $ "failed creating " ++ url parent url = reverse $ dropWhile (== '/')$ reverse $ normalizePathSegments (url ++ "/..") -doGetProps :: [(String, String)] -> IO () -doGetProps as = do - let url = fromJust . lookup "url" $ as - let username = BC8.pack . fromMaybe "" . lookup "username" $ as - let password = BC8.pack . fromMaybe "" . lookup "password" $ as - doc <- getProps url username password +doGetProps :: Options -> Maybe Depth -> IO () +doGetProps o md = do + doc <- getProps (url o) (BC8.pack $ username o) (BC8.pack $ password o) md B.putStrLn (renderLBS def doc) -dispatch :: String -> [(String, String)] -> IO () -dispatch m as - | m == "copy" = doCopy as - | m == "move" = doMove as - | m == "delete" = doDelete as - | m == "makecollection" = doMakeCollection as - | m == "getprops" = doGetProps as - | otherwise = fail "Unexpected condition." +doPut :: FilePath -> Options -> IO () +doPut file o = do + bs <- B.readFile file + putContent (url o) (BC8.pack $ username o) (BC8.pack $ password o) (Nothing, bs) -showHelp :: IO () -showHelp = print $ CA.helpText [] CA.HelpFormatDefault arguments +doReport :: Options -> IO () +doReport o = do + doc <- caldavReport (url o) (BC8.pack $ username o) (BC8.pack $ password o) + B.putStrLn (renderLBS def doc) +dispatch :: Command -> IO () +dispatch (Copy o) = doCopy o +dispatch (Move o) = doMove o +dispatch (Delete o) = doDelete o +dispatch (MakeCollection o) = doMakeCollection o +dispatch (GetProps o md) = doGetProps o md +dispatch (Put f o) = doPut f o +dispatch (CaldavReport o) = doReport o + main :: IO () main = withSocketsDo $ do putStrLn $ "hDAV version " ++ showVersion version ++ ", Copyright (C) 2012-2013 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\n" + \under certain conditions.\n" - as <- CA.processArgs arguments - if ("help","") `elem` as then showHelp else dispatch' as + execParser (info cmd idm) >>= dispatch - where dispatch' as = case lookup "mode" as of - Nothing -> showHelp - Just m -> dispatch m as +cmd :: Parser Command +cmd = subparser + ( command "copy" (info ( Copy <$> twoUUP ) ( progDesc "Copy props and data from one location to another" )) + <> command "delete" (info ( Delete <$> oneUUP ) ( progDesc "Delete props and data" )) + <> command "getprops" (info ( GetProps <$> oneUUP <*> (optional $ option ( long "depth" <> metavar "DEPTH" <> help "depth" ))) ( progDesc "Fetch props and output them to stdout" )) + <> command "makecollection" (info ( MakeCollection <$> oneUUP ) ( progDesc "Make a new collection" )) + <> command "move" (info ( Move <$> twoUoneUP ) ( progDesc "Move props and data from one location to another in the same DAV space" )) + <> command "put" (info ( Put <$> argument str ( metavar "FILE" ) <*> oneUUP ) ( progDesc "Put file to URL" )) -arguments :: CA.Mode [(String,String)] -arguments = CA.modes "hdav" [] "hdav WebDAV client" [ - (CA.mode "copy" [("mode", "copy")] "copy" (CA.flagArg (upd "sourceurl") "SOURCEURL") [ - CA.flagReq ["source-username"] (upd "source-username") "USERNAME" "username for source URL" - , CA.flagReq ["source-password"] (upd "source-password") "PASSWORD" "password for source URL" - , CA.flagReq ["target-username"] (upd "target-username") "USERNAME" "username for target URL" - , CA.flagReq ["target-password"] (upd "target-password") "PASSWORD" "password for target URL" - , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "sourceurl") "SOURCEURL") { CA.argRequire = True }, (CA.flagArg (upd "targeturl") "TARGETURL") { CA.argRequire = True }], Nothing) } - , (CA.mode "move" [("mode", "move")] "move" (CA.flagArg (upd "sourceurl") "SOURCEURL") [ - CA.flagReq ["username"] (upd "username") "USERNAME" "username for source and target URL" - , CA.flagReq ["password"] (upd "password") "PASSWORD" "password for source and target URL" - , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "sourceurl") "SOURCEURL") { CA.argRequire = True }, (CA.flagArg (upd "targeturl") "TARGETURL") { CA.argRequire = True }], Nothing) } - , (CA.mode "delete" [("mode", "delete")] "delete" (CA.flagArg (upd "url") "URL") [ - CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL" - , CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL" - , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) } - , (CA.mode "makecollection" [("mode", "makecollection")] "makecollecton" (CA.flagArg (upd "url") "URL") [ - CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL" - , CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL" - , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) } - , (CA.mode "getprops" [("mode", "getprops")] "getprops" (CA.flagArg (upd "url") "URL") [ - CA.flagReq ["username"] (upd "username") "USERNAME" "username for URL" - , CA.flagReq ["password"] (upd "password") "PASSWORD" "password for URL" - , CA.flagHelpSimple (("help",""):)]) { CA.modeArgs = ([(CA.flagArg (upd "url") "URL") { CA.argRequire = True }], Nothing) } - ] - where upd msg x v = Right $ (msg,x):v + <> command "caldav-report" (info ( CaldavReport <$> oneUUP ) ( progDesc "Get CalDAV report" )) + )