finished this stage of the RawFilePath conversion
Finally compiles again, and test suite passes. This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess
parent
4bcb4030a5
commit
5a1e73617d
36 changed files with 188 additions and 147 deletions
|
|
@ -393,7 +393,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
|
||||
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.
|
||||
|
|
@ -457,7 +457,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
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
|
||||
|
|
@ -475,7 +475,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
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
|
||||
|
|
@ -498,7 +498,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
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
|
||||
|
|
@ -530,12 +530,12 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
|
|||
nohardlink = withTSDelta $ liftIO . nohardlink'
|
||||
|
||||
nohardlink' delta = do
|
||||
cache <- genInodeCache (toRawFilePath file) delta
|
||||
cache <- genInodeCache file' delta
|
||||
return $ LockedDown cfg $ KeySource
|
||||
{ keyFilename = file'
|
||||
, contentLocation = file'
|
||||
|
|
|
|||
|
|
@ -288,9 +288,9 @@ gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $
|
|||
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
|
||||
|
|
@ -511,8 +511,8 @@ gitAnnexDaemonStatusFile r = fromRawFilePath $
|
|||
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
|
||||
|
|
@ -520,12 +520,12 @@ gitAnnexFuzzTestLogFile r = fromRawFilePath $
|
|||
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
|
||||
|
|
|
|||
13
Assistant.hs
13
Assistant.hs
|
|
@ -62,7 +62,8 @@ import System.Log.Logger
|
|||
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.
|
||||
|
|
@ -75,24 +76,24 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
|
|||
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.
|
||||
|
|
@ -128,7 +129,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
|
|||
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
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
|
|||
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"
|
||||
|
||||
|
|
|
|||
|
|
@ -91,10 +91,10 @@ runRepair u mrmt destructiverepair = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ import Utility.ThreadScheduler
|
|||
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
|
||||
|
|
@ -39,8 +40,8 @@ import Network.URI
|
|||
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.
|
||||
|
|
@ -75,8 +76,8 @@ newAssistantUrl repo = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -57,10 +57,11 @@ commitThread = namedThread "Committer" $ do
|
|||
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
|
||||
|
|
@ -261,7 +262,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ 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
|
||||
|
|
@ -304,7 +305,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
|
|||
delta <- liftAnnex getTSDelta
|
||||
let cfg = LockDownConfig
|
||||
{ lockingFile = False
|
||||
, hardlinkFileTmpDir = Just lockdowndir
|
||||
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
|
||||
}
|
||||
if M.null m
|
||||
then forM toadd (add cfg)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.Threads.Merger where
|
||||
|
||||
import Assistant.Common
|
||||
|
|
@ -13,6 +15,7 @@ import Assistant.BranchChange
|
|||
import Assistant.Sync
|
||||
import Utility.DirWatcher
|
||||
import Utility.DirWatcher.Types
|
||||
import Utility.Directory.Create
|
||||
import Annex.CurrentBranch
|
||||
import qualified Annex
|
||||
import qualified Annex.Branch
|
||||
|
|
@ -21,13 +24,15 @@ import qualified Git.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
|
||||
|
|
@ -37,8 +42,8 @@ mergeThread = namedThread "Merger" $ do
|
|||
, 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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ handleMount urlrenderer dir = do
|
|||
-}
|
||||
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
|
||||
|
|
@ -169,7 +169,7 @@ remotesUnder dir = do
|
|||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -221,7 +221,7 @@ hourlyCheck = do
|
|||
-}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ transferPollerThread = namedThread "TransferPoller" $ 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. -}
|
||||
|
|
@ -47,7 +47,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
|
|||
| 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
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ transferWatcherThread = namedThread "TransferWatcher" $ do
|
|||
, 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 ()
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
|
|||
, 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)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Assistant.Alert
|
|||
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
|
||||
|
|
@ -169,7 +170,7 @@ ignored = ig . takeFileName
|
|||
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
|
||||
)
|
||||
|
|
@ -194,7 +195,7 @@ runHandler handler file filestatus = void $ do
|
|||
|
||||
{- 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"
|
||||
|
|
@ -280,7 +281,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
|
|||
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
|
||||
|
|
@ -288,15 +289,17 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
|
|||
-}
|
||||
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
|
||||
|
|
@ -326,17 +329,17 @@ onAddSymlink' linktarget mk file filestatus = go mk
|
|||
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
|
||||
|
|
|
|||
|
|
@ -91,7 +91,9 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
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
|
||||
|
|
@ -100,8 +102,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
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
|
||||
|
|
|
|||
|
|
@ -188,7 +188,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
|
|||
- 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
|
||||
|
|
@ -219,7 +219,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
|
|||
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
|
||||
|
||||
|
|
@ -228,7 +228,7 @@ oldVersionLocation :: IO FilePath
|
|||
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. -}
|
||||
|
|
@ -257,7 +257,7 @@ newVersionLocation d olddir =
|
|||
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))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Assistant.ScanRemotes
|
|||
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
|
||||
|
|
@ -90,7 +90,8 @@ deleteCurrentRepository = dangerPage $ do
|
|||
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")
|
||||
|
|
|
|||
|
|
@ -247,7 +247,7 @@ checkAssociatedDirectory cfg (Just r) = do
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ import qualified Annex
|
|||
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
|
||||
|
|
@ -78,8 +78,8 @@ checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
|
|||
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.")
|
||||
|
|
@ -354,7 +354,9 @@ combineRepos :: FilePath -> String -> Handler Remote
|
|||
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
|
||||
|
||||
|
|
@ -415,7 +417,9 @@ startFullAssistant path repogroup setup = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Assistant.WebApp.Common
|
|||
import qualified Annex
|
||||
import qualified Git
|
||||
import Config
|
||||
import Config.Files
|
||||
import Config.Files.AutoStart
|
||||
import Annex.NumCopies
|
||||
import Utility.DataUnits
|
||||
import Git.Config
|
||||
|
|
@ -24,6 +24,7 @@ import Types.Distribution
|
|||
import qualified BuildInfo
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
data PrefsForm = PrefsForm
|
||||
{ diskReserve :: Text
|
||||
|
|
@ -119,5 +120,5 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do
|
|||
inAutoStartFile :: Annex Bool
|
||||
inAutoStartFile = do
|
||||
here <- liftIO . absPath =<< fromRepo Git.repoPath
|
||||
any (`equalFilePath` here) . toRawFilePath
|
||||
any (`P.equalFilePath` here) . map toRawFilePath
|
||||
<$> liftIO readAutoStartFile
|
||||
|
|
|
|||
|
|
@ -73,6 +73,6 @@ getRestartThreadR name = do
|
|||
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")
|
||||
|
|
|
|||
|
|
@ -118,8 +118,8 @@ getFileBrowserR = whenM openFileBrowser redirectBack
|
|||
- 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]
|
||||
|
|
|
|||
|
|
@ -12,9 +12,10 @@ module Assistant.WebApp.OtherRepos where
|
|||
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
|
||||
|
|
@ -24,9 +25,9 @@ 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
|
||||
|
|
|
|||
|
|
@ -124,7 +124,8 @@ builtin cmd dir params = do
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ checkDirectory mdir = do
|
|||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -49,6 +49,7 @@ import Utility.Tuple
|
|||
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
|
||||
|
|
@ -92,7 +93,7 @@ withFilesNotInGit (CheckGitIgnore ci) ww a l = do
|
|||
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
|
||||
|
|
@ -102,13 +103,18 @@ withPathContents a params = 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
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ import qualified Command.Watch
|
|||
import Annex.Init
|
||||
import Annex.Path
|
||||
import Config.Files
|
||||
import Config.Files.AutoStart
|
||||
import qualified BuildInfo
|
||||
import Utility.HumanTime
|
||||
import Assistant.Install
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ import Git.FilePath
|
|||
import Git.Types
|
||||
import Types.Import
|
||||
import Utility.Metered
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
|
|
@ -118,10 +119,11 @@ duplicateModeParser =
|
|||
|
||||
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))
|
||||
|
|
@ -136,23 +138,21 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
|
|||
(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."
|
||||
|
|
@ -165,35 +165,35 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
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
|
||||
|
|
@ -201,13 +201,17 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
-- 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
|
||||
|
|
@ -218,8 +222,8 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
-- is what will be ingested.
|
||||
let ld' = ld
|
||||
{ keySource = KeySource
|
||||
{ keyFilename = destfile'
|
||||
, contentLocation = destfile'
|
||||
{ keyFilename = destfile
|
||||
, contentLocation = destfile
|
||||
, inodeCache = newcache
|
||||
}
|
||||
}
|
||||
|
|
@ -228,15 +232,15 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
>>= 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
|
||||
|
|
@ -245,7 +249,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
{ lockingFile = lockingfile
|
||||
, hardlinkFileTmpDir = Nothing
|
||||
}
|
||||
v <- lockDown cfg srcfile
|
||||
v <- lockDown cfg (fromRawFilePath srcfile)
|
||||
case v of
|
||||
Just ld -> do
|
||||
backend <- chooseBackend destfile
|
||||
|
|
@ -270,7 +274,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, 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.
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ import Data.Time.LocalTime
|
|||
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
|
||||
|
|
@ -188,13 +189,14 @@ performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownloa
|
|||
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
|
||||
}
|
||||
|
|
@ -218,7 +220,8 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
|
|||
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 []
|
||||
|
|
@ -257,7 +260,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
|
|||
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
|
||||
|
|
@ -307,7 +310,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
|
|||
| 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
|
||||
|
|
@ -315,7 +318,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
|
|||
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
|
||||
|
|
@ -457,7 +460,7 @@ checkFeedBroken url = checkFeedBroken' url =<< feedState url
|
|||
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
|
||||
|
|
|
|||
|
|
@ -191,7 +191,7 @@ instance DeferredParseClass SyncOptions where
|
|||
<*> 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)
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ import qualified Git.LsFiles as LsFiles
|
|||
import qualified Git.Command as Git
|
||||
import qualified Git.Branch
|
||||
import qualified Command.Sync
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
cmd :: Command
|
||||
cmd = notBareRepo $
|
||||
|
|
@ -62,15 +63,15 @@ perform p = do
|
|||
-- 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
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ import Git.Types (fromConfigValue)
|
|||
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
|
||||
|
|
@ -75,15 +75,15 @@ start' allowauto o = do
|
|||
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 ->
|
||||
|
|
@ -93,7 +93,7 @@ start' allowauto o = do
|
|||
)
|
||||
checkpid = do
|
||||
pidfile <- fromRepo gitAnnexPidFile
|
||||
liftIO $ isJust <$> checkDaemon pidfile
|
||||
liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
|
||||
checkshim f = liftIO $ doesFileExist f
|
||||
notinitialized = do
|
||||
g <- Annex.gitRepo
|
||||
|
|
@ -105,8 +105,8 @@ start' allowauto o = do
|
|||
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
|
||||
|
|
@ -191,7 +191,7 @@ firstRun o = do
|
|||
|
||||
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 ()
|
||||
|
|
|
|||
|
|
@ -168,11 +168,11 @@ fromRemotePath dir repo = do
|
|||
- 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
|
||||
|
|
|
|||
19
Test.hs
19
Test.hs
|
|
@ -31,6 +31,7 @@ import Common
|
|||
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
|
||||
|
|
@ -141,7 +142,7 @@ runner opts
|
|||
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!?"
|
||||
|
|
@ -759,7 +760,7 @@ test_lock_force = intmpclonerepo $ do
|
|||
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"
|
||||
|
|
@ -1022,7 +1023,7 @@ test_unused = intmpclonerepo $ do
|
|||
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)
|
||||
|
|
@ -1433,7 +1434,7 @@ test_uncommitted_conflict_resolution = do
|
|||
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"
|
||||
|
|
@ -1681,7 +1682,8 @@ test_rsync_remote = intmpclonerepo $ do
|
|||
|
||||
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"
|
||||
|
|
@ -1705,10 +1707,11 @@ test_crypto = do
|
|||
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"
|
||||
|
|
@ -1805,7 +1808,7 @@ test_addurl :: Assertion
|
|||
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"
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ import Prelude
|
|||
|
||||
import Utility.Monad
|
||||
import Utility.SystemDirectory
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
{- Simplifies a path, removing any "." component, collapsing "dir/..",
|
||||
- and removing the trailing path separator.
|
||||
|
|
@ -84,13 +85,13 @@ upFrom dir
|
|||
(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
|
||||
|
|
@ -222,13 +223,15 @@ relPathDirToFileAbs from to
|
|||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue