everything is building again

However, the test suite fails some quickchecks, so this branch is not
yet in a mergeable state.
This commit is contained in:
Joey Hess 2019-12-05 15:10:23 -04:00
parent c20f4704a7
commit 3266ad3ff7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
14 changed files with 51 additions and 35 deletions

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.MakeRemote where module Assistant.MakeRemote where
import Assistant.Common import Assistant.Common

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.MakeRepo where module Assistant.MakeRepo where
import Assistant.WebApp.Common import Assistant.WebApp.Common

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Sync where module Assistant.Sync where
import Assistant.Common import Assistant.Common

View file

@ -286,7 +286,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
ks = keySource ld ks = keySource ld
doadd = sanitycheck ks $ do doadd = sanitycheck ks $ do
(mkey, _mcache) <- liftAnnex $ do (mkey, _mcache) <- liftAnnex $ do
showStart "add" $ keyFilename ks showStart "add" $ toRawFilePath $ keyFilename ks
ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
maybe (failedingest change) (done change $ keyFilename ks) mkey maybe (failedingest change) (done change $ keyFilename ks) mkey
add _ _ = return Nothing 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 :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c -> mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ changeFile c catKeyFile $ toRawFilePath $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks) M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> 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 done change file key = liftAnnex $ do
logStatus key InfoPresent logStatus key InfoPresent
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
stagePointerFile file mode =<< hashPointerFile key stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
showEndOk showEndOk
return $ Just $ finishedChange change key return $ Just $ finishedChange change key
@ -457,5 +457,5 @@ checkChangeContent change@(Change { changeInfo = i }) =
handleDrops "file renamed" present k af [] handleDrops "file renamed" present k af []
where where
f = changeFile change f = changeFile change
af = AssociatedFile (Just f) af = AssociatedFile (Just (toRawFilePath f))
checkChangeContent _ = noop checkChangeContent _ = noop

View file

@ -44,7 +44,8 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
when (old /= new) $ do when (old /= new) $ do
let changedconfigs = new `S.difference` old let changedconfigs = new `S.difference` old
debug $ "reloading config" : debug $ "reloading config" :
map fst (S.toList changedconfigs) map (fromRawFilePath . fst)
(S.toList changedconfigs)
reloadConfigs new reloadConfigs new
{- Record a commit to get this config {- Record a commit to get this config
- change pushed out to remotes. -} - change pushed out to remotes. -}
@ -53,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
loop new loop new
{- Config files, and their checksums. -} {- 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. -} {- All git-annex's config files, and actions to run when they change. -}
configFilesActions :: [(FilePath, Assistant ())] configFilesActions :: [(RawFilePath, Assistant ())]
configFilesActions = configFilesActions =
[ (uuidLog, void $ liftAnnex uuidDescMapLoad) [ (uuidLog, void $ liftAnnex uuidDescMapLoad)
, (remoteLog, void $ liftAnnex remoteListRefresh) , (remoteLog, void $ liftAnnex remoteListRefresh)
@ -89,5 +90,5 @@ getConfigs :: Assistant Configs
getConfigs = S.fromList . map extract getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files)
where where
files = map fst configFilesActions files = map (fromRawFilePath . fst) configFilesActions
extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) extract treeitem = (toRawFilePath $ getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)

View file

@ -155,10 +155,11 @@ dailyCheck urlrenderer = do
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
forM_ unstaged $ \file -> do forM_ unstaged $ \file -> do
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file let file' = fromRawFilePath file
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file'
case ms of case ms of
Just s | toonew (statusChangeTime s) now -> noop Just s | toonew (statusChangeTime s) now -> noop
| isSymbolicLink s -> addsymlink file ms | isSymbolicLink s -> addsymlink file' ms
_ -> noop _ -> noop
liftIO $ void cleanup liftIO $ void cleanup

View file

@ -136,10 +136,12 @@ startupScan scanner = do
-- Notice any files that were deleted before -- Notice any files that were deleted before
-- watching was started. -- watching was started.
top <- liftAnnex $ fromRepo Git.repoPath top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted
[toRawFilePath top]
forM_ fs $ \f -> do forM_ fs $ \f -> do
liftAnnex $ onDel' f let f' = fromRawFilePath f
maybe noop recordChange =<< madeChange f RmChange liftAnnex $ onDel' f'
maybe noop recordChange =<< madeChange f' RmChange
void $ liftIO cleanup void $ liftIO cleanup
liftAnnex $ showAction "started" liftAnnex $ showAction "started"
@ -206,7 +208,7 @@ shouldRestage ds = scanComplete ds || forceRestage ds
onAddUnlocked :: Bool -> GetFileMatcher -> Handler onAddUnlocked :: Bool -> GetFileMatcher -> Handler
onAddUnlocked symlinkssupported matcher f fs = do onAddUnlocked symlinkssupported matcher f fs = do
mk <- liftIO $ isPointerFile f mk <- liftIO $ isPointerFile $ toRawFilePath f
case mk of case mk of
Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs
Just k -> addlink f k Just k -> addlink f k
@ -228,7 +230,7 @@ onAddUnlocked symlinkssupported matcher f fs = do
logStatus oldkey InfoMissing logStatus oldkey InfoMissing
addlink file key = do addlink file key = do
mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key) madeChange file $ LinkChange (Just key)
onAddUnlocked' onAddUnlocked'
@ -240,7 +242,7 @@ onAddUnlocked'
-> GetFileMatcher -> GetFileMatcher
-> Handler -> Handler
onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do
v <- liftAnnex $ catKeyFile file v <- liftAnnex $ catKeyFile (toRawFilePath file)
case (v, fs) of case (v, fs) of
(Just key, Just filestatus) -> (Just key, Just filestatus) ->
ifM (liftAnnex $ samefilestatus key file filestatus) ifM (liftAnnex $ samefilestatus key file filestatus)
@ -270,7 +272,8 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
guardSymlinkStandin mk a guardSymlinkStandin mk a
| symlinkssupported = a | symlinkssupported = a
| otherwise = do | otherwise = do
linktarget <- liftAnnex $ getAnnexLinkTarget file linktarget <- liftAnnex $ getAnnexLinkTarget $
toRawFilePath file
case linktarget of case linktarget of
Nothing -> a Nothing -> a
Just lt -> do Just lt -> do
@ -287,7 +290,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
onAddSymlink :: Handler onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do onAddSymlink file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (lookupFile file) kv <- liftAnnex (lookupFile (toRawFilePath file))
onAddSymlink' linktarget kv file filestatus onAddSymlink' linktarget kv file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Handler onAddSymlink' :: Maybe String -> Maybe Key -> Handler
@ -299,7 +302,7 @@ onAddSymlink' linktarget mk file filestatus = go mk
then ensurestaged (Just link) =<< getDaemonStatus then ensurestaged (Just link) =<< getDaemonStatus
else do else do
liftAnnex $ replaceFile file $ liftAnnex $ replaceFile file $
makeAnnexLink link makeAnnexLink link . toRawFilePath
addLink file link (Just key) addLink file link (Just key)
-- other symlink, not git-annex -- other symlink, not git-annex
go Nothing = ensurestaged linktarget =<< getDaemonStatus go Nothing = ensurestaged linktarget =<< getDaemonStatus
@ -332,8 +335,8 @@ addLink file link mk = do
case v of case v of
Just (currlink, sha, _type) Just (currlink, sha, _type)
| s2w8 link == L.unpack currlink -> | s2w8 link == L.unpack currlink ->
stageSymlink file sha stageSymlink (toRawFilePath file) sha
_ -> stageSymlink file =<< hashSymlink link _ -> stageSymlink (toRawFilePath file) =<< hashSymlink link
madeChange file $ LinkChange mk madeChange file $ LinkChange mk
onDel :: Handler onDel :: Handler
@ -349,7 +352,7 @@ onDel' file = do
Annex.Queue.addUpdateIndex =<< Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file) inRepo (Git.UpdateIndex.unstageFile file)
where 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 {- 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, - that was inside it from its cache. Since it could reappear at any time,
@ -360,14 +363,15 @@ onDel' file = do
onDelDir :: Handler onDelDir :: Handler
onDelDir dir _ = do onDelDir dir _ = do
debug ["directory deleted", dir] 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 -- Get the events queued up as fast as possible, so the
-- committer sees them all in one block. -- committer sees them all in one block.
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
recordChanges $ map (\f -> Change now f RmChange) fs recordChanges $ map (\f -> Change now f RmChange) fs'
void $ liftIO clean void $ liftIO clean
noChange noChange

View file

@ -161,7 +161,7 @@ genTransfer t info = case transferRemote info of
AssociatedFile Nothing -> noop AssociatedFile Nothing -> noop
AssociatedFile (Just af) -> void $ AssociatedFile (Just af) -> void $
addAlert $ makeAlertFiller True $ addAlert $ makeAlertFiller True $
transferFileAlert direction True af transferFileAlert direction True (fromRawFilePath af)
unless isdownload $ unless isdownload $
handleDrops handleDrops
("object uploaded to " ++ show remote) ("object uploaded to " ++ show remote)

View file

@ -87,7 +87,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
hook <- asIO1 $ distributionDownloadComplete d dest cleanup hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook 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) =<< liftAnnex (remoteFromUUID webUUID)
startTransfer t startTransfer t
k = mkKey $ const $ distributionKey d k = mkKey $ const $ distributionKey d

View file

@ -101,11 +101,12 @@ setRepoConfig uuid mremote oldc newc = do
- there's not. Special remotes don't normally - there's not. Special remotes don't normally
- have that, and don't use it. Temporarily add - have that, and don't use it. Temporarily add
- it if it's missing. -} - 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) needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch)
when needfetch $ when needfetch $
inRepo $ Git.Command.run inRepo $ Git.Command.run
[Param "config", Param remotefetch, Param ""] [Param "config", Param (Git.fromConfigKey remotefetch), Param ""]
inRepo $ Git.Command.run inRepo $ Git.Command.run
[ Param "remote" [ Param "remote"
, Param "rename" , Param "rename"

View file

@ -336,7 +336,7 @@ getFinishAddDriveR drive = go
isnew <- liftIO $ makeRepo dir True isnew <- liftIO $ makeRepo dir True
{- Removable drives are not reliable media, so enable fsync. -} {- Removable drives are not reliable media, so enable fsync. -}
liftIO $ inDir dir $ liftIO $ inDir dir $
setConfig (ConfigKey "core.fsyncobjectfiles") setConfig "core.fsyncobjectfiles"
(Git.Config.boolConfig True) (Git.Config.boolConfig True)
(u, r) <- a isnew (u, r) <- a isnew
when isnew $ when isnew $

View file

@ -20,7 +20,7 @@ import Types.StandardGroups
import Utility.UserInfo import Utility.UserInfo
import Utility.Gpg import Utility.Gpg
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
import Git.Types (RemoteName, fromRef) import Git.Types (RemoteName, fromRef, fromConfigKey)
import qualified Remote.GCrypt as GCrypt import qualified Remote.GCrypt as GCrypt
import qualified Annex import qualified Annex
import qualified Git.Command 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 else T.pack $ "Failed to ssh to the server. Transcript: " ++ s
finduuid (k, v) finduuid (k, v)
| k == "annex.uuid" = Just $ toUUID v | k == "annex.uuid" = Just $ toUUID v
| k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v | k == fromConfigKey GCrypt.coreGCryptId =
Just $ genUUIDInNameSpace gCryptNameSpace v
| otherwise = Nothing | otherwise = Nothing
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"

View file

@ -45,7 +45,7 @@ transfersDisplay = do
transferPaused info || isNothing (startedTime info) transferPaused info || isNothing (startedTime info)
desc transfer info = case associatedFile info of desc transfer info = case associatedFile info of
AssociatedFile Nothing -> serializeKey $ transferKey transfer AssociatedFile Nothing -> serializeKey $ transferKey transfer
AssociatedFile (Just af) -> af AssociatedFile (Just af) -> fromRawFilePath af
{- Simplifies a list of transfers, avoiding display of redundant {- Simplifies a list of transfers, avoiding display of redundant
- equivilant transfers. -} - equivilant transfers. -}

View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Command.WebApp where module Command.WebApp where
@ -22,6 +23,7 @@ import Utility.Daemon (checkDaemon)
import Utility.UserInfo import Utility.UserInfo
import Annex.Init import Annex.Init
import qualified Git import qualified Git
import Git.Types (fromConfigValue)
import qualified Git.Config import qualified Git.Config
import qualified Git.CurrentRepo import qualified Git.CurrentRepo
import qualified Annex 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 -} {- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath webBrowser :: Git.Repo -> Maybe FilePath
webBrowser = Git.Config.getMaybe "web.browser" webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser"
fileUrl :: FilePath -> String fileUrl :: FilePath -> String
fileUrl file = "file://" ++ file fileUrl file = "file://" ++ file