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
|
{- A "remote" that is just a local directory.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Directory (remote) where
import IO
import Control.Exception.Extensible (IOException)
import qualified Data.Map as M
import Data.Maybe
import Data.String.Utils
import Control.Monad (when)
import Control.Monad.State (liftIO)
import System.Directory (doesDirectoryExist, doesFileExist, removeFile)
import System.FilePath
import RemoteClass
import Types
import qualified GitRepo as Git
import qualified Annex
import UUID
import Config
import Utility
import Locations
import CopyFile
remote :: RemoteType Annex
remote = RemoteType {
typename = "directory",
enumerate = list,
generate = gen,
setup = dosetup
}
list :: Annex [Git.Repo]
list = do
g <- Annex.gitRepo
return $ findDirectoryRemotes g
findDirectoryRemotes :: Git.Repo -> [Git.Repo]
findDirectoryRemotes r = map construct remotepairs
where
remotepairs = M.toList $ filterremotes $ Git.configMap r
filterremotes = M.filterWithKey (\k _ -> directoryremote k)
construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
directoryremote k = startswith "remote." k && endswith ".annex-directory" k
gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
gen r c = do
u <- getUUID r
cst <- remoteCost r
return $ genRemote r u c cst
where
genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex
genRemote r u c cst = this
where
this = Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = store this,
retrieveKeyFile = retrieve this,
removeKey = remove this,
hasKey = checkPresent this,
hasKeyCheap = True,
config = c
}
dosetup :: UUID -> M.Map String String -> Annex (M.Map String String)
dosetup u c = do
-- verify configuration is sane
let dir = case M.lookup "directory" c of
Nothing -> error "Specify directory="
Just d -> d
e <- liftIO $ doesDirectoryExist dir
when (not e) $ error $ "Directory does not exist: " ++ dir
g <- Annex.gitRepo
liftIO $ do
Git.run g "config" [Param (configsetting "annex-directory"), Param "true"]
Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
return c
where
remotename = fromJust (M.lookup "name" c)
configsetting s = "remote." ++ remotename ++ "." ++ s
dirKey :: Remote Annex -> Key -> FilePath
dirKey r k = dir </> show k
where
dir = fromJust $ M.lookup "directory" $ fromJust $ config r
store :: Remote Annex -> Key -> Annex Bool
store r k = do
g <- Annex.gitRepo
liftIO $ copyFile (gitAnnexLocation g k) (dirKey r k)
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
retrieve r k f = liftIO $ copyFile (dirKey r k) f
remove :: Remote Annex -> Key -> Annex Bool
remove r k = liftIO $ catch
(removeFile (dirKey r k) >> return True)
(const $ return False)
checkPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
checkPresent r k = liftIO $ try $ doesFileExist (dirKey r k)
|
