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.
-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.MakeRemote where
import Assistant.Common

View file

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

View file

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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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"

View file

@ -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 $

View file

@ -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"

View file

@ -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. -}

View file

@ -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