refactor
This commit is contained in:
parent
98e3817466
commit
991efddfa1
2 changed files with 86 additions and 65 deletions
|
@ -42,14 +42,17 @@ gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
|||
gen r u c = do
|
||||
dir <- getConfig r "directory" (error "missing directory")
|
||||
cst <- remoteCost r cheapRemoteCost
|
||||
return $ Remote {
|
||||
return $ encryptedRemote c
|
||||
(storeEncrypted dir)
|
||||
(retrieveEncrypted dir)
|
||||
Remote {
|
||||
uuid = u,
|
||||
cost = cst,
|
||||
name = Git.repoDescribe r,
|
||||
storeKey = storeKeyEncrypted c $ store dir,
|
||||
retrieveKeyFile = retrieveKeyFileEncrypted c $ retrieve dir,
|
||||
removeKey = removeKeyEncrypted c $ remove dir,
|
||||
hasKey = hasKeyEncrypted c $ checkPresent dir,
|
||||
storeKey = store dir,
|
||||
retrieveKeyFile = retrieve dir,
|
||||
removeKey = remove dir,
|
||||
hasKey = checkPresent dir,
|
||||
hasKeyCheap = True,
|
||||
config = Nothing
|
||||
}
|
||||
|
@ -74,41 +77,45 @@ dirKey d k = d </> hashDirMixed k </> f </> f
|
|||
where
|
||||
f = keyFile k
|
||||
|
||||
store :: FilePath -> Key -> Maybe (Cipher, Key) -> Annex Bool
|
||||
store d k c = do
|
||||
store :: FilePath -> Key -> Annex Bool
|
||||
store d k = do
|
||||
g <- Annex.gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
liftIO $ catch (copy src) (const $ return False)
|
||||
where
|
||||
copy src = case c of
|
||||
Just (cipher, enckey) -> do
|
||||
content <- L.readFile src
|
||||
let dest = dirKey d enckey
|
||||
prep dest
|
||||
withEncryptedContent cipher content $ \s -> do
|
||||
L.writeFile dest s
|
||||
cleanup True dest
|
||||
_ -> do
|
||||
let dest = dirKey d k
|
||||
prep dest
|
||||
ok <- copyFile src dest
|
||||
cleanup ok dest
|
||||
prep dest = liftIO $ do
|
||||
liftIO $ catch (storeHelper dest $ copyFile src dest) (const $ return False)
|
||||
|
||||
storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted d (cipher, enck) k = do
|
||||
g <- Annex.gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
let dest = dirKey d enck
|
||||
liftIO $ catch (storeHelper dest $ encrypt src dest) (const $ return False)
|
||||
where
|
||||
encrypt src dest = do
|
||||
content <- L.readFile src
|
||||
withEncryptedContent cipher content $ L.writeFile dest
|
||||
return True
|
||||
|
||||
storeHelper :: FilePath -> IO Bool -> IO Bool
|
||||
storeHelper dest a = do
|
||||
let dir = parentDir dest
|
||||
createDirectoryIfMissing True dir
|
||||
allowWrite dir
|
||||
cleanup ok dest = do
|
||||
ok <- a
|
||||
when ok $ do
|
||||
let dir = parentDir dest
|
||||
preventWrite dest
|
||||
preventWrite dir
|
||||
return ok
|
||||
|
||||
retrieve :: FilePath -> Key -> FilePath -> Maybe (Cipher, Key) -> Annex Bool
|
||||
retrieve d k f Nothing = liftIO $ copyFile (dirKey d k) f
|
||||
retrieve d k f (Just (cipher, enckey)) =
|
||||
liftIO $ flip catch (const $ return False) $ do
|
||||
content <- L.readFile (dirKey d enckey)
|
||||
retrieve :: FilePath -> Key -> FilePath -> Annex Bool
|
||||
retrieve d k f = liftIO $ copyFile (dirKey d k) f
|
||||
|
||||
retrieveEncrypted :: FilePath -> (Cipher, Key) -> FilePath -> Annex Bool
|
||||
retrieveEncrypted d (cipher, enck) f =
|
||||
liftIO $ catch decrypt (const $ return False)
|
||||
where
|
||||
decrypt = do
|
||||
content <- L.readFile (dirKey d enck)
|
||||
withDecryptedContent cipher content $ L.writeFile f
|
||||
return True
|
||||
|
||||
|
|
|
@ -33,16 +33,39 @@ encryptionSetup c =
|
|||
cipher <- liftIO a
|
||||
return $ M.delete "encryption" $ storeCipher c cipher
|
||||
|
||||
{- Helpers that can be applied to a Remote's normal actions to
|
||||
- add crypto support. -}
|
||||
storeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Maybe (Cipher, Key) -> Annex a) -> Key -> Annex a
|
||||
storeKeyEncrypted c a k = a k =<< cipherKey c k
|
||||
retrieveKeyFileEncrypted :: Maybe RemoteConfig -> (Key -> FilePath -> Maybe (Cipher, Key) -> Annex a) -> Key -> FilePath -> Annex a
|
||||
retrieveKeyFileEncrypted c a k f = a k f =<< cipherKey c k
|
||||
removeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
removeKeyEncrypted = withEncryptedKey
|
||||
hasKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
hasKeyEncrypted = withEncryptedKey
|
||||
{- Modifies a Remote to support encryption.
|
||||
-
|
||||
- Two additional functions must be provided by the remote,
|
||||
- to support storing and retrieving encrypted content. -}
|
||||
encryptedRemote
|
||||
:: Maybe RemoteConfig
|
||||
-> ((Cipher, Key) -> Key -> Annex Bool)
|
||||
-> ((Cipher, Key) -> FilePath -> Annex Bool)
|
||||
-> Remote Annex
|
||||
-> Remote Annex
|
||||
encryptedRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
|
||||
r {
|
||||
storeKey = store,
|
||||
retrieveKeyFile = retrieve,
|
||||
removeKey = withkey $ removeKey r,
|
||||
hasKey = withkey $ hasKey r
|
||||
}
|
||||
where
|
||||
store k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> (storeKey r) k
|
||||
Just x -> storeKeyEncrypted x k
|
||||
retrieve k f = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> (retrieveKeyFile r) k f
|
||||
Just x -> retrieveKeyFileEncrypted x f
|
||||
withkey a k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> a k
|
||||
Just (_, k') -> a k'
|
||||
|
||||
{- Gets encryption Cipher, and encrypted version of Key.
|
||||
-
|
||||
|
@ -64,12 +87,3 @@ cipherKey (Just c) k = do
|
|||
ret cipher = do
|
||||
k' <- liftIO $ encryptKey cipher k
|
||||
return $ Just (cipher, k')
|
||||
|
||||
{- Passes the encrypted version of the key to the action when encryption
|
||||
- is enabled, and the non-encrypted version otherwise. -}
|
||||
withEncryptedKey :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
withEncryptedKey c a k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> a k
|
||||
Just (_, k') -> a k'
|
||||
|
|
Loading…
Reference in a new issue