split cost out into its own module

Added a function to insert a new cost into a list, which could be used to
asjust costs after a drag and drop.

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