From 29826eaa3d217a722a291b30fba5f9eda98ff518 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 17 Aug 2015 10:42:14 -0400 Subject: refactor --- Remote/Glacier.hs | 3 ++- Remote/Helper/Messages.hs | 11 ++++++++--- Remote/Hook.hs | 3 ++- Remote/Rsync.hs | 3 ++- Remote/S3.hs | 5 +++-- Remote/Web.hs | 3 ++- Remote/WebDAV.hs | 3 ++- 7 files changed, 21 insertions(+), 10 deletions(-) (limited to 'Remote') 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 -- cgit v1.2.3