S3 crypto support
Untested, I will need to dust off my S3 keys, and plug the modem back in that was unplugged last night due to very low battery bank power. But it compiles, so it's probably perfect. :)
This commit is contained in:
parent
4d136e1ef5
commit
67cced26dc
1 changed files with 39 additions and 11 deletions
|
@ -29,6 +29,7 @@ import Locations
|
||||||
import Config
|
import Config
|
||||||
import Remote.Special
|
import Remote.Special
|
||||||
import Remote.Encryptable
|
import Remote.Encryptable
|
||||||
|
import Crypto
|
||||||
|
|
||||||
remote :: RemoteType Annex
|
remote :: RemoteType Annex
|
||||||
remote = RemoteType {
|
remote = RemoteType {
|
||||||
|
@ -41,16 +42,22 @@ remote = RemoteType {
|
||||||
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
||||||
gen r u c = do
|
gen r u c = do
|
||||||
cst <- remoteCost r expensiveRemoteCost
|
cst <- remoteCost r expensiveRemoteCost
|
||||||
return $ this cst
|
return $ gen' r u c cst
|
||||||
|
gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote Annex
|
||||||
|
gen' r u c cst =
|
||||||
|
encryptableRemote c
|
||||||
|
(storeEncrypted this)
|
||||||
|
(retrieveEncrypted this)
|
||||||
|
this
|
||||||
where
|
where
|
||||||
this cst = Remote {
|
this = Remote {
|
||||||
uuid = u,
|
uuid = u,
|
||||||
cost = cst,
|
cost = cst,
|
||||||
name = Git.repoDescribe r,
|
name = Git.repoDescribe r,
|
||||||
storeKey = store (this cst),
|
storeKey = store this,
|
||||||
retrieveKeyFile = retrieve (this cst),
|
retrieveKeyFile = retrieve this,
|
||||||
removeKey = remove (this cst),
|
removeKey = remove this,
|
||||||
hasKey = checkPresent (this cst),
|
hasKey = checkPresent this,
|
||||||
hasKeyCheap = False,
|
hasKeyCheap = False,
|
||||||
config = c
|
config = c
|
||||||
}
|
}
|
||||||
|
@ -139,9 +146,21 @@ checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
|
||||||
noconn = Left $ error "S3 not configured"
|
noconn = Left $ error "S3 not configured"
|
||||||
|
|
||||||
store :: Remote Annex -> Key -> Annex Bool
|
store :: Remote Annex -> Key -> Annex Bool
|
||||||
store r k = s3Action r False $ \(conn, bucket) -> do
|
store r k = storeHelper r k =<< lazyKeyContent k
|
||||||
|
|
||||||
|
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
|
||||||
|
storeEncrypted r (cipher, enck) k = do
|
||||||
|
content <- lazyKeyContent k
|
||||||
|
content' <- liftIO $ withEncryptedContent cipher content return
|
||||||
|
storeHelper r enck content'
|
||||||
|
|
||||||
|
lazyKeyContent :: Key -> Annex L.ByteString
|
||||||
|
lazyKeyContent k = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
content <- liftIO $ L.readFile $ gitAnnexLocation g k
|
liftIO $ L.readFile $ gitAnnexLocation g k
|
||||||
|
|
||||||
|
storeHelper :: Remote Annex -> Key -> L.ByteString -> Annex Bool
|
||||||
|
storeHelper r k content = s3Action r False $ \(conn, bucket) -> do
|
||||||
let object = setStorageClass storageclass $ bucketKey bucket k content
|
let object = setStorageClass storageclass $ bucketKey bucket k content
|
||||||
res <- liftIO $ sendObject conn object
|
res <- liftIO $ sendObject conn object
|
||||||
case res of
|
case res of
|
||||||
|
@ -156,16 +175,25 @@ store r k = s3Action r False $ \(conn, bucket) -> do
|
||||||
_ -> STANDARD
|
_ -> STANDARD
|
||||||
|
|
||||||
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
|
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
|
||||||
retrieve r k f = s3Action r False $ \(conn, bucket) -> do
|
retrieve = retrieveHelper (return . obj_data)
|
||||||
|
|
||||||
|
retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool
|
||||||
|
retrieveEncrypted r (cipher, enck) f = retrieveHelper decrypt r enck f
|
||||||
|
where
|
||||||
|
decrypt o = withDecryptedContent cipher (obj_data o) return
|
||||||
|
|
||||||
|
retrieveHelper :: (S3Object -> IO L.ByteString) -> Remote Annex -> Key -> FilePath -> Annex Bool
|
||||||
|
retrieveHelper a r k f = s3Action r False $ \(conn, bucket) -> do
|
||||||
res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
|
res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
|
||||||
case res of
|
case res of
|
||||||
Right o -> do
|
Right o -> do
|
||||||
liftIO $ L.writeFile f (obj_data o)
|
content <- liftIO $ a o
|
||||||
|
liftIO $ L.writeFile f content
|
||||||
return True
|
return True
|
||||||
Left e -> do
|
Left e -> do
|
||||||
warning $ prettyReqError e
|
warning $ prettyReqError e
|
||||||
return False
|
return False
|
||||||
|
|
||||||
remove :: Remote Annex -> Key -> Annex Bool
|
remove :: Remote Annex -> Key -> Annex Bool
|
||||||
remove r k = s3Action r False $ \(conn, bucket) -> do
|
remove r k = s3Action r False $ \(conn, bucket) -> do
|
||||||
res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
|
res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue