From 3266ad3ff7b4cdc50cc0593c698f25da7155c7f8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 5 Dec 2019 15:10:23 -0400 Subject: [PATCH] everything is building again However, the test suite fails some quickchecks, so this branch is not yet in a mergeable state. --- Assistant/MakeRemote.hs | 2 ++ Assistant/MakeRepo.hs | 2 ++ Assistant/Sync.hs | 2 ++ Assistant/Threads/Committer.hs | 8 +++--- Assistant/Threads/ConfigMonitor.hs | 11 ++++---- Assistant/Threads/SanityChecker.hs | 5 ++-- Assistant/Threads/Watcher.hs | 34 ++++++++++++++----------- Assistant/TransferSlots.hs | 2 +- Assistant/Upgrade.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 5 ++-- Assistant/WebApp/Configurators/Local.hs | 2 +- Assistant/WebApp/Configurators/Ssh.hs | 5 ++-- Assistant/WebApp/DashBoard.hs | 2 +- Command/WebApp.hs | 4 ++- 14 files changed, 51 insertions(+), 35 deletions(-) diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 99d68ab82d..ba4df37f97 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRemote where import Assistant.Common diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index 67e83ef5cd..f1dac121d2 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRepo where import Assistant.WebApp.Common diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index c528cf565f..4a90b09943 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Sync where import Assistant.Common diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 09fac0b311..5ed49166bb 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -286,7 +286,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do ks = keySource ld doadd = sanitycheck ks $ do (mkey, _mcache) <- liftAnnex $ do - showStart "add" $ keyFilename ks + showStart "add" $ toRawFilePath $ keyFilename ks ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing maybe (failedingest change) (done change $ keyFilename ks) mkey add _ _ = return Nothing @@ -325,7 +325,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do mks <- forM (filter isRmChange l) $ \c -> - catKeyFile $ changeFile c + catKeyFile $ toRawFilePath $ changeFile c M.fromList . concat <$> mapM mkpairs (catMaybes mks) where mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> @@ -339,7 +339,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do done change file key = liftAnnex $ do logStatus key InfoPresent mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - stagePointerFile file mode =<< hashPointerFile key + stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key showEndOk return $ Just $ finishedChange change key @@ -457,5 +457,5 @@ checkChangeContent change@(Change { changeInfo = i }) = handleDrops "file renamed" present k af [] where f = changeFile change - af = AssociatedFile (Just f) + af = AssociatedFile (Just (toRawFilePath f)) checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index cbfd8c823b..cabda5d259 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,8 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs when (old /= new) $ do let changedconfigs = new `S.difference` old debug $ "reloading config" : - map fst (S.toList changedconfigs) + map (fromRawFilePath . fst) + (S.toList changedconfigs) reloadConfigs new {- Record a commit to get this config - change pushed out to remotes. -} @@ -53,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs loop new {- Config files, and their checksums. -} -type Configs = S.Set (FilePath, Sha) +type Configs = S.Set (RawFilePath, Sha) {- All git-annex's config files, and actions to run when they change. -} -configFilesActions :: [(FilePath, Assistant ())] +configFilesActions :: [(RawFilePath, Assistant ())] configFilesActions = [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remoteListRefresh) @@ -89,5 +90,5 @@ getConfigs :: Assistant Configs getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) where - files = map fst configFilesActions - extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) + files = map (fromRawFilePath . fst) configFilesActions + extract treeitem = (toRawFilePath $ getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index bc65d9aa6f..28beacb2ea 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -155,10 +155,11 @@ dailyCheck urlrenderer = do (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + let file' = fromRawFilePath file + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file' case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink file ms + | isSymbolicLink s -> addsymlink file' ms _ -> noop liftIO $ void cleanup diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 67c986301b..5322998644 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -136,10 +136,12 @@ startupScan scanner = do -- Notice any files that were deleted before -- watching was started. top <- liftAnnex $ fromRepo Git.repoPath - (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] + (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted + [toRawFilePath top] forM_ fs $ \f -> do - liftAnnex $ onDel' f - maybe noop recordChange =<< madeChange f RmChange + let f' = fromRawFilePath f + liftAnnex $ onDel' f' + maybe noop recordChange =<< madeChange f' RmChange void $ liftIO cleanup liftAnnex $ showAction "started" @@ -206,7 +208,7 @@ shouldRestage ds = scanComplete ds || forceRestage ds onAddUnlocked :: Bool -> GetFileMatcher -> Handler onAddUnlocked symlinkssupported matcher f fs = do - mk <- liftIO $ isPointerFile f + mk <- liftIO $ isPointerFile $ toRawFilePath f case mk of Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs Just k -> addlink f k @@ -228,7 +230,7 @@ onAddUnlocked symlinkssupported matcher f fs = do logStatus oldkey InfoMissing addlink file key = do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - liftAnnex $ stagePointerFile file mode =<< hashPointerFile key + liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) onAddUnlocked' @@ -240,7 +242,7 @@ onAddUnlocked' -> GetFileMatcher -> Handler onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do - v <- liftAnnex $ catKeyFile file + v <- liftAnnex $ catKeyFile (toRawFilePath file) case (v, fs) of (Just key, Just filestatus) -> ifM (liftAnnex $ samefilestatus key file filestatus) @@ -270,7 +272,8 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss guardSymlinkStandin mk a | symlinkssupported = a | otherwise = do - linktarget <- liftAnnex $ getAnnexLinkTarget file + linktarget <- liftAnnex $ getAnnexLinkTarget $ + toRawFilePath file case linktarget of Nothing -> a Just lt -> do @@ -287,7 +290,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) - kv <- liftAnnex (lookupFile file) + kv <- liftAnnex (lookupFile (toRawFilePath file)) onAddSymlink' linktarget kv file filestatus onAddSymlink' :: Maybe String -> Maybe Key -> Handler @@ -299,7 +302,7 @@ onAddSymlink' linktarget mk file filestatus = go mk then ensurestaged (Just link) =<< getDaemonStatus else do liftAnnex $ replaceFile file $ - makeAnnexLink link + makeAnnexLink link . toRawFilePath addLink file link (Just key) -- other symlink, not git-annex go Nothing = ensurestaged linktarget =<< getDaemonStatus @@ -332,8 +335,8 @@ addLink file link mk = do case v of Just (currlink, sha, _type) | s2w8 link == L.unpack currlink -> - stageSymlink file sha - _ -> stageSymlink file =<< hashSymlink link + stageSymlink (toRawFilePath file) sha + _ -> stageSymlink (toRawFilePath file) =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler @@ -349,7 +352,7 @@ onDel' file = do Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.unstageFile file) where - withkey a = maybe noop a =<< catKeyFile file + withkey a = maybe noop a =<< catKeyFile (toRawFilePath file) {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, @@ -360,14 +363,15 @@ onDel' file = do onDelDir :: Handler onDelDir dir _ = do debug ["directory deleted", dir] - (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [toRawFilePath dir] + let fs' = map fromRawFilePath fs - liftAnnex $ mapM_ onDel' fs + liftAnnex $ mapM_ onDel' fs' -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - recordChanges $ map (\f -> Change now f RmChange) fs + recordChanges $ map (\f -> Change now f RmChange) fs' void $ liftIO clean noChange diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 6dacefbf45..5b555548e7 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -161,7 +161,7 @@ genTransfer t info = case transferRemote info of AssociatedFile Nothing -> noop AssociatedFile (Just af) -> void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True af + transferFileAlert direction True (fromRawFilePath af) unless isdownload $ handleDrops ("object uploaded to " ++ show remote) diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 53eeac3222..0ea52f3158 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -87,7 +87,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> s { transferHook = M.insert k hook (transferHook s) } - maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t) + maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t) =<< liftAnnex (remoteFromUUID webUUID) startTransfer t k = mkKey $ const $ distributionKey d diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 1237f22339..b711761a42 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -101,11 +101,12 @@ setRepoConfig uuid mremote oldc newc = do - there's not. Special remotes don't normally - have that, and don't use it. Temporarily add - it if it's missing. -} - let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch" + let remotefetch = Git.ConfigKey $ encodeBS' $ + "remote." ++ T.unpack (repoName oldc) ++ ".fetch" needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch) when needfetch $ inRepo $ Git.Command.run - [Param "config", Param remotefetch, Param ""] + [Param "config", Param (Git.fromConfigKey remotefetch), Param ""] inRepo $ Git.Command.run [ Param "remote" , Param "rename" diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index eb52be0093..faf3cde57e 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -336,7 +336,7 @@ getFinishAddDriveR drive = go isnew <- liftIO $ makeRepo dir True {- Removable drives are not reliable media, so enable fsync. -} liftIO $ inDir dir $ - setConfig (ConfigKey "core.fsyncobjectfiles") + setConfig "core.fsyncobjectfiles" (Git.Config.boolConfig True) (u, r) <- a isnew when isnew $ diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index b140e99dcc..9ed76bef48 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -20,7 +20,7 @@ import Types.StandardGroups import Utility.UserInfo import Utility.Gpg import Types.Remote (RemoteConfig) -import Git.Types (RemoteName, fromRef) +import Git.Types (RemoteName, fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex import qualified Git.Command @@ -317,7 +317,8 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do else T.pack $ "Failed to ssh to the server. Transcript: " ++ s finduuid (k, v) | k == "annex.uuid" = Just $ toUUID v - | k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v + | k == fromConfigKey GCrypt.coreGCryptId = + Just $ genUUIDInNameSpace gCryptNameSpace v | otherwise = Nothing checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 09a1e5f047..6b9d8787cb 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ transfersDisplay = do transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of AssociatedFile Nothing -> serializeKey $ transferKey transfer - AssociatedFile (Just af) -> af + AssociatedFile (Just af) -> fromRawFilePath af {- Simplifies a list of transfers, avoiding display of redundant - equivilant transfers. -} diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 3f8002d68b..95bd8af9d4 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Command.WebApp where @@ -22,6 +23,7 @@ import Utility.Daemon (checkDaemon) import Utility.UserInfo import Annex.Init import qualified Git +import Git.Types (fromConfigValue) import qualified Git.Config import qualified Git.CurrentRepo import qualified Annex @@ -229,7 +231,7 @@ openBrowser' mcmd htmlshim realurl outh errh = {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath -webBrowser = Git.Config.getMaybe "web.browser" +webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser" fileUrl :: FilePath -> String fileUrl file = "file://" ++ file