diff options
34 files changed, 280 insertions, 89 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 4a36de66a..021cd3926 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -189,7 +189,7 @@ change file a = lockJournal $ a <$> getStale file >>= set file {- Records new content of a file into the journal -} set :: FilePath -> String -> Annex () -set file content = setJournalFile file content +set = setJournalFile {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex () @@ -197,7 +197,7 @@ commit message = whenM journalDirty $ lockJournal $ do cleanjournal <- stageJournal ref <- getBranch withIndex $ commitBranch ref message [fullname] - liftIO $ cleanjournal + liftIO cleanjournal {- Commits the staged changes in the index to the branch. - @@ -355,7 +355,7 @@ stageJournal = withIndex $ do Git.UpdateIndex.streamUpdateIndex g [genstream dir h fs] hashObjectStop h - return $ liftIO $ mapM_ removeFile $ map (dir </>) fs + return $ liftIO $ mapM_ (removeFile . (dir </>)) fs where genstream dir h fs streamer = forM_ fs $ \file -> do let path = dir </> file diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index bbf6e310d..25e257918 100644 --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -139,11 +139,10 @@ sameFileStatus :: Key -> FileStatus -> Annex Bool sameFileStatus key status = do old <- recordedInodeCache key let curr = toInodeCache status - r <- case (old, curr) of + case (old, curr) of (Just o, Just c) -> compareInodeCaches o c (Nothing, Nothing) -> return True _ -> return False - return r {- If the inodes have changed, only the size and mtime are compared. -} compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool diff --git a/Annex/Direct.hs b/Annex/Direct.hs index a88a045e7..7836ceb96 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -122,7 +122,7 @@ mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex () mergeDirectCleanup d oldsha newsha = do (items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha forM_ items updated - void $ liftIO $ cleanup + void $ liftIO cleanup liftIO $ removeDirectoryRecursive d where updated item = do diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index c32402baf..220fea286 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -47,7 +47,7 @@ parsedToMatcher parsed = case partitionEithers parsed of parseToken :: MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) parseToken checkpresent groupmap t - | any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t + | t `elem` tokens = Right $ token t | t == "present" = use checkpresent | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ M.fromList @@ -61,7 +61,7 @@ parseToken checkpresent groupmap t ] where (k, v) = separate (== '=') t - use a = Utility.Matcher.Operation <$> a v + use a = Operation <$> a v {- This is really dumb tokenization; there's no support for quoted values. - Open and close parens are always treated as standalone tokens; @@ -76,7 +76,7 @@ tokenizeMatcher = filter (not . null ) . concatMap splitparens . words largeFilesMatcher :: Annex FileMatcher largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig where - go Nothing = return $ matchAll + go Nothing = return matchAll go (Just expr) = do m <- groupMap u <- getUUID diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index a8bd1f7b6..0b8ce3b93 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -79,7 +79,7 @@ sshCacheDir gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR" usetmpdir tmpdir = liftIO $ catchMaybeIO $ do createDirectoryIfMissing True tmpdir - return $ tmpdir + return tmpdir portParams :: Maybe Integer -> [CommandParam] portParams Nothing = [] diff --git a/Assistant.hs b/Assistant.hs index 8ea6692e3..a436070b3 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -154,6 +154,7 @@ import Assistant.Threads.XMPPClient #warning Building without the webapp. You probably need to install Yesod.. #endif import Assistant.Environment +import Assistant.Types.UrlRenderer import qualified Utility.Daemon import Utility.LogFile import Utility.ThreadScheduler @@ -196,7 +197,8 @@ startDaemon assistant foreground startbrowser = do | otherwise = "watch" start daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch - when assistant $ checkEnvironment + when assistant + checkEnvironment dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexLogFile liftIO $ debugM desc $ "logging to " ++ logfile @@ -204,15 +206,16 @@ startDaemon assistant foreground startbrowser = do flip runAssistant (go webappwaiter) =<< newAssistantData st dstatus - go webappwaiter = do - notice ["starting", desc, "version", SysConfig.packageversion] + #ifdef WITH_WEBAPP + go webappwaiter = do d <- getAssistant id - urlrenderer <- liftIO newUrlRenderer - mapM_ (startthread $ Just urlrenderer) #else - mapM_ (startthread Nothing) + go _webappwaiter = do #endif + notice ["starting", desc, "version", SysConfig.packageversion] + urlrenderer <- liftIO newUrlRenderer + mapM_ (startthread urlrenderer) [ watch $ commitThread #ifdef WITH_WEBAPP , assist $ webAppThread d urlrenderer False Nothing webappwaiter @@ -237,7 +240,7 @@ startDaemon assistant foreground startbrowser = do #endif , assist $ netWatcherThread , assist $ netWatcherFallbackThread - , assist $ transferScannerThread + , assist $ transferScannerThread urlrenderer , assist $ configMonitorThread , assist $ glacierThread , watch $ watchThread diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 206694031..81dc362e4 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -34,6 +34,7 @@ data AlertName | WarningAlert String | PairAlert String | XMPPNeededAlert + | RemoteRemovalAlert String | CloudRepoNeededAlert | SyncAlert deriving (Eq) @@ -351,6 +352,23 @@ cloudRepoNeededAlert friendname button = Alert , alertData = [] } +remoteRemovalAlert :: String -> AlertButton -> Alert +remoteRemovalAlert desc button = Alert + { alertHeader = Just $ fromString $ + "The repository \"" ++ desc ++ + "\" has been emptied, and can now be removed." + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = tenseWords + , alertBlockDisplay = True + , alertName = Just $ RemoteRemovalAlert desc + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + fileAlert :: TenseChunk -> FilePath -> Alert fileAlert msg file = (activityAlert Nothing [f]) { alertName = Just $ FileAlert msg diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs new file mode 100644 index 000000000..25dd7720f --- /dev/null +++ b/Assistant/DeleteRemote.hs @@ -0,0 +1,88 @@ +{- git-annex assistant remote deletion utilities + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.DeleteRemote where + +import Assistant.Common +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import Assistant.WebApp +#endif +import Assistant.TransferQueue +import Logs.Transfer +import Logs.Location +import Assistant.Alert +import Assistant.DaemonStatus +import Assistant.Types.UrlRenderer +import qualified Remote +import Remote.List +import qualified Git.Command +import Logs.Trust +import qualified Annex + +import qualified Data.Text as T + +{- Removes a remote (but leave the repository as-is), and returns the old + - Remote data. -} +removeRemote :: UUID -> Assistant Remote +removeRemote uuid = do + remote <- fromMaybe (error "unknown remote") + <$> liftAnnex (Remote.remoteFromUUID uuid) + liftAnnex $ do + inRepo $ Git.Command.run + [ Param "remote" + , Param "remove" + , Param (Remote.name remote) + ] + void $ remoteListRefresh + updateSyncRemotes + return remote + +{- Called when a Remote is probably empty, to remove it. + - + - This does one last check for any objects remaining in the Remote, + - and if there are any, queues Downloads of them, and defers removing + - the remote for later. This is to catch any objects not referred to + - in keys in the current branch. + -} +removableRemote :: UrlRenderer -> UUID -> Assistant () +removableRemote urlrenderer uuid = do + keys <- getkeys + if null keys + then finishRemovingRemote urlrenderer uuid + else do + r <- fromMaybe (error "unknown remote") + <$> liftAnnex (Remote.remoteFromUUID uuid) + mapM_ (queueremaining r) keys + where + queueremaining r k = + queueTransferWhenSmall "remaining object in unwanted remote" + Nothing (Transfer Download uuid k) r + {- Scanning for keys can take a long time; do not tie up + - the Annex monad while doing it, so other threads continue to + - run. -} + getkeys = do + a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid + liftIO a + +finishRemovingRemote :: UrlRenderer -> UUID -> Assistant () +finishRemovingRemote urlrenderer uuid = do + void $ removeRemote uuid + liftAnnex $ trustSet uuid DeadTrusted + +#ifdef WITH_WEBAPP + desc <- liftAnnex $ Remote.prettyUUID uuid + url <- liftIO $ renderUrl urlrenderer (FinishedDeletingRepositoryContentsR uuid) [] + close <- asIO1 removeAlert + void $ addAlert $ remoteRemovalAlert desc $ AlertButton + { buttonLabel = T.pack "Finish removal" + , buttonUrl = url + , buttonAction = Just close + } +#endif diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 33af2c304..1d291ba74 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -13,6 +13,7 @@ import Common.Annex import Assistant.Types.NamedThread import Assistant.Types.ThreadName import Assistant.Types.DaemonStatus +import Assistant.Types.UrlRenderer import Assistant.DaemonStatus import Assistant.Monad @@ -32,13 +33,8 @@ import qualified Data.Text as T - - Named threads are run by a management thread, so if they crash - an alert is displayed, allowing the thread to be restarted. -} -#ifdef WITH_WEBAPP -startNamedThread :: Maybe UrlRenderer -> NamedThread -> Assistant () -startNamedThread urlrenderer namedthread@(NamedThread name a) = do -#else -startNamedThread :: Maybe Bool -> NamedThread -> Assistant () +startNamedThread :: UrlRenderer -> NamedThread -> Assistant () startNamedThread urlrenderer namedthread@(NamedThread name a) = do -#endif m <- startedThreads <$> getDaemonStatus case M.lookup name m of Nothing -> start @@ -69,17 +65,14 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do ] hPutStrLn stderr msg #ifdef WITH_WEBAPP - button <- runAssistant d $ - case urlrenderer of - Nothing -> return Nothing - Just renderer -> do - close <- asIO1 removeAlert - url <- liftIO $ renderUrl renderer (RestartThreadR name) [] - return $ Just $ AlertButton - { buttonLabel = T.pack "Restart Thread" - , buttonUrl = url - , buttonAction = Just close - } + button <- runAssistant d $ do + close <- asIO1 removeAlert + url <- liftIO $ renderUrl urlrenderer (RestartThreadR name) [] + return $ Just $ AlertButton + { buttonLabel = T.pack "Restart Thread" + , buttonUrl = url + , buttonAction = Just close + } runAssistant d $ void $ addAlert $ (warningAlert (fromThreadName name) msg) { alertButton = button } diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 4698a0d30..46695469e 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -14,8 +14,11 @@ import Assistant.TransferQueue import Assistant.DaemonStatus import Assistant.Drop import Assistant.Sync +import Assistant.DeleteRemote +import Assistant.Types.UrlRenderer import Logs.Transfer import Logs.Location +import Logs.Group import Logs.Web (webUUID) import qualified Remote import qualified Types.Remote as Remote @@ -31,8 +34,8 @@ import qualified Data.Set as S {- This thread waits until a remote needs to be scanned, to find transfers - that need to be made, to keep data in sync. -} -transferScannerThread :: NamedThread -transferScannerThread = namedThread "TransferScanner" $ do +transferScannerThread :: UrlRenderer -> NamedThread +transferScannerThread urlrenderer = namedThread "TransferScanner" $ do startupScan go S.empty where @@ -43,7 +46,7 @@ transferScannerThread = namedThread "TransferScanner" $ do scanrunning True if any fullScan infos || any (`S.notMember` scanned) rs then do - expensiveScan rs + expensiveScan urlrenderer rs go $ scanned `S.union` S.fromList rs else do mapM_ failedTransferScan rs @@ -67,6 +70,8 @@ transferScannerThread = namedThread "TransferScanner" $ do - * We may have run before, and had transfers queued, - and then the system (or us) crashed, and that info was - lost. + - * A remote may be in the unwanted group, and this is a chance + - to determine if the remote has been emptied. -} startupScan = do reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus @@ -103,26 +108,45 @@ failedTransferScan r = do - - TODO: It would be better to first drop as much as we can, before - transferring much, to minimise disk use. + - + - During the scan, we'll also check if any unwanted repositories are empty, + - and can be removed. While unrelated, this is a cheap place to do it, + - since we need to look at the locations of all keys anyway. -} -expensiveScan :: [Remote] -> Assistant () -expensiveScan rs = unless onlyweb $ do +expensiveScan :: UrlRenderer -> [Remote] -> Assistant () +expensiveScan urlrenderer rs = unless onlyweb $ do debug ["starting scan of", show visiblers] + + unwantedrs <- liftAnnex $ S.fromList + <$> filterM inUnwantedGroup (map Remote.uuid rs) + g <- liftAnnex gitRepo (files, cleanup) <- liftIO $ LsFiles.inRepo [] g - forM_ files $ \f -> do - ts <- maybe (return []) (findtransfers f) - =<< liftAnnex (Backend.lookupFile f) - mapM_ (enqueue f) ts + removablers <- scan unwantedrs files void $ liftIO cleanup + debug ["finished scan of", show visiblers] + + remove <- asIO1 $ removableRemote urlrenderer + liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers where onlyweb = all (== webUUID) $ map Remote.uuid rs visiblers = let rs' = filter (not . Remote.readonly) rs in if null rs' then rs else rs' + + scan unwanted [] = return unwanted + scan unwanted (f:fs) = do + (unwanted', ts) <- maybe + (return (unwanted, [])) + (findtransfers f unwanted) + =<< liftAnnex (Backend.lookupFile f) + mapM_ (enqueue f) ts + scan unwanted' fs + enqueue f (r, t) = queueTransferWhenSmall "expensive scan found missing object" (Just f) t r - findtransfers f (key, _) = do + findtransfers f unwanted (key, _) = do {- The syncable remotes may have changed since this - scan began. -} syncrs <- syncDataRemotes <$> getDaemonStatus @@ -134,11 +158,13 @@ expensiveScan rs = unless onlyweb $ do liftAnnex $ do let slocs = S.fromList locs let use a = return $ catMaybes $ map (a key slocs) syncrs - if present + ts <- if present then filterM (wantSend True (Just f) . Remote.uuid . fst) =<< use (genTransfer Upload False) else ifM (wantGet True $ Just f) ( use (genTransfer Download True) , return [] ) + let unwanted' = S.difference unwanted slocs + return (unwanted', ts) genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) genTransfer direction want key slocs r diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs index 0e884637a..a65edc20d 100644 --- a/Assistant/Types/NamedThread.hs +++ b/Assistant/Types/NamedThread.hs @@ -14,4 +14,4 @@ import Assistant.Types.ThreadName data NamedThread = NamedThread ThreadName (Assistant ()) namedThread :: String -> Assistant () -> NamedThread -namedThread name a = NamedThread (ThreadName name) a +namedThread = NamedThread . ThreadName diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 05e51045d..1ea7db7ce 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -104,7 +104,7 @@ getSide side m = m side data NetMessager = NetMessager -- outgoing messages - { netMessages :: TChan (NetMessage) + { netMessages :: TChan NetMessage -- important messages for each client , importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) -- important messages that are believed to have been sent to a client diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs new file mode 100644 index 000000000..521905bf3 --- /dev/null +++ b/Assistant/Types/UrlRenderer.hs @@ -0,0 +1,26 @@ +{- webapp url renderer access from the assistant + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Types.UrlRenderer ( + UrlRenderer, + newUrlRenderer +) where + +#ifdef WITH_WEBAPP + +import Assistant.WebApp (UrlRenderer, newUrlRenderer) + +#else + +data UrlRenderer = UrlRenderer -- dummy type + +newUrlRenderer :: IO UrlRenderer +newUrlRenderer = return UrlRenderer + +#endif diff --git a/Backend.hs b/Backend.hs index 8bf29846c..2ee14acc6 100644 --- a/Backend.hs +++ b/Backend.hs @@ -94,8 +94,7 @@ lookupFile file = do where makeret k = let bname = keyBackendName k in case maybeLookupBackendName bname of - Just backend -> do - return $ Just (k, backend) + Just backend -> return $ Just (k, backend) Nothing -> do warning $ "skipping " ++ file ++ diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 0d232fcdf..33d6f536a 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -103,7 +103,7 @@ firstRun = do v <- newEmptyMVar let callback a = Just $ a v runAssistant d $ do - startNamedThread (Just urlrenderer) $ + startNamedThread urlrenderer $ webAppThread d urlrenderer True (callback signaler) (callback mainthread) @@ -92,7 +92,7 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv Just credpair -> do writeCacheCredPair credpair storage return $ Just credpair - _ -> do error $ "bad creds" + _ -> error "bad creds" {- Gets a CredPair from the environment. -} getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair) @@ -100,7 +100,7 @@ encryptCipher :: Cipher -> KeyIds -> IO StorableCipher encryptCipher (Cipher c) (KeyIds ks) = do -- gpg complains about duplicate recipient keyids let ks' = nub $ sort ks - encipher <- Gpg.pipeStrict ([ Params "--encrypt" ] ++ recipients ks') c + encipher <- Gpg.pipeStrict (Params "--encrypt" : recipients ks') c return $ EncryptedCipher encipher (KeyIds ks') where recipients l = force_recipients : @@ -33,7 +33,7 @@ import Backend genDescription :: Maybe String -> Annex String genDescription (Just d) = return d genDescription Nothing = do - hostname <- maybe "" id <$> liftIO getHostname + hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" username <- liftIO myUserName reldir <- liftIO . relHome =<< fromRepo Git.repoPath @@ -132,7 +132,7 @@ probeCrippledFileSystem = do return True checkCrippledFileSystem :: Annex () -checkCrippledFileSystem = whenM (probeCrippledFileSystem) $ do +checkCrippledFileSystem = whenM probeCrippledFileSystem $ do warning "Detected a crippled filesystem." setCrippledFileSystem True unlessM isDirect $ do @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE PackageImports, CPP #-} +{-# LANGUAGE CPP #-} module Limit where @@ -128,7 +128,7 @@ limitIn name = Right $ \notpresent -> check $ limitPresent :: Maybe UUID -> MkLimit limitPresent u _ = Right $ const $ check $ \key -> do hereu <- getUUID - if u == Just hereu || u == Nothing + if u == Just hereu || isNothing u then inAnnex key else do us <- Remote.keyLocations key @@ -146,7 +146,7 @@ addCopies = addLimit . limitCopies limitCopies :: MkLimit limitCopies want = case split ":" want of [v, n] -> case parsetrustspec v of - Just pred -> go n $ checktrust pred + Just checker -> go n $ checktrust checker Nothing -> go n $ checkgroup v [n] -> go n $ const $ return True _ -> Left "bad value for copies" @@ -160,7 +160,7 @@ limitCopies want = case split ":" want of us <- filter (`S.notMember` notpresent) <$> (filterM good =<< Remote.keyLocations key) return $ length us >= n - checktrust pred u = pred <$> lookupTrust u + checktrust checker u = checker <$> lookupTrust u checkgroup g u = S.member g <$> lookupGroups u parsetrustspec s | "+" `isSuffixOf` s = (>=) <$> readTrustLevel (beginning s) diff --git a/Logs/Group.hs b/Logs/Group.hs index a069edcdf..85906f0a7 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -13,6 +13,7 @@ module Logs.Group ( groupMap, groupMapLoad, getStandardGroup, + inUnwantedGroup ) where import qualified Data.Map as M @@ -66,11 +67,15 @@ makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap makeGroupMap byuuid = GroupMap byuuid bygroup where bygroup = M.fromListWith S.union $ - concat $ map explode $ M.toList byuuid + concatMap explode $ M.toList byuuid explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) {- If a repository is in exactly one standard group, returns it. -} getStandardGroup :: S.Set Group -> Maybe StandardGroup -getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of +getStandardGroup s = case mapMaybe toStandardGroup $ S.toList s of [g] -> Just g _ -> Nothing + +inUnwantedGroup :: UUID -> Annex Bool +inUnwantedGroup u = elem UnwantedGroup + . mapMaybe toStandardGroup . S.toList <$> lookupGroups u diff --git a/Logs/Remote.hs b/Logs/Remote.hs index 55fb40f4b..89792b054 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -93,7 +93,7 @@ prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c -- whitespace and '=' are not supported in keys - | any (\k -> any isSpace k || any (== '=') k) (M.keys c) = True + | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True | otherwise = parseConfig (showConfig c) ~~ Just c where normalize v = sort . M.toList <$> v diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 921d8f815..778932510 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -130,8 +130,8 @@ runTransfer t file shouldretry a = do Just fd -> do locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) - when (locked == Nothing) $ - error $ "transfer already in progress" + when (isNothing locked) $ + error "transfer already in progress" void $ tryIO $ writeTransferInfoFile info tfile return mfd cleanup _ Nothing = noop @@ -169,7 +169,7 @@ mkProgressUpdater t info = do where updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do let newbytes = fromBytesProcessed b - if (newbytes - oldbytes >= mindelta) + if newbytes - oldbytes >= mindelta then do let info' = info { bytesComplete = Just newbytes } _ <- tryIO $ writeTransferInfoFile info' tfile @@ -213,7 +213,7 @@ checkTransfer t = do {- Gets all currently running transfers. -} getTransfers :: Annex [(Transfer, TransferInfo)] getTransfers = do - transfers <- catMaybes . map parseTransferFile . concat <$> findfiles + transfers <- mapMaybe parseTransferFile . concat <$> findfiles infos <- mapM checkTransfer transfers return $ map (\(t, Just i) -> (t, i)) $ filter running $ zip transfers infos @@ -265,7 +265,7 @@ transferLockFile infofile = let (d,f) = splitFileName infofile in {- Parses a transfer information filename to a Transfer. -} parseTransferFile :: FilePath -> Maybe Transfer parseTransferFile file - | "lck." `isPrefixOf` (takeFileName file) = Nothing + | "lck." `isPrefixOf` takeFileName file = Nothing | otherwise = case drop (length bits - 3) bits of [direction, u, key] -> Transfer <$> readLcDirection direction @@ -291,17 +291,17 @@ writeTransferInfoFile info tfile = do writeTransferInfo :: TransferInfo -> String writeTransferInfo info = unlines [ (maybe "" show $ startedTime info) ++ - (maybe "" (\b -> " " ++ show b) $ bytesComplete info) + (maybe "" (\b -> ' ' : show b) (bytesComplete info)) , fromMaybe "" $ associatedFile info -- comes last; arbitrary content ] -readTransferInfoFile :: (Maybe ProcessID) -> FilePath -> IO (Maybe TransferInfo) +readTransferInfoFile :: Maybe ProcessID -> FilePath -> IO (Maybe TransferInfo) readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ do h <- openFile tfile ReadMode fileEncoding h hClose h `after` (readTransferInfo mpid <$> hGetContentsStrict h) -readTransferInfo :: (Maybe ProcessID) -> String -> Maybe TransferInfo +readTransferInfo :: Maybe ProcessID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo <$> time <*> pure mpid @@ -353,8 +353,8 @@ instance Arbitrary TransferInfo where prop_read_write_transferinfo :: TransferInfo -> Bool prop_read_write_transferinfo info - | transferRemote info /= Nothing = True -- remote not stored - | transferTid info /= Nothing = True -- tid not stored + | isJust (transferRemote info) = True -- remote not stored + | isJust (transferTid info) = True -- tid not stored | otherwise = Just (info { transferPaused = False }) == info' where info' = readTransferInfo (transferPid info) (writeTransferInfo info) diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 058250740..89a5404f7 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -70,7 +70,7 @@ trustPartition level ls return $ partition (`elem` candidates) ls {- Filters UUIDs to those not matching a TrustLevel. -} -trustExclude :: TrustLevel -> [UUID] -> Annex ([UUID]) +trustExclude :: TrustLevel -> [UUID] -> Annex [UUID] trustExclude level ls = snd <$> trustPartition level ls {- trustLog in a map, overridden with any values from forcetrust or diff --git a/Logs/Unused.hs b/Logs/Unused.hs index bef78a992..437b01f71 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -31,7 +31,7 @@ readUnusedLog :: FilePath -> Annex UnusedMap readUnusedLog prefix = do f <- fromRepo $ gitAnnexUnusedLog prefix ifM (liftIO $ doesFileExist f) - ( M.fromList . catMaybes . map parse . lines + ( M.fromList . mapMaybe parse . lines <$> liftIO (readFile f) , return M.empty ) diff --git a/Messages.hs b/Messages.hs index 13b786a31..cc82b9050 100644 --- a/Messages.hs +++ b/Messages.hs @@ -71,7 +71,7 @@ showProgress = handle q $ {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} -metered :: (Maybe MeterUpdate) -> Key -> (MeterUpdate -> Annex a) -> Annex a +metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a metered combinemeterupdate key a = go (keySize key) where go (Just size) = meteredBytes combinemeterupdate size a @@ -79,7 +79,7 @@ metered combinemeterupdate key a = go (keySize key) {- Shows a progress meter while performing an action on a given number - of bytes. -} -meteredBytes :: (Maybe MeterUpdate) -> Integer -> (MeterUpdate -> Annex a) -> Annex a +meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a meteredBytes combinemeterupdate size a = withOutputType go where go NormalOutput = do diff --git a/Messages/JSON.hs b/Messages/JSON.hs index e262192a8..d57d69318 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -34,7 +34,4 @@ add :: JSON a => [(String, a)] -> IO () add v = putStr $ Stream.add v complete :: JSON a => [(String, a)] -> IO () -complete v = putStr $ concat - [ Stream.start v - , Stream.end - ] +complete v = putStr $ Stream.start v ++ Stream.end @@ -28,6 +28,7 @@ module Remote ( byCost, prettyPrintUUIDs, prettyListUUIDs, + prettyUUID, remoteFromUUID, remotesWithUUID, remotesWithoutUUID, @@ -150,7 +151,7 @@ prettyListUUIDs :: [UUID] -> Annex [String] prettyListUUIDs uuids = do hereu <- getUUID m <- uuidDescriptions - return $ map (\u -> prettify m hereu u) uuids + return $ map (prettify m hereu) uuids where finddescription m u = M.findWithDefault "" u m prettify m hereu u @@ -159,6 +160,10 @@ prettyListUUIDs uuids = do where n = finddescription m u +{- Nice display of a remote's name and/or description. -} +prettyUUID :: UUID -> Annex String +prettyUUID u = concat <$> prettyListUUIDs [u] + {- Gets the remote associated with a UUID. - There's no associated remote when this is the UUID of the local repo. -} remoteFromUUID :: UUID -> Annex (Maybe Remote) diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 9563b43e8..a5750437d 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -127,7 +127,7 @@ retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k undefined f , return False ) retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool -retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do +retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> ifM (retrieve o enck undefined tmp) ( liftIO $ catchBoolIO $ do decrypt cipher (feedFile tmp) $ @@ -28,7 +28,7 @@ seekHelper a params = do runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params {- Show warnings only for files/directories that do not exist. -} forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> - unlessM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus p)) $ + unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ fileNotFound p return $ concat ll @@ -72,7 +72,7 @@ main = do divider propigate rs qcok where - divider = putStrLn $ take 70 $ repeat '-' + divider = putStrLn $ replicate 70 '-' propigate :: [Counts] -> Bool -> IO () propigate cs qcok diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 246c320d0..ff7cd3c90 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -122,8 +122,8 @@ extractRemoteGitConfig r remotename = RemoteGitConfig getbool k def = fromMaybe def $ getmaybebool k getmaybebool k = Git.Config.isTrue =<< getmaybe k getmayberead k = readish =<< getmaybe k - getmaybe k = maybe (Git.Config.getMaybe (key k) r) Just $ - Git.Config.getMaybe (remotekey k) r + getmaybe k = mplus (Git.Config.getMaybe (key k) r) + (Git.Config.getMaybe (remotekey k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k key k = "annex." ++ k diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 2262c3bde..434600f3f 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -57,17 +57,17 @@ descStandardGroup UnwantedGroup = "unwanted: remove content from this repository preferredContent :: StandardGroup -> String preferredContent ClientGroup = lastResort "exclude=*/archive/* and exclude=archive/*" -preferredContent TransferGroup = lastResort $ +preferredContent TransferGroup = lastResort "not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup preferredContent BackupGroup = "include=*" -preferredContent IncrementalBackupGroup = lastResort $ +preferredContent IncrementalBackupGroup = lastResort "include=* and (not copies=incrementalbackup:1)" preferredContent SmallArchiveGroup = lastResort $ "(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup -preferredContent FullArchiveGroup = lastResort $ +preferredContent FullArchiveGroup = lastResort "not (copies=archive:1 or copies=smallarchive:1)" preferredContent SourceGroup = "not (copies=1)" -preferredContent ManualGroup = lastResort $ +preferredContent ManualGroup = lastResort "present and exclude=*/archive/* and exclude=archive/*" preferredContent UnwantedGroup = "exclude=*" diff --git a/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn b/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn index 599b15280..39b860e7c 100644 --- a/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn +++ b/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn @@ -58,3 +58,8 @@ Running the whole thing with --debug doesn't appear to provide anything useful: [1] + exit 139 GITWRAP annex webapp --debug [0 zerodogg@browncoats annexed]$ Created new window in existing browser session. + +> On IRC it developed that it segfaulted at other times, and gdb complained +> of a library mismatch. Seems something changed in Fedora libc, and +> the 32 bit binary is not working on 64 bit. I've brought back the 64 bit +> standalone builds, which work. [[done]] --[[Joey]] diff --git a/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn b/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn new file mode 100644 index 000000000..f8b450216 --- /dev/null +++ b/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn @@ -0,0 +1,27 @@ +Getting back to the repository removal handling from Sunday, I made the +assistant detect when a repository that has been marked as unwanted becomes +empty, and finish the removal process. + +I was able to add this to the expensive transfer scan without making it any +more expensive than it already was, since that scan already looks at the +location of all keys. Although when a remote is detected as empty, it then +does one more check, equivilant to `git annex unused`, to find any +remaining objects on the remote, and force them off. + +I think this should work pretty well, but it needs some testing and +probably some UI work. + +---- + +Andy spotted a bug in the preferred content expressions I was using to +handle untrusted remotes. So he saved me several hours dealing with an ugly +bug at some point down the line. I had misread my own preferred content +expression documentation, and `copies=semitrusted:1` was not doing what I +thought it was. Added a new syntax that does what I need, +`copies=semitrusted+:1` + +---- + +The 64 bit linux standalone builds are back. Apparently the 32 bit builds +have stopped working on recent Fedora, for reasons that are unclear. I set +up an autobuilder to produce the 64 bit builds. |