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:
parent
c20f4704a7
commit
3266ad3ff7
14 changed files with 51 additions and 35 deletions
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.MakeRemote where
|
||||
|
||||
import Assistant.Common
|
||||
|
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.MakeRepo where
|
||||
|
||||
import Assistant.WebApp.Common
|
||||
|
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.Sync where
|
||||
|
||||
import Assistant.Common
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue