summaryrefslogtreecommitdiff
path: root/Backend/File.hs
blob: 797d4874795fbf9c958b63787d0bad8412a2f1fa (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
{- git-annex pseudo-backend
 -
 - This backend does not really do any independant data storage,
 - it relies on the file contents in .git/annex/ in this repo,
 - and other accessible repos.
 -
 - This is an abstract backend; getKey has to be implemented to complete
 - it.
 -}

module Backend.File (backend) where

import Control.Monad.State
import System.IO
import System.Cmd
import System.Cmd.Utils
import Control.Exception
import List
import Maybe

import TypeInternals
import LocationLog
import Locations
import qualified Remotes
import qualified GitRepo as Git
import Utility
import Core
import qualified Annex
import UUID
import qualified Backend

backend = Backend {
	name = mustProvide,
	getKey = mustProvide,
	storeFileKey = dummyStore,
	retrieveKeyFile = copyKeyFile,
	removeKey = checkRemoveKey,
	hasKey = checkKeyFile
}

mustProvide = error "must provide this field"

{- Storing a key is a no-op. -}
dummyStore :: FilePath -> Key -> Annex (Bool)
dummyStore file key = return True

{- Just check if the .git/annex/ file for the key exists. 
 -
 - But, if running against a remote annex, need to use ssh to do it. -}
checkKeyFile :: Key -> Annex Bool
checkKeyFile k = do
	g <- Annex.gitRepo
	if (not $ Git.repoIsUrl g)
		then inAnnex k
		else do
			showNote ("checking " ++ Git.repoDescribe g ++ "...")
			liftIO $ boolSystem "ssh" [Git.urlHost g,
				"test -e " ++ (shellEscape $ annexLocation g k)]

{- Try to find a copy of the file in one of the remotes,
 - and copy it over to this one. -}
copyKeyFile :: Key -> FilePath -> Annex (Bool)
copyKeyFile key file = do
	remotes <- Remotes.withKey key
	if (0 == length remotes)
		then do
			showNote "not available"
			showLocations key
			return False
		else trycopy remotes remotes
	where
		trycopy full [] = do
			showNote "not available"
			showTriedRemotes full
			showLocations key
			return False
		trycopy full (r:rs) = do
			-- annexLocation needs the git config to have been
			-- read for a remote, so do that now,
			-- if it hasn't been already
			result <- Remotes.tryGitConfigRead r
			case (result) of
				Left err -> trycopy full rs
				Right r' -> do
					showNote $ "copying from " ++ (Git.repoDescribe r) ++ "..."
					liftIO $ copyFromRemote r' key file

{- Tries to copy a file from a remote. -}
copyFromRemote :: Git.Repo -> Key -> FilePath -> IO Bool
copyFromRemote r key file = do
	if (not $ Git.repoIsUrl r)
		then getlocal
		else if (Git.repoIsSsh r)
			then getssh
			else error "copying from non-ssh repo not supported"
	where
		getlocal = boolSystem "cp" ["-a", location, file]
		getssh = do
			liftIO $ putStrLn "" -- make way for scp progress bar
			-- TODO double-shell-quote path for scp
			boolSystem "scp" [sshlocation, file]
		location = annexLocation r key
		sshlocation = (Git.urlHost r) ++ ":" ++ location

{- Checks remotes to verify that enough copies of a key exist to allow
 - for a key to be safely removed (with no data loss), and fails with an
 - error if not. -}
checkRemoveKey :: Key -> Annex (Bool)
checkRemoveKey key = do
	force <- Annex.flagIsSet "force"
	if (force)
		then return True
		else do
			g <- Annex.gitRepo
			remotes <- Remotes.withKey key
			let numcopies = read $ Git.configGet g config "1"
			if (numcopies > length remotes)
				then notEnoughCopies numcopies (length remotes) []
				else findcopies numcopies 0 remotes []
	where
		config = "annex.numcopies"
		findcopies need have [] bad = 
			if (have >= need)
				then return True
				else notEnoughCopies need have bad
		findcopies need have (r:rs) bad = do
			all <- Annex.supportedBackends
			result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
			case (result) of
				Right True	-> findcopies need (have+1) rs bad
				Right False	-> findcopies need have rs bad
				Left _		-> findcopies need have rs (r:bad)
		remoteHasKey remote all = do
			-- To check if a remote has a key, construct a new
			-- Annex monad and query its backend.
			a <- Annex.new remote all
			(result, _) <- Annex.run a (Backend.hasKey key)
			return result
		notEnoughCopies need have bad = do
			unsafe
			showLongNote $
				"Could only verify the existence of " ++
				(show have) ++ " out of " ++ (show need) ++ 
				" necessary copies"
			if (0 /= length bad) then showTriedRemotes bad else return ()
			showLocations key
			hint
			return False
		unsafe = showNote "unsafe"
		hint = showLongNote $ "(Use --force to override this check, or adjust annex.numcopies.)"

showLocations :: Key -> Annex ()
showLocations key = do
	g <- Annex.gitRepo
	u <- getUUID g
	uuids <- liftIO $ keyLocations g key
	let uuidsf = filter (\v -> v /= u) uuids
	ppuuids <- prettyPrintUUIDs uuidsf
	if (0 < length uuidsf)
		then showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
		else showLongNote $ "No other repository is known to contain the file."
		
showTriedRemotes remotes =
	showLongNote $ "I was unable to access these remotes: " ++
		(Remotes.list remotes)