DAV 0.3.1 → 0.4

raw patch · 4 files changed

+185/−102 lines, 4 filesdep +optparse-applicativedep −cmdargsPVP ok

version bump matches the API change (PVP)

Dependencies added: optparse-applicative

Dependencies removed: cmdargs

API changes (from Hackage documentation)

Files

• DAV.cabal +2/−2
• Network/Protocol/HTTP/DAV.hs +47/−17
• Network/Protocol/HTTP/DAV/TH.hs +13/−0
• hdav.hs +123/−83

@@ -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

@@ -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 @@ <D:owner>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|+<D:prop>+  <D:getetag>+  <C:calendar-data>+<C:filter>+  <C:comp-filter name="VCALENDAR">+|]

@@ -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

@@ -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" ))+  )