summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-08-17 10:42:14 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-08-17 10:42:14 -0400
commit29826eaa3d217a722a291b30fba5f9eda98ff518 (patch)
treed1458e3ddc08bf9cfac80650b15c40da5b5b6419 /Remote
parent7b7d9ed864684aa3d82640780d69c5285750ab03 (diff)
refactor
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Glacier.hs3
-rw-r--r--Remote/Helper/Messages.hs11
-rw-r--r--Remote/Hook.hs3
-rw-r--r--Remote/Rsync.hs3
-rw-r--r--Remote/S3.hs5
-rw-r--r--Remote/Web.hs3
-rw-r--r--Remote/WebDAV.hs3
7 files changed, 21 insertions, 10 deletions
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 98b7d6fad..e69903634 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -18,6 +18,7 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
+import Remote.Helper.Messages
import qualified Remote.Helper.AWS as AWS
import Creds
import Utility.Metered
@@ -176,7 +177,7 @@ remove r k = glacierAction r
checkKey :: Remote -> CheckPresent
checkKey r k = do
- showAction $ "checking " ++ name r
+ showChecking r
go =<< glacierEnv (config r) (uuid r)
where
go Nothing = error "cannot check glacier"
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index 30db70fbb..377f2d231 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -5,15 +5,14 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
module Remote.Helper.Messages where
import Common.Annex
import qualified Git
import qualified Types.Remote as Remote
-showChecking :: Git.Repo -> Annex ()
-showChecking r = showAction $ "checking " ++ Git.repoDescribe r
-
class Checkable a where
descCheckable :: a -> String
@@ -23,5 +22,11 @@ instance Checkable Git.Repo where
instance Checkable (Remote.RemoteA a) where
descCheckable = Remote.name
+instance Checkable String where
+ descCheckable = id
+
+showChecking :: Checkable a => a -> Annex ()
+showChecking v = showAction $ "checking " ++ descCheckable v
+
cantCheck :: Checkable a => a -> e
cantCheck v = error $ "unable to check " ++ descCheckable v
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 259a44bcd..98eeeb031 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -16,6 +16,7 @@ import Config
import Config.Cost
import Annex.UUID
import Remote.Helper.Special
+import Remote.Helper.Messages
import Utility.Env
import Messages.Progress
@@ -138,7 +139,7 @@ remove h k = runHook h "remove" k Nothing $ return True
checkKey :: Git.Repo -> HookName -> CheckPresent
checkKey r h k = do
- showAction $ "checking " ++ Git.repoDescribe r
+ showChecking r
v <- lookupHook h action
liftIO $ check v
where
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index be9629b26..829a2661a 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -27,6 +27,7 @@ import Annex.Content
import Annex.UUID
import Annex.Ssh
import Remote.Helper.Special
+import Remote.Helper.Messages
import Remote.Rsync.RsyncUrl
import Crypto
import Utility.Rsync
@@ -222,7 +223,7 @@ remove o k = do
checkKey :: Git.Repo -> RsyncOpts -> CheckPresent
checkKey r o k = do
- showAction $ "checking " ++ Git.repoDescribe r
+ showChecking r
-- note: Does not currently differentiate between rsync failing
-- to connect, and the file not being present.
untilTrue (rsyncUrls o k) $ \u ->
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 1290e784a..fe407f204 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -39,6 +39,7 @@ import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Http
+import Remote.Helper.Messages
import qualified Remote.Helper.AWS as AWS
import Creds
import Annex.UUID
@@ -269,7 +270,7 @@ remove info h k
checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent
checkKey r info (Just h) k = do
- showAction $ "checking " ++ name r
+ showChecking r
#if MIN_VERSION_aws(0,10,0)
rsp <- go
return (isJust $ S3.horMetadata rsp)
@@ -300,7 +301,7 @@ checkKey r info Nothing k = case getpublicurl info of
warnMissingCredPairFor "S3" (AWS.creds $ uuid r)
error "No S3 credentials configured"
Just geturl -> do
- showAction $ "checking " ++ name r
+ showChecking r
withUrlOptions $ checkBoth (geturl k) (keySize k)
{- Generate the bucket if it does not already exist, including creating the
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 9892f4c98..357522836 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -11,6 +11,7 @@ module Remote.Web (remote) where
import Common.Annex
import Types.Remote
+import Remote.Helper.Messages
import qualified Git
import qualified Git.Construct
import Annex.Content
@@ -112,7 +113,7 @@ checkKey key = do
checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u
- showAction $ "checking " ++ u'
+ showChecking u'
case downloader of
QuviDownloader ->
#ifdef WITH_QUVI
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 6cc53964e..730093a3b 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -25,6 +25,7 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
+import Remote.Helper.Messages
import Remote.Helper.Http
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Creds
@@ -147,7 +148,7 @@ remove (Just dav) k = liftIO $ do
checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent
checkKey r _ Nothing _ = error $ name r ++ " not configured"
checkKey r chunkconfig (Just dav) k = do
- showAction $ "checking " ++ name r
+ showChecking r
case chunkconfig of
LegacyChunks _ -> checkKeyLegacyChunked dav k
_ -> do