Finally compiles again, and test suite passes.
This commit was sponsored by Brock Spratlen on Patreon.
importordownload cidmap db (loc, (cid, sz)) largematcher= do
f <- locworktreefile loc
- matcher <- largematcher (fromRawFilePath f)
+ matcher <- largematcher f
-- When importing a key is supported, always use it rather
-- than downloading and retrieving a key, to avoid
-- generating trees with different keys for the same content.
let af = AssociatedFile (Just f)
let downloader p' tmpfile = do
k' <- Remote.retrieveExportWithContentIdentifier
- ia loc cid tmpfile
+ ia loc cid (fromRawFilePath tmpfile)
(pure k)
(combineMeterUpdate p' p)
ok <- moveAnnex k' tmpfile
doimportsmall cidmap db loc cid sz p = do
let downloader tmpfile = do
k <- Remote.retrieveExportWithContentIdentifier
- ia loc cid tmpfile
+ ia loc cid (fromRawFilePath tmpfile)
(mkkey tmpfile)
p
case keyGitSha k of
let af = AssociatedFile (Just f)
let downloader tmpfile p = do
k <- Remote.retrieveExportWithContentIdentifier
- ia loc cid tmpfile
+ ia loc cid (fromRawFilePath tmpfile)
(mkkey tmpfile)
p
case keyGitSha k of
mkkey tmpfile = do
let mi = MatchingFile FileInfo
{ matchFile = f
- , contentFile = Just (toRawFilePath tmpfile)
+ , contentFile = Just tmpfile
}
islargefile <- checkMatcher' matcher mi mempty
if islargefile
then do
- backend <- chooseBackend (fromRawFilePath f)
+ backend <- chooseBackend f
let ks = KeySource
{ keyFilename = f
, contentLocation = tmpfile
nohardlink = withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do
- cache <- genInodeCache (toRawFilePath file) delta
+ cache <- genInodeCache file' delta
return $ LockedDown cfg $ KeySource
{ keyFilename = file'
, contentLocation = file'
gitAnnexDir r P.</> "misctmp"
{- .git/annex/watchtmp/ is used by the watcher and assistant -}
-gitAnnexTmpWatcherDir :: Git.Repo -> FilePath
-gitAnnexTmpWatcherDir r = fromRawFilePath $
- P.addTrailingPathSeparator $ gitAnnexDir r P.</> "watchtmp"
+gitAnnexTmpWatcherDir :: Git.Repo -> RawFilePath
+gitAnnexTmpWatcherDir r = P.addTrailingPathSeparator $
+ gitAnnexDir r P.</> "watchtmp"
{- The temp file to use for a given key's content. -}
gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath
gitAnnexDir r P.</> "daemon.status"
{- Log file for daemon mode. -}
-gitAnnexDaemonLogFile :: Git.Repo -> FilePath
-gitAnnexDaemonLogFile r = fromRawFilePath $ gitAnnexDir r P.</> "daemon.log"
+gitAnnexDaemonLogFile :: Git.Repo -> RawFilePath
+gitAnnexDaemonLogFile r = gitAnnexDir r P.</> "daemon.log"
{- Log file for fuzz test. -}
gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath
gitAnnexDir r P.</> "fuzztest.log"
{- Html shim file used to launch the webapp. -}
-gitAnnexHtmlShim :: Git.Repo -> FilePath
-gitAnnexHtmlShim r = fromRawFilePath $ gitAnnexDir r P.</> "webapp.html"
+gitAnnexHtmlShim :: Git.Repo -> RawFilePath
+gitAnnexHtmlShim r = gitAnnexDir r P.</> "webapp.html"
{- File containing the url to the webapp. -}
-gitAnnexUrlFile :: Git.Repo -> FilePath
-gitAnnexUrlFile r = fromRawFilePath $ gitAnnexDir r P.</> "url"
+gitAnnexUrlFile :: Git.Repo -> RawFilePath
+gitAnnexUrlFile r = gitAnnexDir r P.</> "url"
{- Temporary file used to edit configuriation from the git-annex branch. -}
gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath
import Network.Socket (HostName)
stopDaemon :: Annex ()
-stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
+stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath
+ =<< fromRepo gitAnnexPidFile
{- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser.
enableInteractiveBranchAccess
pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ debugM desc $ "logging to " ++ logfile
+ liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile
createAnnexDirectory (parentDir pidfile)
#ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile)
- logfd <- liftIO $ handleToFd =<< openLog logfile
+ logfd <- liftIO $ handleToFd =<< openLog (fromRawFilePath logfile)
if foreground
then do
origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError
- let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
+ let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile))
start undaemonize $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a origout origerr
else
- start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
+ start (Utility.Daemon.daemonize logfd (Just (fromRawFilePath pidfile)) False) Nothing
#else
-- Windows doesn't daemonize, but does redirect output to the
-- log file. The only way to do so is to restart the program.
checkCanWatch
dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ debugM desc $ "logging to " ++ logfile
+ liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile
liftIO $ daemonize $
flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> error err
Right pubkey -> do
- absdir <- absPath repodir
+ absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
error "failed setting up ssh authorized keys"
remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
Nothing -> return False
Just mkrepair -> do
- thisrepopath <- liftIO . absPath . fromRawFilePath
+ thisrepopath <- liftIO . absPath
=<< liftAnnex (fromRepo Git.repoPath)
a <- liftAnnex $ mkrepair $
- repair fsckresults (Just thisrepopath)
+ repair fsckresults (Just (fromRawFilePath thisrepopath))
liftIO $ catchBoolIO a
repair fsckresults referencerepo = do
import Utility.NotificationBroadcaster
import Utility.Url
import Utility.PID
+import qualified Utility.RawFilePath as R
import qualified Git.Construct
import qualified Git.Config
import qualified Annex
prepRestart :: Assistant ()
prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
- liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
- liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
+ liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
+ liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp.
geturl
where
geturl = do
- r <- Git.Config.read =<< Git.Construct.fromPath repo
- waiturl $ gitAnnexUrlFile r
+ r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo)
+ waiturl $ fromRawFilePath $ gitAnnexUrlFile r
waiturl urlfile = do
v <- tryIO $ readFile urlfile
case v of
liftAnnex $ do
-- Clean up anything left behind by a previous process
-- on unclean shutdown.
- void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
+ void $ liftIO $ tryIO $ removeDirectoryRecursive
+ (fromRawFilePath lockdowndir)
void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do
- readychanges <- handleAdds lockdowndir havelsof delayadd $
+ readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof delayadd $
simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges
then do
let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just lockdowndir
+ , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
}
(postponed, toadd) <- partitionEithers
<$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess
delta <- liftAnnex getTSDelta
let cfg = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just lockdowndir
+ , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
}
if M.null m
then forM toadd (add cfg)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.Sync
import Utility.DirWatcher
import Utility.DirWatcher.Types
+import Utility.Directory.Create
import Annex.CurrentBranch
import qualified Annex
import qualified Annex.Branch
import qualified Git.Ref
import qualified Command.Sync
+import qualified System.FilePath.ByteString as P
+
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
- let gitd = fromRawFilePath (Git.localGitDir g)
- let dir = gitd </> "refs"
+ let gitd = Git.localGitDir g
+ let dir = gitd P.</> "refs"
liftIO $ createDirectoryUnder gitd dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
, modifyHook = changehook
, errHook = errhook
}
- void $ liftIO $ watchDir dir (const False) True hooks id
- debug ["watching", dir]
+ void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
+ debug ["watching", fromRawFilePath dir]
type Handler = FilePath -> Assistant ()
-}
remotesUnder :: FilePath -> Assistant [Remote]
remotesUnder dir = do
- repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
+ repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList
pairs <- liftAnnex $ mapM (checkremote repotop) rs
let (waschanged, rs') = unzip pairs
return $ mapMaybe snd $ filter fst pairs
where
checkremote repotop r = case Remote.localpath r of
- Just p | dirContains dir (absPathFrom repotop p) ->
+ Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) ->
(,) <$> pure True <*> updateRemote r
_ -> return (False, Just r)
-}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
- f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
+ f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM getFileSize logs
when (totalsize > 2 * oneMegabyte) $ do
- temp file being used for the transfer. -}
| transferDirection t == Download = do
let f = gitAnnexTmpObjectLocation (transferKey t) g
- sz <- liftIO $ catchMaybeIO $ getFileSize f
+ sz <- liftIO $ catchMaybeIO $ getFileSize (fromRawFilePath f)
newsize t info sz
{- Uploads don't need to be polled for when the TransferWatcher
- thread can track file modifications. -}
| otherwise = do
let f = transferFile t g
mi <- liftIO $ catchDefaultIO Nothing $
- readTransferInfoFile Nothing f
+ readTransferInfoFile Nothing (fromRawFilePath f)
maybe noop (newsize t info . bytesComplete) mi
newsize t info sz
, modifyHook = modifyhook
, errHook = errhook
}
- void $ liftIO $ watchDir dir (const False) True hooks id
+ void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
debug ["watching for transfers"]
type Handler = FilePath -> Assistant ()
, modifyHook = changed
, delDirHook = changed
}
- let dir = parentDir flagfile
+ let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
import Utility.DirWatcher
import Utility.DirWatcher.Types
import Utility.InodeCache
+import qualified Utility.RawFilePath as R
import qualified Annex
import qualified Annex.Queue
import qualified Git
ig _ = False
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
-unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
+unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file))
( noChange
, a
)
{- Small files are added to git as-is, while large ones go into the annex. -}
add :: GetFileMatcher -> FilePath -> Assistant (Maybe Change)
-add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher file)
+add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath file))
( pendingAddChange file
, do
liftAnnex $ Annex.Queue.addCommand "add"
Nothing -> noop
Just key -> liftAnnex $
addassociatedfile key file
- onAddSymlink' (Just $ fromRawFilePath lt) mk file fs
+ onAddSymlink' (Just lt) mk file fs
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
-}
onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do
- linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
- kv <- liftAnnex (lookupKey (toRawFilePath file))
+ linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
+ kv <- liftAnnex (lookupKey file')
onAddSymlink' linktarget kv file filestatus
+ where
+ file' = toRawFilePath file
-onAddSymlink' :: Maybe String -> Maybe Key -> Handler
+onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
onAddSymlink' linktarget mk file filestatus = go mk
where
go (Just key) = do
- link <- liftAnnex $ calcRepo $ gitAnnexLink file key
+ link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -}
-addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
+addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
debug ["add symlink", file]
liftAnnex $ do
v <- catObjectDetails $ Ref $ encodeBS' $ ':':file
case v of
Just (currlink, sha, _type)
- | s2w8 link == L.unpack currlink ->
+ | L.fromStrict link == currlink ->
stageSymlink (toRawFilePath file) sha
_ -> stageSymlink (toRawFilePath file)
- =<< hashSymlink (toRawFilePath link)
+ =<< hashSymlink link
madeChange file $ LinkChange mk
onDel :: Handler
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
- go tlssettings addr webapp htmlshim (Just urlfile)
+ go tlssettings addr webapp
+ (fromRawFilePath htmlshim)
+ (Just (fromRawFilePath urlfile))
where
-- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while
getreldir
| noannex = return Nothing
| otherwise = Just <$>
- (relHome =<< absPath . fromRawFilePath
- =<< getAnnex' (fromRepo repoPath))
+ (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
+ withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do
let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
unlessM (doesDirectoryExist dir) $
error $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do
- let origdir = parentDir olddir </> installBase
+ let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
removeWhenExistsWith removeLink origdir
createSymbolicLink newdir origdir
oldVersionLocation = readProgramFile >>= \case
Nothing -> error "Cannot find old distribution bundle; not upgrading."
Just pf -> do
- let pdir = parentDir pf
+ let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
#ifdef darwin_HOST_OS
let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -}
return Nothing
where
s = installBase ++ "." ++ distributionVersion d
- topdir = parentDir olddir
+ topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir
newloc = topdir </> s
trymkdir dir fallback =
(createDirectory dir >> return (Just dir))
import Assistant.Sync
import qualified Remote
import qualified Git
-import Config.Files
+import Config.Files.AutoStart
import Logs.Trust
import Logs.Remote
import Logs.PreferredContent
mapM_ (\r -> changeSyncable (Just r) False) rs
liftAnnex $ prepareRemoveAnnexDir dir
- liftIO $ removeDirectoryRecursive =<< absPath dir
+ liftIO $ removeDirectoryRecursive . fromRawFilePath
+ =<< absPath (toRawFilePath dir)
redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository")
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> do
top <- fromRawFilePath <$> fromRepo Git.repoPath
- createWorkTreeDirectory (top </> d)
+ createWorkTreeDirectory (toRawFilePath (top </> d))
Nothing -> noop
_ -> noop
import qualified Git
import qualified Git.Config
import qualified Git.Command
-import Config.Files
+import Config.Files.AutoStart
import Utility.FreeDesktop
import Utility.DiskFree
#ifndef mingw32_HOST_OS
checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
- path <- absPath basepath
- let parent = parentDir path
+ path <- fromRawFilePath <$> absPath (toRawFilePath basepath)
+ let parent = fromRawFilePath $ parentDir (toRawFilePath path)
problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
combineRepos dir name = liftAnnex $ do
hostname <- fromMaybe "host" <$> liftIO getHostname
mylocation <- fromRepo Git.repoLocation
- mypath <- liftIO $ relPathDirToFile dir mylocation
+ mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile
+ (toRawFilePath dir)
+ (toRawFilePath mylocation)
liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
addRemote $ makeGitRemote name dir
canWrite :: FilePath -> IO Bool
canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir)
- (return dir, return $ parentDir dir)
+ ( return dir
+ , return $ fromRawFilePath $ parentDir $ toRawFilePath dir
+ )
catchBoolIO $ fileAccess tocheck False True False
{- Gets the UUID of the git repo at a location, which may not exist, or
import qualified Annex
import qualified Git
import Config
-import Config.Files
+import Config.Files.AutoStart
import Annex.NumCopies
import Utility.DataUnits
import Git.Config
import qualified BuildInfo
import qualified Data.Text as T
+import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm
{ diskReserve :: Text
inAutoStartFile :: Annex Bool
inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath
- any (`equalFilePath` here) . toRawFilePath
+ any (`P.equalFilePath` here) . map toRawFilePath
<$> liftIO readAutoStartFile
getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
- logs <- liftIO $ listLogs logfile
+ logs <- liftIO $ listLogs (fromRawFilePath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log")
- blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool
openFileBrowser = do
- path <- liftIO . absPath . fromRawFilePath
- =<< liftAnnex (fromRepo Git.repoPath)
+ path <- fromRawFilePath
+ <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath))
#ifdef darwin_HOST_OS
let cmd = "open"
let p = proc cmd [path]
import Assistant.Common
import Assistant.WebApp.Types
import Assistant.WebApp.Page
-import Config.Files
+import Config.Files.AutoStart
import Utility.Yesod
import Assistant.Restart
+import qualified Utility.RawFilePath as R
getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
listOtherRepos :: IO [(String, String)]
listOtherRepos = do
dirs <- readAutoStartFile
- pwd <- getCurrentDirectory
+ pwd <- R.getCurrentDirectory
gooddirs <- filterM isrepo $
- filter (\d -> not $ d `dirContains` pwd) dirs
+ filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs
names <- mapM relHome gooddirs
return $ sort $ zip names gooddirs
where
"Restricted login shell for git-annex only SSH access"
where
mkrepo = do
- r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
+ r <- Git.Construct.repoAbsPath (toRawFilePath dir)
+ >>= Git.Construct.fromAbsPath
Git.Config.read r
`catchIO` \_ -> do
hn <- fromMaybe "unknown" <$> getHostname
canondir home d
| "~/" `isPrefixOf` d = return d
| "/~/" `isPrefixOf` d = return $ drop 1 d
- | otherwise = relHome $ fromRawFilePath <$> absPathFrom
+ | otherwise = relHome $ fromRawFilePath $ absPathFrom
(toRawFilePath home)
(toRawFilePath d)
import Control.Concurrent.Async
import System.Posix.Types
import Data.IORef
+import qualified System.FilePath.ByteString as P
data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: SeekInput -> RawFilePath -> Key -> CommandStart
seekFiltered (const (pure True)) a $
seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l
-withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek
+withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
forM_ params $ \p -> do
a f
where
get p = ifM (isDirectory <$> getFileStatus p)
- ( map (\f -> (f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f))
+ ( map (\f ->
+ let f' = toRawFilePath f
+ in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f'))
<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p
- , return [(p, takeFileName p)]
+ , return [(p', P.takeFileName p')]
)
+ where
+ p' = toRawFilePath p
+
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
- { contentFile = Just (toRawFilePath f)
- , matchFile = toRawFilePath relf
+ { contentFile = Just f
+ , matchFile = relf
}
withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek
import Annex.Init
import Annex.Path
import Config.Files
+import Config.Files.AutoStart
import qualified BuildInfo
import Utility.HumanTime
import Assistant.Install
import Git.Types
import Types.Import
import Utility.Metered
+import qualified Utility.RawFilePath as R
import Control.Concurrent.STM
seek :: ImportOptions -> CommandSeek
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
- repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath
- inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
+ repopath <- liftIO . absPath =<< fromRepo Git.repoPath
+ inrepops <- liftIO $ filter (dirContains repopath)
+ <$> mapM (absPath . toRawFilePath) (importFiles o)
unless (null inrepops) $ do
- giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
+ giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords (map fromRawFilePath inrepops)
largematcher <- largeFilesMatcher
addunlockedmatcher <- addUnlockedMatcher
(commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o))
(importToSubDir o)
seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o)
-startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
+startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart
startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
- ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
+ ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile)
( starting "import" ai si pickaction
, stop
)
where
- ai = ActionItemWorkTreeFile destfile'
+ ai = ActionItemWorkTreeFile destfile
si = SeekInput []
- destfile' = toRawFilePath destfile
-
deletedup k = do
showNote $ "duplicate of " ++ serializeKey k
verifyExisting k destfile
( do
- liftIO $ removeFile srcfile
+ liftIO $ R.removeLink srcfile
next $ return True
, do
warning "Could not verify that the content is still present in the annex; not removing from the import location."
ignored <- checkIgnored (checkGitIgnoreOption o) destfile
if ignored
then do
- warning $ "not importing " ++ destfile ++ " which is .gitignored (use --no-check-gitignore to override)"
+ warning $ "not importing " ++ fromRawFilePath destfile ++ " which is .gitignored (use --no-check-gitignore to override)"
stop
else do
- existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
+ existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
case existing of
Nothing -> importfilechecked ld k
Just s
| isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getState Annex.force)
( do
- liftIO $ removeWhenExistsWith removeLink destfile
+ liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k
, notoverwriting "(is a symlink)"
)
| otherwise -> ifM (Annex.getState Annex.force)
( do
- liftIO $ removeWhenExistsWith removeLink destfile
+ liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
)
checkdestdir cont = do
let destdir = parentDir destfile
- existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destdir)
+ existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir)
case existing of
Nothing -> cont
Just s
| isDirectory s -> cont
| otherwise -> do
- warning $ "not importing " ++ destfile ++ " because " ++ destdir ++ " is not a directory"
+ warning $ "not importing " ++ fromRawFilePath destfile ++ " because " ++ fromRawFilePath destdir ++ " is not a directory"
stop
importfilechecked ld k = do
-- The dest file is what will be ingested.
createWorkTreeDirectory (parentDir destfile)
liftIO $ if mode == Duplicate || mode == SkipDuplicates
- then void $ copyFileExternal CopyAllMetaData srcfile destfile
- else moveFile srcfile destfile
+ then void $ copyFileExternal CopyAllMetaData
+ (fromRawFilePath srcfile)
+ (fromRawFilePath destfile)
+ else moveFile
+ (fromRawFilePath srcfile)
+ (fromRawFilePath destfile)
-- Get the inode cache of the dest file. It should be
-- weakly the same as the originally locked down file's
-- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.)
- newcache <- withTSDelta $ liftIO . genInodeCache destfile'
+ newcache <- withTSDelta $ liftIO . genInodeCache destfile
let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True
(Just newc, Just c) | compareWeak c newc -> True
-- is what will be ingested.
let ld' = ld
{ keySource = KeySource
- { keyFilename = destfile'
- , contentLocation = destfile'
+ { keyFilename = destfile
+ , contentLocation = destfile
, inodeCache = newcache
}
}
>>= maybe
stop
(\addedk -> next $ Command.Add.cleanup addedk True)
- , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile'
+ , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile
)
notoverwriting why = do
- warning $ "not overwriting existing " ++ destfile ++ " " ++ why
+ warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why
stop
lockdown a = do
let mi = MatchingFile $ FileInfo
- { contentFile = Just (toRawFilePath srcfile)
- , matchFile = toRawFilePath destfile
+ { contentFile = Just srcfile
+ , matchFile = destfile
}
lockingfile <- not <$> addUnlocked addunlockedmatcher mi
-- Minimal lock down with no hard linking so nothing
{ lockingFile = lockingfile
, hardlinkFileTmpDir = Nothing
}
- v <- lockDown cfg srcfile
+ v <- lockDown cfg (fromRawFilePath srcfile)
case v of
Just ld -> do
backend <- chooseBackend destfile
_ -> importfile ld k
skipbecause s = showNote (s ++ "; skipping") >> next (return True)
-verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform
+verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported.
import qualified Data.Text as T
import System.Log.Logger
import Control.Concurrent.Async
+import qualified System.FilePath.ByteString as P
import Command
import qualified Annex
performDownload addunlockedmatcher opts cache todownload = case location todownload of
Enclosure url -> checkknown url $
rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do
+ let f' = fromRawFilePath f
r <- Remote.claimingUrl url
if Remote.uuid r == webUUID || rawOption (downloadOptions opts)
then do
let dlopts = (downloadOptions opts)
-- force using the filename
-- chosen here
- { fileOption = Just f
+ { fileOption = Just f'
-- don't use youtube-dl
, rawOption = True
}
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz
Right (UrlMulti l) -> do
kl <- forM l $ \(url', sz, subf) ->
- downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f </> sanitizeFilePath subf) sz
+ let dest = f P.</> toRawFilePath (sanitizeFilePath subf)
+ in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz
return $ Just $ if all isJust kl
then catMaybes kl
else []
Nothing -> return True
Just f -> do
showStartOther "addurl" (Just url) (SeekInput [])
- getter f >>= \case
+ getter (toRawFilePath f) >>= \case
Just ks
-- Download problem.
| null ks -> do
| rawOption (downloadOptions opts) = downloadlink
| otherwise = do
r <- withTmpWorkDir mediakey $ \workdir -> do
- dl <- youtubeDl linkurl workdir nullMeterUpdate
+ dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate
case dl of
Right (Just mediafile) -> do
let ext = case takeExtension mediafile of
s -> s
ok <- rundownload linkurl ext $ \f ->
checkCanAdd (downloadOptions opts) f $ \canadd -> do
- addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile))
return (Just [mediakey])
return (Just ok)
-- youtude-dl didn't support it, so
checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool
checkFeedBroken' url f = do
prev <- maybe Nothing readish
- <$> liftIO (catchMaybeIO $ readFile (fromRawFlePath f))
+ <$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f))
now <- liftIO getCurrentTime
case prev of
Nothing -> do
<*> pure (pushOption v)
<*> pure (contentOption v)
<*> pure (noContentOption v)
- <*> liftIO (mapM absPath (contentOfOption v))
+ <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v))
<*> pure (cleanupOption v)
<*> pure (keyOptions v)
<*> pure (resolveMergeOverride v)
import qualified Git.Command as Git
import qualified Git.Branch
import qualified Command.Sync
+import qualified Utility.RawFilePath as R
cmd :: Command
cmd = notBareRepo $
-- and then any adds. This order is necessary to handle eg, removing
-- a directory and replacing it with a file.
let (removals, adds) = partition (\di -> dstsha di `elem` nullShas) diff'
- let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $
+ let mkrel di = liftIO $ relPathCwdToFile $
fromTopFilePath (file di) g
forM_ removals $ \di -> do
f <- mkrel di
- liftIO $ removeWhenExistsWith removeLink f
+ liftIO $ removeWhenExistsWith R.removeLink f
forM_ adds $ \di -> do
- f <- mkrel di
+ f <- fromRawFilePath <$> mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f]
next $ liftIO cleanup
import qualified Git.Config
import qualified Git.CurrentRepo
import qualified Annex
-import Config.Files
+import Config.Files.AutoStart
import Upgrade
import Annex.Version
import Utility.Android
listenAddress' <- if isJust (listenAddress o)
then pure (listenAddress o)
else annexListen <$> Annex.getGitConfig
- ifM (checkpid <&&> checkshim f)
+ ifM (checkpid <&&> checkshim (fromRawFilePath f))
( if isJust (listenAddress o)
then giveup "The assistant is already running, so --listen cannot be used."
else do
- url <- liftIO . readFile
+ url <- liftIO . readFile . fromRawFilePath
=<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress'
then putStrLn url
- else liftIO $ openBrowser browser f url Nothing Nothing
+ else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
, do
startDaemon True True Nothing cannotrun listenAddress' $ Just $
\origout origerr url htmlshim ->
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
- liftIO $ isJust <$> checkDaemon pidfile
+ liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
checkshim f = liftIO $ doesFileExist f
notinitialized = do
g <- Annex.gitRepo
notHome :: Annex Bool
notHome = do
g <- Annex.gitRepo
- d <- liftIO $ absPath (Git.repoLocation g)
- h <- liftIO $ absPath =<< myHomeDir
+ d <- liftIO $ absPath (Git.repoPath g)
+ h <- liftIO $ absPath . toRawFilePath =<< myHomeDir
return (d /= h)
{- When run without a repo, start the first available listed repository in
openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do
- htmlshim' <- absPath htmlshim
+ htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim)
openBrowser' mcmd htmlshim' realurl outh errh
openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
-repoAbsPath :: FilePath -> IO FilePath
+repoAbsPath :: RawFilePath -> IO RawFilePath
repoAbsPath d = do
- d' <- expandTilde d
+ d' <- expandTilde (fromRawFilePath d)
h <- myHomeDir
- return $ h </> d'
+ return $ toRawFilePath $ h </> d'
expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS
import CmdLine.GitAnnex.Options
import qualified Utility.SafeCommand
+import qualified Utility.RawFilePath as R
import qualified Annex
import qualified Git.Filename
import qualified Git.Types
exitWith exitcode
runsubprocesstests (Just _) = isolateGitConfig $ do
ensuretmpdir
- crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' tmpdir
+ crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir)
adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of
Nothing -> error "No tests found!?"
Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
Database.Keys.removeInodeCaches k
Database.Keys.closeDb
- liftIO . removeWhenExistsWith removeLink
+ liftIO . removeWhenExistsWith R.removeLink
=<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache
writecontent annexedfile "test_lock_force content"
git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail"
where
checkunused expectedkeys desc = do
git_annex "unused" [] @? "unused failed"
- unusedmap <- annexeval $ Logs.Unused.readUnusedMap ""
+ unusedmap <- annexeval $ Logs.Unused.readUnusedMap mempty
let unusedkeys = M.elems unusedmap
assertEqual ("unused keys differ " ++ desc)
(sort expectedkeys) (sort unusedkeys)
withtmpclonerepo $ \r2 -> do
indir r1 $ do
disconnectOrigin
- createDirectoryIfMissing True (parentDir remoteconflictor)
+ createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor)))
writecontent remoteconflictor annexedcontent
add_annex conflictor @? "add remoteconflicter failed"
git_annex "sync" [] @? "sync failed in r1"
test_bup_remote :: Assertion
test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do
- dir <- absPath "dir" -- bup special remote needs an absolute path
+ -- bup special remote needs an absolute path
+ dir <- fromRawFilePath <$> absPath (toRawFilePath "dir")
createDirectory dir
git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed"
git_annex "get" [annexedfile] @? "get of file failed"
where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing
testscheme scheme = do
- abstmp <- absPath tmpdir
+ abstmp <- fromRawFilePath <$> absPath (toRawFilePath tmpdir)
testscheme' scheme abstmp
testscheme' scheme abstmp = intmpclonerepo $ do
- gpgtmp <- (</> "gpgtmp") <$> relPathCwdToFile abstmp
+ gpgtmp <- (</> "gpgtmp") . fromRawFilePath
+ <$> relPathCwdToFile (toRawFilePath abstmp)
createDirectoryIfMissing False gpgtmp
Utility.Gpg.testTestHarness gpgtmp gpgcmd
@? "test harness self-test failed"
test_addurl = intmpclonerepo $ do
-- file:// only; this test suite should not hit the network
let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps)
- f <- absPath "myurl"
+ f <- fromRawFilePath <$> absPath (toRawFilePath "myurl")
let url = replace "\\" "/" ("file:///" ++ dropDrive f)
writecontent f "foo"
git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url"
import Utility.Monad
import Utility.SystemDirectory
+import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
(drive, path) = splitDrive dir
dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
-prop_upFrom_basics :: RawFilePath -> Bool
+prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir
- | B.null dir = True
+ | null dir = True
| dir == "/" = p == Nothing
| otherwise = p /= Just dir
where
- p = upFrom dir
+ p = fromRawFilePath <$> upFrom (toRawFilePath dir)
{- Checks if the first RawFilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive
#endif
-prop_relPathDirToFileAbs_basics :: RawFilePath -> RawFilePath -> Bool
+prop_relPathDirToFileAbs_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFileAbs_basics from to
- | B.null from || B.null to = True
- | from == to = B.null r
- | otherwise = not (B.null r)
+ | null from || null to = True
+ | from == to = null r
+ | otherwise = not (null r)
where
- r = relPathDirToFileAbs from to
+ r = fromRawFilePath $ relPathDirToFileAbs
+ (toRawFilePath from)
+ (toRawFilePath to)
prop_relPathDirToFileAbs_regressionTest :: Bool
prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
projects / git-annex.git / commitdiff