encrypted webdav working
This commit is contained in:
parent
bb28c6114a
commit
0f782bd028
2 changed files with 25 additions and 17 deletions
|
@ -122,7 +122,7 @@ storeEncrypted r (cipher, enck) k _p = s3Action r False $ \(conn, bucket) ->
|
||||||
-- (An alternative would be chunking to to a constant size.)
|
-- (An alternative would be chunking to to a constant size.)
|
||||||
withTmp enck $ \tmp -> do
|
withTmp enck $ \tmp -> do
|
||||||
f <- inRepo $ gitAnnexLocation k
|
f <- inRepo $ gitAnnexLocation k
|
||||||
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
|
liftIO $ withEncryptedContent cipher (L.readFile f) $ L.writeFile tmp
|
||||||
res <- liftIO $ storeHelper (conn, bucket) r enck tmp
|
res <- liftIO $ storeHelper (conn, bucket) r enck tmp
|
||||||
s3Bool res
|
s3Bool res
|
||||||
|
|
||||||
|
|
|
@ -78,39 +78,47 @@ webdavSetup u c = do
|
||||||
creds <- getCreds c' u
|
creds <- getCreds c' u
|
||||||
testDav url creds
|
testDav url creds
|
||||||
gitConfigSpecialRemote u c' "webdav" "true"
|
gitConfigSpecialRemote u c' "webdav" "true"
|
||||||
setRemoteCredPair c (davCreds u)
|
setRemoteCredPair c' (davCreds u)
|
||||||
|
|
||||||
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||||
store r k _f _p = davAction r False $ \(baseurl, user, pass) -> do
|
store r k _f _p = davAction r False $ \(baseurl, user, pass) -> do
|
||||||
let url = davLocation baseurl k
|
let url = davLocation baseurl k
|
||||||
liftIO $ davMkdir (urlParent url) user pass
|
|
||||||
f <- inRepo $ gitAnnexLocation k
|
f <- inRepo $ gitAnnexLocation k
|
||||||
b <- liftIO $ L.readFile f
|
b <- liftIO $ L.readFile f
|
||||||
|
liftIO $ davMkdir (urlParent url) user pass
|
||||||
v <- liftIO $ catchMaybeHttp $ putContentAndProps url user pass
|
v <- liftIO $ catchMaybeHttp $ putContentAndProps url user pass
|
||||||
(noProps, (contentType, b))
|
(noProps, (contentType, b))
|
||||||
return $ isJust v
|
return $ isJust v
|
||||||
|
|
||||||
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
||||||
storeEncrypted r (cipher, enck) k _p = davAction r False $ \creds -> liftIO $ do
|
storeEncrypted r (cipher, enck) k _p = davAction r False $ \(baseurl, user, pass) -> do
|
||||||
error "TODO"
|
f <- inRepo $ gitAnnexLocation k
|
||||||
|
let url = davLocation baseurl enck
|
||||||
|
liftIO $ davMkdir (urlParent url) user pass
|
||||||
|
v <- liftIO $ withEncryptedContent cipher (L.readFile f) $ \b ->
|
||||||
|
catchMaybeHttp $ putContentAndProps url user pass
|
||||||
|
(noProps, (contentType, b))
|
||||||
|
return $ isJust v
|
||||||
|
|
||||||
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||||
retrieve r k _f d = davAction r False $ liftIO . go
|
retrieve r k _f d = retrieve' r k (L.writeFile d)
|
||||||
where
|
|
||||||
go (baseurl, user, pass) = do
|
|
||||||
let url = davLocation baseurl k
|
|
||||||
maybe (return False) save
|
|
||||||
=<< catchMaybeHttp (getPropsAndContent url user pass)
|
|
||||||
save (_, (_, b)) = do
|
|
||||||
L.writeFile d b
|
|
||||||
return True
|
|
||||||
|
|
||||||
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
|
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
|
||||||
retrieveCheap _ _ _ = return False
|
retrieveCheap _ _ _ = return False
|
||||||
|
|
||||||
retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
|
retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
|
||||||
retrieveEncrypted r (cipher, enck) _ f = davAction r False $ \creds -> do
|
retrieveEncrypted r (cipher, enck) _ d = retrieve' r enck $ \b -> do
|
||||||
error "TODO"
|
withDecryptedContent cipher (return b) (L.writeFile d)
|
||||||
|
|
||||||
|
retrieve' :: Remote -> Key -> (L.ByteString -> IO ()) -> Annex Bool
|
||||||
|
retrieve' r k saver = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
|
||||||
|
let url = davLocation baseurl k
|
||||||
|
maybe (return False) save
|
||||||
|
=<< catchMaybeHttp (getPropsAndContent url user pass)
|
||||||
|
where
|
||||||
|
save (_, (_, b)) = do
|
||||||
|
saver b
|
||||||
|
return True
|
||||||
|
|
||||||
remove :: Remote -> Key -> Annex Bool
|
remove :: Remote -> Key -> Annex Bool
|
||||||
remove r k = davAction r False $ liftIO . go
|
remove r k = davAction r False $ liftIO . go
|
||||||
|
@ -200,7 +208,6 @@ urlParent url = reverse $ dropWhile (== '/') $ reverse $
|
||||||
{- Test if a WebDAV store is usable, by writing to a test file, and then
|
{- Test if a WebDAV store is usable, by writing to a test file, and then
|
||||||
- deleting the file. Exits with an error if not. -}
|
- deleting the file. Exits with an error if not. -}
|
||||||
testDav :: String -> Maybe CredPair -> Annex ()
|
testDav :: String -> Maybe CredPair -> Annex ()
|
||||||
testDav baseurl Nothing = error "Need to configure webdav username and password."
|
|
||||||
testDav baseurl (Just (u, p)) = do
|
testDav baseurl (Just (u, p)) = do
|
||||||
showSideAction "testing WebDAV server"
|
showSideAction "testing WebDAV server"
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
|
@ -212,6 +219,7 @@ testDav baseurl (Just (u, p)) = do
|
||||||
user = toDavUser u
|
user = toDavUser u
|
||||||
pass = toDavPass p
|
pass = toDavPass p
|
||||||
testurl = davUrl baseurl "git-annex-test"
|
testurl = davUrl baseurl "git-annex-test"
|
||||||
|
testDav _ Nothing = error "Need to configure webdav username and password."
|
||||||
|
|
||||||
{- Content-Type to use for files uploaded to WebDAV. -}
|
{- Content-Type to use for files uploaded to WebDAV. -}
|
||||||
contentType :: Maybe B8.ByteString
|
contentType :: Maybe B8.ByteString
|
||||||
|
|
Loading…
Reference in a new issue