bugfix
This commit is contained in:
parent
b8ba60428a
commit
4c3ad80f32
6 changed files with 26 additions and 22 deletions
20
Backend.hs
20
Backend.hs
|
@ -78,17 +78,9 @@ retrieveKeyFile backend key dest = (B.retrieveKeyFile backend) key dest
|
||||||
removeKey :: Backend -> Key -> Annex Bool
|
removeKey :: Backend -> Key -> Annex Bool
|
||||||
removeKey backend key = (B.removeKey backend) key
|
removeKey backend key = (B.removeKey backend) key
|
||||||
|
|
||||||
{- Checks if any backend has a key. -}
|
{- Checks if a backend has its key. -}
|
||||||
hasKey :: Key -> Annex Bool
|
hasKey :: Key -> Annex Bool
|
||||||
hasKey key = do
|
hasKey key = (B.hasKey (lookupBackendName $ backendName key)) key
|
||||||
b <- backendList
|
|
||||||
hasKey' b key
|
|
||||||
hasKey' [] key = return False
|
|
||||||
hasKey' (b:bs) key = do
|
|
||||||
has <- (B.hasKey b) key
|
|
||||||
if (has)
|
|
||||||
then return True
|
|
||||||
else hasKey' bs key
|
|
||||||
|
|
||||||
{- Looks up the key and backend corresponding to an annexed file,
|
{- Looks up the key and backend corresponding to an annexed file,
|
||||||
- by examining what the file symlinks to. -}
|
- by examining what the file symlinks to. -}
|
||||||
|
@ -101,6 +93,8 @@ lookupFile file = do
|
||||||
where
|
where
|
||||||
lookup = do
|
lookup = do
|
||||||
l <- readSymbolicLink file
|
l <- readSymbolicLink file
|
||||||
return $ Just (k l, b l)
|
return $ Just $ pair $ takeFileName l
|
||||||
k l = fileKey $ takeFileName $ l
|
pair file = (k, b)
|
||||||
b l = lookupBackendName $ takeFileName $ parentDir $ l
|
where
|
||||||
|
k = fileKey file
|
||||||
|
b = lookupBackendName $ backendName k
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
|
|
||||||
module Backend.Url (backend) where
|
module Backend.Url (backend) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State (liftIO)
|
||||||
|
import Data.String.Utils
|
||||||
import System.Cmd
|
import System.Cmd
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import BackendTypes
|
import BackendTypes
|
||||||
|
@ -30,9 +31,11 @@ dummyOk :: Key -> Annex Bool
|
||||||
dummyOk url = return True
|
dummyOk url = return True
|
||||||
|
|
||||||
downloadUrl :: Key -> FilePath -> Annex Bool
|
downloadUrl :: Key -> FilePath -> Annex Bool
|
||||||
downloadUrl url file = do
|
downloadUrl key file = do
|
||||||
liftIO $ putStrLn $ "download: " ++ (show url)
|
liftIO $ putStrLn $ "download: " ++ url
|
||||||
result <- liftIO $ rawSystem "curl" ["-#", "-o", file, (show url)]
|
result <- liftIO $ rawSystem "curl" ["-#", "-o", file, url]
|
||||||
if (result == ExitSuccess)
|
if (result == ExitSuccess)
|
||||||
then return True
|
then return True
|
||||||
else return False
|
else return False
|
||||||
|
where
|
||||||
|
url = join ":" $ drop 1 $ split ":" $ show key
|
||||||
|
|
|
@ -28,7 +28,7 @@ parseBackendList s =
|
||||||
then supportedBackends
|
then supportedBackends
|
||||||
else map (lookupBackendName) $ words s
|
else map (lookupBackendName) $ words s
|
||||||
|
|
||||||
{- Looks up a supported backed by name. -}
|
{- Looks up a supported backend by name. -}
|
||||||
lookupBackendName :: String -> Backend
|
lookupBackendName :: String -> Backend
|
||||||
lookupBackendName s =
|
lookupBackendName s =
|
||||||
if ((length matches) /= 1)
|
if ((length matches) /= 1)
|
||||||
|
|
|
@ -36,6 +36,14 @@ instance Read Key where
|
||||||
b = l !! 0
|
b = l !! 0
|
||||||
k = join ":" $ drop 1 l
|
k = join ":" $ drop 1 l
|
||||||
|
|
||||||
|
-- pulls the backend name out
|
||||||
|
backendName :: Key -> BackendName
|
||||||
|
backendName (Key (b,k)) = b
|
||||||
|
|
||||||
|
-- pulls the key fragment out
|
||||||
|
keyFrag :: Key -> KeyFrag
|
||||||
|
keyFrag (Key (b,k)) = k
|
||||||
|
|
||||||
-- this structure represents a key/value backend
|
-- this structure represents a key/value backend
|
||||||
data Backend = Backend {
|
data Backend = Backend {
|
||||||
-- name of this backend
|
-- name of this backend
|
||||||
|
|
3
TODO
3
TODO
|
@ -1,9 +1,6 @@
|
||||||
* bug when annexing files while in a subdir of a git repo
|
* bug when annexing files while in a subdir of a git repo
|
||||||
* bug when specifying absolute path to files when annexing
|
* bug when specifying absolute path to files when annexing
|
||||||
|
|
||||||
* need to include backend name as part of the key, because currently
|
|
||||||
if two backends have overlapping key spaces, it can confuse things
|
|
||||||
|
|
||||||
* --push/--pull/--want
|
* --push/--pull/--want
|
||||||
|
|
||||||
* how to handle git mv file?
|
* how to handle git mv file?
|
||||||
|
|
4
Types.hs
4
Types.hs
|
@ -3,8 +3,10 @@
|
||||||
module Types (
|
module Types (
|
||||||
Annex,
|
Annex,
|
||||||
AnnexState,
|
AnnexState,
|
||||||
|
Backend,
|
||||||
Key,
|
Key,
|
||||||
Backend
|
backendName,
|
||||||
|
keyFrag
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import BackendTypes
|
import BackendTypes
|
||||||
|
|
Loading…
Reference in a new issue