summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/MakeRemote.hs3
-rw-r--r--Assistant/Pairing/MakeRemote.hs1
-rw-r--r--Assistant/Types/ScanRemotes.hs2
-rw-r--r--Config.hs32
-rw-r--r--Config/Cost.hs79
-rw-r--r--Remote/Bup.hs3
-rw-r--r--Remote/Directory.hs1
-rw-r--r--Remote/Git.hs1
-rw-r--r--Remote/Glacier.hs1
-rw-r--r--Remote/Helper/Encryptable.hs2
-rw-r--r--Remote/Hook.hs1
-rw-r--r--Remote/Rsync.hs1
-rw-r--r--Remote/S3.hs1
-rw-r--r--Remote/Web.hs1
-rw-r--r--Remote/WebDAV.hs1
-rw-r--r--Test.hs4
-rw-r--r--Types/GitConfig.hs3
-rw-r--r--Types/Remote.hs3
18 files changed, 103 insertions, 37 deletions
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index 8d4e3a1ba..448f7ad97 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -21,12 +21,13 @@ import Logs.UUID
import Logs.Remote
import Git.Remote
import Config
+import Config.Cost
import qualified Data.Text as T
import qualified Data.Map as M
{- Sets up and begins syncing with a new ssh or rsync remote. -}
-makeSshRemote :: Bool -> SshData -> Maybe Int -> Assistant Remote
+makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
makeSshRemote forcersync sshdata mcost = do
r <- liftAnnex $
addRemote $ maker (sshRepoName sshdata) sshurl
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index e4aab434d..ff5688bd3 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -13,6 +13,7 @@ import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.MakeRemote
import Config
+import Config.Cost
import Network.Socket
import qualified Data.Text as T
diff --git a/Assistant/Types/ScanRemotes.hs b/Assistant/Types/ScanRemotes.hs
index d2f0c588f..8219f9baf 100644
--- a/Assistant/Types/ScanRemotes.hs
+++ b/Assistant/Types/ScanRemotes.hs
@@ -13,7 +13,7 @@ import Control.Concurrent.STM
import qualified Data.Map as M
data ScanInfo = ScanInfo
- { scanPriority :: Int
+ { scanPriority :: Float
, fullScan :: Bool
}
diff --git a/Config.hs b/Config.hs
index b732f982f..4d93a2af5 100644
--- a/Config.hs
+++ b/Config.hs
@@ -13,6 +13,7 @@ import qualified Git.Config
import qualified Git.Command
import qualified Annex
import qualified Types.Remote as Remote
+import Config.Cost
type UnqualifiedConfigKey = String
data ConfigKey = ConfigKey String
@@ -44,43 +45,16 @@ annexConfig key = ConfigKey $ "annex." ++ key
{- Calculates cost for a remote. Either the specific default, or as configured
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
- is set and prints a number, that is used. -}
-remoteCost :: RemoteGitConfig -> Int -> Annex Int
+remoteCost :: RemoteGitConfig -> Cost -> Annex Cost
remoteCost c def = case remoteAnnexCostCommand c of
Just cmd | not (null cmd) -> liftIO $
(fromMaybe def . readish) <$>
readProcess "sh" ["-c", cmd]
_ -> return $ fromMaybe def $ remoteAnnexCost c
-setRemoteCost :: Remote -> Int -> Annex ()
+setRemoteCost :: Remote -> Cost -> Annex ()
setRemoteCost r c = setConfig (remoteConfig (Remote.repo r) "cost") (show c)
-cheapRemoteCost :: Int
-cheapRemoteCost = 100
-semiCheapRemoteCost :: Int
-semiCheapRemoteCost = 110
-semiExpensiveRemoteCost :: Int
-semiExpensiveRemoteCost = 175
-expensiveRemoteCost :: Int
-expensiveRemoteCost = 200
-veryExpensiveRemoteCost :: Int
-veryExpensiveRemoteCost = 1000
-
-{- Adjusts a remote's cost to reflect it being encrypted. -}
-encryptedRemoteCostAdj :: Int
-encryptedRemoteCostAdj = 50
-
-{- Make sure the remote cost numbers work out. -}
-prop_cost_sane :: Bool
-prop_cost_sane = False `notElem`
- [ expensiveRemoteCost > 0
- , cheapRemoteCost < semiCheapRemoteCost
- , semiCheapRemoteCost < semiExpensiveRemoteCost
- , semiExpensiveRemoteCost < expensiveRemoteCost
- , cheapRemoteCost + encryptedRemoteCostAdj > semiCheapRemoteCost
- , cheapRemoteCost + encryptedRemoteCostAdj < semiExpensiveRemoteCost
- , semiCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
- ]
-
getNumCopies :: Maybe Int -> Annex Int
getNumCopies (Just v) = return v
getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig
diff --git a/Config/Cost.hs b/Config/Cost.hs
new file mode 100644
index 000000000..dd3968e78
--- /dev/null
+++ b/Config/Cost.hs
@@ -0,0 +1,79 @@
+{- Remote costs.
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Config.Cost where
+
+{- We use a float for a cost to ensure that there is a cost in
+ - between any two other costs. -}
+type Cost = Float
+
+{- Some predefined default costs.
+ - Users setting costs in config files can be aware of these,
+ - and pick values relative to them. So don't change. -}
+cheapRemoteCost :: Cost
+cheapRemoteCost = 100
+nearlyCheapRemoteCost :: Cost
+nearlyCheapRemoteCost = 110
+semiExpensiveRemoteCost :: Cost
+semiExpensiveRemoteCost = 175
+expensiveRemoteCost :: Cost
+expensiveRemoteCost = 200
+veryExpensiveRemoteCost :: Cost
+veryExpensiveRemoteCost = 1000
+
+{- Adjusts a remote's cost to reflect it being encrypted. -}
+encryptedRemoteCostAdj :: Cost
+encryptedRemoteCostAdj = 50
+
+{- Given an ordered list of costs, and the position of one of the items
+ - the list, inserts a new cost into the list, in between the item
+ - and the item after it.
+ -
+ - If both items have the same cost, one of them will have its cost
+ - adjusted to make room. The costs of other items in the list are left
+ - unchanged.
+ -
+ - To insert the new cost before any other in the list, specify a negative
+ - position. To insert the new cost at the end of the list, specify a
+ - position longer than the list.
+ -}
+insertCostAfter :: [Cost] -> Int -> [Cost]
+insertCostAfter [] _ = error "insertCostAfter: empty list"
+insertCostAfter l pos
+ | pos < 0 = costBetween 0 (l !! 0) : l
+ | nextpos > maxpos = l ++ [1 + l !! maxpos]
+ | item == nextitem =
+ let (_dup:new:l') = insertCostAfter lastsegment 0
+ in firstsegment ++ [costBetween item new, new] ++ l'
+ | otherwise =
+ firstsegment ++ [costBetween item nextitem ] ++ lastsegment
+ where
+ nextpos = pos + 1
+ maxpos = length l - 1
+
+ item = l !! pos
+ nextitem = l !! nextpos
+
+ (firstsegment, lastsegment) = splitAt (pos + 1) l
+
+costBetween :: Cost -> Cost -> Cost
+costBetween x y
+ | x == y = x
+ | x > y = y + (x - y) / 2
+ | otherwise = costBetween y x
+
+{- Make sure the remote cost numbers work out. -}
+prop_cost_sane :: Bool
+prop_cost_sane = False `notElem`
+ [ expensiveRemoteCost > 0
+ , cheapRemoteCost < nearlyCheapRemoteCost
+ , nearlyCheapRemoteCost < semiExpensiveRemoteCost
+ , semiExpensiveRemoteCost < expensiveRemoteCost
+ , cheapRemoteCost + encryptedRemoteCostAdj > nearlyCheapRemoteCost
+ , nearlyCheapRemoteCost + encryptedRemoteCostAdj < semiExpensiveRemoteCost
+ , nearlyCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
+ ]
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index a598e5599..43d28a40f 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -20,6 +20,7 @@ import qualified Git.Config
import qualified Git.Construct
import qualified Git.Ref
import Config
+import Config.Cost
import Remote.Helper.Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
@@ -44,7 +45,7 @@ gen r u c gc = do
bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $
if bupLocal buprepo
- then semiCheapRemoteCost
+ then nearlyCheapRemoteCost
else expensiveRemoteCost
(u', bupr') <- getBupUUID bupr u
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 141586938..da75fb794 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -16,6 +16,7 @@ import Data.Int
import Common.Annex
import Types.Remote
import qualified Git
+import Config.Cost
import Config
import Utility.FileMode
import Remote.Helper.Special
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 0de453522..b08166bfa 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -35,6 +35,7 @@ import qualified Annex.Branch
import qualified Utility.Url as Url
import Utility.TempFile
import Config
+import Config.Cost
import Init
import Types.Key
import qualified Fields
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index bd2f0a179..b7e002b3d 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -16,6 +16,7 @@ import Types.Remote
import Types.Key
import qualified Git
import Config
+import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import qualified Remote.Helper.AWS as AWS
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index d322a5cf8..242fcfe8a 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -13,7 +13,7 @@ import Common.Annex
import Types.Remote
import Crypto
import qualified Annex
-import Config
+import Config.Cost
import Utility.Base64
{- Encryption setup for a remote. The user must specify whether to use
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 9fbd632d6..b6b4d8788 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -16,6 +16,7 @@ import Types.Remote
import Types.Key
import qualified Git
import Config
+import Config.Cost
import Annex.Content
import Remote.Helper.Special
import Remote.Helper.Encryptable
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index a7a830ef9..c303316ab 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -15,6 +15,7 @@ import Common.Annex
import Types.Remote
import qualified Git
import Config
+import Config.Cost
import Annex.Content
import Remote.Helper.Special
import Remote.Helper.Encryptable
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 164e384f5..8d487de22 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -21,6 +21,7 @@ import Types.Remote
import Types.Key
import qualified Git
import Config
+import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import qualified Remote.Helper.AWS as AWS
diff --git a/Remote/Web.hs b/Remote/Web.hs
index f984137a9..38546c717 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -13,6 +13,7 @@ import qualified Git
import qualified Git.Construct
import Annex.Content
import Config
+import Config.Cost
import Logs.Web
import qualified Utility.Url as Url
import Types.Key
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index b1c2ee4a8..a06a4eb11 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -24,6 +24,7 @@ import Common.Annex
import Types.Remote
import qualified Git
import Config
+import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Remote.Helper.Chunked
diff --git a/Test.hs b/Test.hs
index 308769b26..a383a0a48 100644
--- a/Test.hs
+++ b/Test.hs
@@ -42,7 +42,7 @@ import qualified Logs.Presence
import qualified Remote
import qualified Types.Key
import qualified Types.Messages
-import qualified Config
+import qualified Config.Cost
import qualified Crypto
import qualified Utility.Path
import qualified Utility.FileMode
@@ -102,7 +102,7 @@ quickcheck =
, check "prop_parentDir_basics" Utility.Path.prop_parentDir_basics
, check "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics
, check "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest
- , check "prop_cost_sane" Config.prop_cost_sane
+ , check "prop_cost_sane" Config.Cost.prop_cost_sane
, check "prop_hmacWithCipher_sane" Crypto.prop_hmacWithCipher_sane
, check "prop_TimeStamp_sane" Logs.UUIDBased.prop_TimeStamp_sane
, check "prop_addLog_sane" Logs.UUIDBased.prop_addLog_sane
diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index 9c6de59d7..b42f8f229 100644
--- a/Types/GitConfig.hs
+++ b/Types/GitConfig.hs
@@ -16,6 +16,7 @@ import Common
import qualified Git
import qualified Git.Config
import Utility.DataUnits
+import Config.Cost
{- Main git-annex settings. Each setting corresponds to a git-config key
- such as annex.foo -}
@@ -77,7 +78,7 @@ extractGitConfig r = GitConfig
- key such as <remote>.annex-foo, or if that is not set, a default from
- annex.foo -}
data RemoteGitConfig = RemoteGitConfig
- { remoteAnnexCost :: Maybe Int
+ { remoteAnnexCost :: Maybe Cost
, remoteAnnexCostCommand :: Maybe String
, remoteAnnexIgnore :: Bool
, remoteAnnexSync :: Bool
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 05763e4d3..b8c603c65 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -17,6 +17,7 @@ import Types.Key
import Types.UUID
import Types.Meters
import Types.GitConfig
+import Config.Cost
type RemoteConfigKey = String
type RemoteConfig = M.Map RemoteConfigKey String
@@ -46,7 +47,7 @@ data RemoteA a = Remote {
-- each Remote has a human visible name
name :: String,
-- Remotes have a use cost; higher is more expensive
- cost :: Int,
+ cost :: Cost,
-- Transfers a key to the remote.
storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,
-- retrieves a key's contents to a file
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-29 07:19:37 +0000