mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

finished this stage of the RawFilePath conversion

Browse source 
Finally compiles again, and test suite passes.

This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess 2020-11-04 14:20:37 -04:00
parent 4bcb4030a5
commit 5a1e73617d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
36 changed files with 188 additions and 147 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
Annex/Import.hs
View file

@ -393,7 +393,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
importordownload cidmap db (loc, (cid, sz)) largematcher= do importordownload cidmap db (loc, (cid, sz)) largematcher= do
f <- locworktreefile loc f <- locworktreefile loc
matcher <- largematcher (fromRawFilePath f) matcher <- largematcher f
-- When importing a key is supported, always use it rather -- When importing a key is supported, always use it rather
-- than downloading and retrieving a key, to avoid -- than downloading and retrieving a key, to avoid
-- generating trees with different keys for the same content. -- 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 af = AssociatedFile (Just f)
let downloader p' tmpfile = do let downloader p' tmpfile = do
k' <- Remote.retrieveExportWithContentIdentifier k' <- Remote.retrieveExportWithContentIdentifier
ia loc cid tmpfile ia loc cid (fromRawFilePath tmpfile)
(pure k) (pure k)
(combineMeterUpdate p' p) (combineMeterUpdate p' p)
ok <- moveAnnex k' tmpfile ok <- moveAnnex k' tmpfile
@ -475,7 +475,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
doimportsmall cidmap db loc cid sz p = do doimportsmall cidmap db loc cid sz p = do
let downloader tmpfile = do let downloader tmpfile = do
k <- Remote.retrieveExportWithContentIdentifier k <- Remote.retrieveExportWithContentIdentifier
ia loc cid tmpfile ia loc cid (fromRawFilePath tmpfile)
(mkkey tmpfile) (mkkey tmpfile)
p p
case keyGitSha k of case keyGitSha k of
@ -498,7 +498,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do
let af = AssociatedFile (Just f) let af = AssociatedFile (Just f)
let downloader tmpfile p = do let downloader tmpfile p = do
k <- Remote.retrieveExportWithContentIdentifier k <- Remote.retrieveExportWithContentIdentifier
ia loc cid tmpfile ia loc cid (fromRawFilePath tmpfile)
(mkkey tmpfile) (mkkey tmpfile)
p p
case keyGitSha k of case keyGitSha k of
@ -530,12 +530,12 @@ importKeys remote importtreeconfig importcontent importablecontents = do
mkkey tmpfile = do mkkey tmpfile = do
let mi = MatchingFile FileInfo let mi = MatchingFile FileInfo
{ matchFile = f { matchFile = f
, contentFile = Just (toRawFilePath tmpfile) , contentFile = Just tmpfile
} }
islargefile <- checkMatcher' matcher mi mempty islargefile <- checkMatcher' matcher mi mempty
if islargefile if islargefile
then do then do
backend <- chooseBackend (fromRawFilePath f) backend <- chooseBackend f
let ks = KeySource let ks = KeySource
{ keyFilename = f { keyFilename = f
, contentLocation = tmpfile , contentLocation = tmpfile

2
Annex/Ingest.hs
View file

@ -98,7 +98,7 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
nohardlink = withTSDelta $ liftIO . nohardlink' nohardlink = withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do nohardlink' delta = do
cache <- genInodeCache (toRawFilePath file) delta cache <- genInodeCache file' delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file' { keyFilename = file'
, contentLocation = file' , contentLocation = file'

18
Annex/Locations.hs
View file

@ -288,9 +288,9 @@ gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $
gitAnnexDir r P.</> "misctmp" gitAnnexDir r P.</> "misctmp"
{- .git/annex/watchtmp/ is used by the watcher and assistant -} {- .git/annex/watchtmp/ is used by the watcher and assistant -}
gitAnnexTmpWatcherDir :: Git.Repo -> FilePath gitAnnexTmpWatcherDir :: Git.Repo -> RawFilePath
gitAnnexTmpWatcherDir r = fromRawFilePath $ gitAnnexTmpWatcherDir r = P.addTrailingPathSeparator $
P.addTrailingPathSeparator $ gitAnnexDir r P.</> "watchtmp" gitAnnexDir r P.</> "watchtmp"
{- The temp file to use for a given key's content. -} {- The temp file to use for a given key's content. -}
gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath
@ -511,8 +511,8 @@ gitAnnexDaemonStatusFile r = fromRawFilePath $
gitAnnexDir r P.</> "daemon.status" gitAnnexDir r P.</> "daemon.status"
{- Log file for daemon mode. -} {- Log file for daemon mode. -}
gitAnnexDaemonLogFile :: Git.Repo -> FilePath gitAnnexDaemonLogFile :: Git.Repo -> RawFilePath
gitAnnexDaemonLogFile r = fromRawFilePath $ gitAnnexDir r P.</> "daemon.log" gitAnnexDaemonLogFile r = gitAnnexDir r P.</> "daemon.log"
{- Log file for fuzz test. -} {- Log file for fuzz test. -}
gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath
@ -520,12 +520,12 @@ gitAnnexFuzzTestLogFile r = fromRawFilePath $
gitAnnexDir r P.</> "fuzztest.log" gitAnnexDir r P.</> "fuzztest.log"
{- Html shim file used to launch the webapp. -} {- Html shim file used to launch the webapp. -}
gitAnnexHtmlShim :: Git.Repo -> FilePath gitAnnexHtmlShim :: Git.Repo -> RawFilePath
gitAnnexHtmlShim r = fromRawFilePath $ gitAnnexDir r P.</> "webapp.html" gitAnnexHtmlShim r = gitAnnexDir r P.</> "webapp.html"
{- File containing the url to the webapp. -} {- File containing the url to the webapp. -}
gitAnnexUrlFile :: Git.Repo -> FilePath gitAnnexUrlFile :: Git.Repo -> RawFilePath
gitAnnexUrlFile r = fromRawFilePath $ gitAnnexDir r P.</> "url" gitAnnexUrlFile r = gitAnnexDir r P.</> "url"
{- Temporary file used to edit configuriation from the git-annex branch. -} {- Temporary file used to edit configuriation from the git-annex branch. -}
gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath

13
Assistant.hs
View file

@ -62,7 +62,8 @@ import System.Log.Logger
import Network.Socket (HostName) import Network.Socket (HostName)
stopDaemon :: Annex () 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 {- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser. - running, can start the browser.
@ -75,24 +76,24 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
enableInteractiveBranchAccess enableInteractiveBranchAccess
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexDaemonLogFile logfile <- fromRepo gitAnnexDaemonLogFile
liftIO $ debugM desc $ "logging to " ++ logfile liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile
createAnnexDirectory (parentDir pidfile) createAnnexDirectory (parentDir pidfile)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile) createAnnexDirectory (parentDir logfile)
logfd <- liftIO $ handleToFd =<< openLog logfile logfd <- liftIO $ handleToFd =<< openLog (fromRawFilePath logfile)
if foreground if foreground
then do then do
origout <- liftIO $ catchMaybeIO $ origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $ origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError fdToHandle =<< dup stdError
let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile))
start undaemonize $ start undaemonize $
case startbrowser of case startbrowser of
Nothing -> Nothing Nothing -> Nothing
Just a -> Just $ a origout origerr Just a -> Just $ a origout origerr
else else
start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing start (Utility.Daemon.daemonize logfd (Just (fromRawFilePath pidfile)) False) Nothing
#else #else
-- Windows doesn't daemonize, but does redirect output to the -- Windows doesn't daemonize, but does redirect output to the
-- log file. The only way to do so is to restart the program. -- 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 checkCanWatch
dstatus <- startDaemonStatus dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexDaemonLogFile logfile <- fromRepo gitAnnexDaemonLogFile
liftIO $ debugM desc $ "logging to " ++ logfile liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile
liftIO $ daemonize $ liftIO $ daemonize $
flip runAssistant (go webappwaiter) flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus =<< newAssistantData st dstatus

2
Assistant/Pairing/MakeRemote.hs
View file

@ -26,7 +26,7 @@ setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> error err Left err -> error err
Right pubkey -> do Right pubkey -> do
absdir <- absPath repodir absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $ unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
error "failed setting up ssh authorized keys" error "failed setting up ssh authorized keys"

4
Assistant/Repair.hs
View file

@ -91,10 +91,10 @@ runRepair u mrmt destructiverepair = do
remoterepair fsckresults = case Remote.repairRepo =<< mrmt of remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
Nothing -> return False Nothing -> return False
Just mkrepair -> do Just mkrepair -> do
thisrepopath <- liftIO . absPath . fromRawFilePath thisrepopath <- liftIO . absPath
=<< liftAnnex (fromRepo Git.repoPath) =<< liftAnnex (fromRepo Git.repoPath)
a <- liftAnnex $ mkrepair $ a <- liftAnnex $ mkrepair $
repair fsckresults (Just thisrepopath) repair fsckresults (Just (fromRawFilePath thisrepopath))
liftIO $ catchBoolIO a liftIO $ catchBoolIO a
repair fsckresults referencerepo = do repair fsckresults referencerepo = do

9
Assistant/Restart.hs
View file

@ -17,6 +17,7 @@ import Utility.ThreadScheduler
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Url import Utility.Url
import Utility.PID import Utility.PID
import qualified Utility.RawFilePath as R
import qualified Git.Construct import qualified Git.Construct
import qualified Git.Config import qualified Git.Config
import qualified Annex import qualified Annex
@ -39,8 +40,8 @@ import Network.URI
prepRestart :: Assistant () prepRestart :: Assistant ()
prepRestart = do prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
liftIO . removeWhenExistsWith removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url {- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp. - to any web browsers that are displaying the webapp.
@ -75,8 +76,8 @@ newAssistantUrl repo = do
geturl geturl
where where
geturl = do geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath repo r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo)
waiturl $ gitAnnexUrlFile r waiturl $ fromRawFilePath $ gitAnnexUrlFile r
waiturl urlfile = do waiturl urlfile = do
v <- tryIO $ readFile urlfile v <- tryIO $ readFile urlfile
case v of case v of

9
Assistant/Threads/Committer.hs
View file

@ -57,10 +57,11 @@ commitThread = namedThread "Committer" $ do
liftAnnex $ do liftAnnex $ do
-- Clean up anything left behind by a previous process -- Clean up anything left behind by a previous process
-- on unclean shutdown. -- on unclean shutdown.
void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir void $ liftIO $ tryIO $ removeDirectoryRecursive
(fromRawFilePath lockdowndir)
void $ createAnnexDirectory lockdowndir void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds lockdowndir havelsof delayadd $ readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof delayadd $
simplifyChanges changes simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges if shouldCommit False time (length readychanges) readychanges
then do then do
@ -261,7 +262,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig let lockdownconfig = LockDownConfig
{ lockingFile = False { lockingFile = False
, hardlinkFileTmpDir = Just lockdowndir , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
} }
(postponed, toadd) <- partitionEithers (postponed, toadd) <- partitionEithers
<$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess <$> safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess
@ -304,7 +305,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
delta <- liftAnnex getTSDelta delta <- liftAnnex getTSDelta
let cfg = LockDownConfig let cfg = LockDownConfig
{ lockingFile = False { lockingFile = False
, hardlinkFileTmpDir = Just lockdowndir , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
} }
if M.null m if M.null m
then forM toadd (add cfg) then forM toadd (add cfg)

13
Assistant/Threads/Merger.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Threads.Merger where module Assistant.Threads.Merger where
import Assistant.Common import Assistant.Common
@ -13,6 +15,7 @@ import Assistant.BranchChange
import Assistant.Sync import Assistant.Sync
import Utility.DirWatcher import Utility.DirWatcher
import Utility.DirWatcher.Types import Utility.DirWatcher.Types
import Utility.Directory.Create
import Annex.CurrentBranch import Annex.CurrentBranch
import qualified Annex import qualified Annex
import qualified Annex.Branch import qualified Annex.Branch
@ -21,13 +24,15 @@ import qualified Git.Branch
import qualified Git.Ref import qualified Git.Ref
import qualified Command.Sync import qualified Command.Sync
import qualified System.FilePath.ByteString as P
{- This thread watches for changes to .git/refs/, and handles incoming {- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -} - pushes. -}
mergeThread :: NamedThread mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
let gitd = fromRawFilePath (Git.localGitDir g) let gitd = Git.localGitDir g
let dir = gitd </> "refs" let dir = gitd P.</> "refs"
liftIO $ createDirectoryUnder gitd dir liftIO $ createDirectoryUnder gitd dir
let hook a = Just <$> asIO2 (runHandler a) let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange changehook <- hook onChange
@ -37,8 +42,8 @@ mergeThread = namedThread "Merger" $ do
, modifyHook = changehook , modifyHook = changehook
, errHook = errhook , errHook = errhook
} }
void $ liftIO $ watchDir dir (const False) True hooks id void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
debug ["watching", dir] debug ["watching", fromRawFilePath dir]
type Handler = FilePath -> Assistant () type Handler = FilePath -> Assistant ()

4
Assistant/Threads/MountWatcher.hs
View file

@ -159,7 +159,7 @@ handleMount urlrenderer dir = do
-} -}
remotesUnder :: FilePath -> Assistant [Remote] remotesUnder :: FilePath -> Assistant [Remote]
remotesUnder dir = do remotesUnder dir = do
repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList rs <- liftAnnex remoteList
pairs <- liftAnnex $ mapM (checkremote repotop) rs pairs <- liftAnnex $ mapM (checkremote repotop) rs
let (waschanged, rs') = unzip pairs let (waschanged, rs') = unzip pairs
@ -169,7 +169,7 @@ remotesUnder dir = do
return $ mapMaybe snd $ filter fst pairs return $ mapMaybe snd $ filter fst pairs
where where
checkremote repotop r = case Remote.localpath r of 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 (,) <$> pure True <*> updateRemote r
_ -> return (False, Just r) _ -> return (False, Just r)

2
Assistant/Threads/SanityChecker.hs
View file

@ -221,7 +221,7 @@ hourlyCheck = do
-} -}
checkLogSize :: Int -> Assistant () checkLogSize :: Int -> Assistant ()
checkLogSize n = do checkLogSize n = do
f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs f logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM getFileSize logs totalsize <- liftIO $ sum <$> mapM getFileSize logs
when (totalsize > 2 * oneMegabyte) $ do when (totalsize > 2 * oneMegabyte) $ do

4
Assistant/Threads/TransferPoller.hs
View file

@ -37,7 +37,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
- temp file being used for the transfer. -} - temp file being used for the transfer. -}
| transferDirection t == Download = do | transferDirection t == Download = do
let f = gitAnnexTmpObjectLocation (transferKey t) g let f = gitAnnexTmpObjectLocation (transferKey t) g
sz <- liftIO $ catchMaybeIO $ getFileSize f sz <- liftIO $ catchMaybeIO $ getFileSize (fromRawFilePath f)
newsize t info sz newsize t info sz
{- Uploads don't need to be polled for when the TransferWatcher {- Uploads don't need to be polled for when the TransferWatcher
- thread can track file modifications. -} - thread can track file modifications. -}
@ -47,7 +47,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
| otherwise = do | otherwise = do
let f = transferFile t g let f = transferFile t g
mi <- liftIO $ catchDefaultIO Nothing $ mi <- liftIO $ catchDefaultIO Nothing $
readTransferInfoFile Nothing f readTransferInfoFile Nothing (fromRawFilePath f)
maybe noop (newsize t info . bytesComplete) mi maybe noop (newsize t info . bytesComplete) mi
newsize t info sz newsize t info sz

2
Assistant/Threads/TransferWatcher.hs
View file

@ -37,7 +37,7 @@ transferWatcherThread = namedThread "TransferWatcher" $ do
, modifyHook = modifyhook , modifyHook = modifyhook
, errHook = errhook , 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"] debug ["watching for transfers"]
type Handler = FilePath -> Assistant () type Handler = FilePath -> Assistant ()

2
Assistant/Threads/UpgradeWatcher.hs
View file

@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed , modifyHook = changed
, delDirHook = changed , delDirHook = changed
} }
let dir = parentDir flagfile let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
let depth = length (splitPath dir) + 1 let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)

23
Assistant/Threads/Watcher.hs
View file

@ -24,6 +24,7 @@ import Assistant.Alert
import Utility.DirWatcher import Utility.DirWatcher
import Utility.DirWatcher.Types import Utility.DirWatcher.Types
import Utility.InodeCache import Utility.InodeCache
import qualified Utility.RawFilePath as R
import qualified Annex import qualified Annex
import qualified Annex.Queue import qualified Annex.Queue
import qualified Git import qualified Git
@ -169,7 +170,7 @@ ignored = ig . takeFileName
ig _ = False ig _ = False
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) 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 ( noChange
, a , 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. -} {- Small files are added to git as-is, while large ones go into the annex. -}
add :: GetFileMatcher -> FilePath -> Assistant (Maybe Change) 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 ( pendingAddChange file
, do , do
liftAnnex $ Annex.Queue.addCommand "add" liftAnnex $ Annex.Queue.addCommand "add"
@ -280,7 +281,7 @@ onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkss
Nothing -> noop Nothing -> noop
Just key -> liftAnnex $ Just key -> liftAnnex $
addassociatedfile key file 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. {- 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 - 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 :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do onAddSymlink file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
kv <- liftAnnex (lookupKey (toRawFilePath file)) kv <- liftAnnex (lookupKey file')
onAddSymlink' linktarget kv file filestatus 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 onAddSymlink' linktarget mk file filestatus = go mk
where where
go (Just key) = do go (Just key) = do
link <- liftAnnex $ calcRepo $ gitAnnexLink file key link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
if linktarget == Just link if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus then ensurestaged (Just link) =<< getDaemonStatus
else do else do
@ -326,17 +329,17 @@ onAddSymlink' linktarget mk file filestatus = go mk
ensurestaged Nothing _ = noChange ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -} {- 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 addLink file link mk = do
debug ["add symlink", file] debug ["add symlink", file]
liftAnnex $ do liftAnnex $ do
v <- catObjectDetails $ Ref $ encodeBS' $ ':':file v <- catObjectDetails $ Ref $ encodeBS' $ ':':file
case v of case v of
Just (currlink, sha, _type) Just (currlink, sha, _type)
| s2w8 link == L.unpack currlink -> | L.fromStrict link == currlink ->
stageSymlink (toRawFilePath file) sha stageSymlink (toRawFilePath file) sha
_ -> stageSymlink (toRawFilePath file) _ -> stageSymlink (toRawFilePath file)
=<< hashSymlink (toRawFilePath link) =<< hashSymlink link
madeChange file $ LinkChange mk madeChange file $ LinkChange mk
onDel :: Handler onDel :: Handler

7
Assistant/Threads/WebApp.hs
View file

@ -91,7 +91,9 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
else do else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
go tlssettings addr webapp htmlshim (Just urlfile) go tlssettings addr webapp
(fromRawFilePath htmlshim)
(Just (fromRawFilePath urlfile))
where where
-- The webapp thread does not wait for the startupSanityCheckThread -- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while -- to finish, so that the user interface remains responsive while
@ -100,8 +102,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
getreldir getreldir
| noannex = return Nothing | noannex = return Nothing
| otherwise = Just <$> | otherwise = Just <$>
(relHome =<< absPath . fromRawFilePath (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
=<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile maybe noop (`writeFileProtected` url) urlfile

8
Assistant/Upgrade.hs
View file

@ -188,7 +188,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
- into place. -} - into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation olddir <- oldVersionLocation
withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do
let tarball = tmpdir </> "tar" let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also -- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent -- avoids problems if tar doesn't support transparent
@ -219,7 +219,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
unlessM (doesDirectoryExist dir) $ unlessM (doesDirectoryExist dir) $
error $ "did not find " ++ dir ++ " in " ++ distributionfile error $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do makeorigsymlink olddir = do
let origdir = parentDir olddir </> installBase let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
removeWhenExistsWith removeLink origdir removeWhenExistsWith removeLink origdir
createSymbolicLink newdir origdir createSymbolicLink newdir origdir
@ -228,7 +228,7 @@ oldVersionLocation :: IO FilePath
oldVersionLocation = readProgramFile >>= \case oldVersionLocation = readProgramFile >>= \case
Nothing -> error "Cannot find old distribution bundle; not upgrading." Nothing -> error "Cannot find old distribution bundle; not upgrading."
Just pf -> do Just pf -> do
let pdir = parentDir pf let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
let dirs = splitDirectories pdir let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -} {- It will probably be deep inside a git-annex.app directory. -}
@ -257,7 +257,7 @@ newVersionLocation d olddir =
return Nothing return Nothing
where where
s = installBase ++ "." ++ distributionVersion d s = installBase ++ "." ++ distributionVersion d
topdir = parentDir olddir topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir
newloc = topdir </> s newloc = topdir </> s
trymkdir dir fallback = trymkdir dir fallback =
(createDirectory dir >> return (Just dir)) (createDirectory dir >> return (Just dir))

5
Assistant/WebApp/Configurators/Delete.hs
View file

@ -16,7 +16,7 @@ import Assistant.ScanRemotes
import Assistant.Sync import Assistant.Sync
import qualified Remote import qualified Remote
import qualified Git import qualified Git
import Config.Files import Config.Files.AutoStart
import Logs.Trust import Logs.Trust
import Logs.Remote import Logs.Remote
import Logs.PreferredContent import Logs.PreferredContent
@ -90,7 +90,8 @@ deleteCurrentRepository = dangerPage $ do
mapM_ (\r -> changeSyncable (Just r) False) rs mapM_ (\r -> changeSyncable (Just r) False) rs
liftAnnex $ prepareRemoveAnnexDir dir liftAnnex $ prepareRemoveAnnexDir dir
liftIO $ removeDirectoryRecursive =<< absPath dir liftIO $ removeDirectoryRecursive . fromRawFilePath
=<< absPath (toRawFilePath dir)
redirect ShutdownConfirmedR redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository") _ -> $(widgetFile "configurators/delete/currentrepository")

2
Assistant/WebApp/Configurators/Edit.hs
View file

@ -247,7 +247,7 @@ checkAssociatedDirectory cfg (Just r) = do
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> do Just d -> do
top <- fromRawFilePath <$> fromRepo Git.repoPath top <- fromRawFilePath <$> fromRepo Git.repoPath
createWorkTreeDirectory (top </> d) createWorkTreeDirectory (toRawFilePath (top </> d))
Nothing -> noop Nothing -> noop
_ -> noop _ -> noop

14
Assistant/WebApp/Configurators/Local.hs
View file

@ -20,7 +20,7 @@ import qualified Annex
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
import qualified Git.Command import qualified Git.Command
import Config.Files import Config.Files.AutoStart
import Utility.FreeDesktop import Utility.FreeDesktop
import Utility.DiskFree import Utility.DiskFree
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -78,8 +78,8 @@ checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
checkRepositoryPath p = do checkRepositoryPath p = do
home <- myHomeDir home <- myHomeDir
let basepath = expandTilde home $ T.unpack p let basepath = expandTilde home $ T.unpack p
path <- absPath basepath path <- fromRawFilePath <$> absPath (toRawFilePath basepath)
let parent = parentDir path let parent = fromRawFilePath $ parentDir (toRawFilePath path)
problems <- catMaybes <$> mapM runcheck problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.") [ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.") , (return $ all isSpace basepath, "A blank path? Seems unlikely.")
@ -354,7 +354,9 @@ combineRepos :: FilePath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do combineRepos dir name = liftAnnex $ do
hostname <- fromMaybe "host" <$> liftIO getHostname hostname <- fromMaybe "host" <$> liftIO getHostname
mylocation <- fromRepo Git.repoLocation mylocation <- fromRepo Git.repoLocation
mypath <- liftIO $ relPathDirToFile dir mylocation mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile
(toRawFilePath dir)
(toRawFilePath mylocation)
liftIO $ inDir dir $ void $ makeGitRemote hostname mypath liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
addRemote $ makeGitRemote name dir addRemote $ makeGitRemote name dir
@ -415,7 +417,9 @@ startFullAssistant path repogroup setup = do
canWrite :: FilePath -> IO Bool canWrite :: FilePath -> IO Bool
canWrite dir = do canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir) tocheck <- ifM (doesDirectoryExist dir)
(return dir, return $ parentDir dir) ( return dir
, return $ fromRawFilePath $ parentDir $ toRawFilePath dir
)
catchBoolIO $ fileAccess tocheck False True False catchBoolIO $ fileAccess tocheck False True False
{- Gets the UUID of the git repo at a location, which may not exist, or {- Gets the UUID of the git repo at a location, which may not exist, or

5
Assistant/WebApp/Configurators/Preferences.hs
View file

@ -16,7 +16,7 @@ import Assistant.WebApp.Common
import qualified Annex import qualified Annex
import qualified Git import qualified Git
import Config import Config
import Config.Files import Config.Files.AutoStart
import Annex.NumCopies import Annex.NumCopies
import Utility.DataUnits import Utility.DataUnits
import Git.Config import Git.Config
@ -24,6 +24,7 @@ import Types.Distribution
import qualified BuildInfo import qualified BuildInfo
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm data PrefsForm = PrefsForm
{ diskReserve :: Text { diskReserve :: Text
@ -119,5 +120,5 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do
inAutoStartFile :: Annex Bool inAutoStartFile :: Annex Bool
inAutoStartFile = do inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath here <- liftIO . absPath =<< fromRepo Git.repoPath
any (`equalFilePath` here) . toRawFilePath any (`P.equalFilePath` here) . map toRawFilePath
<$> liftIO readAutoStartFile <$> liftIO readAutoStartFile

2
Assistant/WebApp/Control.hs
View file

@ -73,6 +73,6 @@ getRestartThreadR name = do
getLogR :: Handler Html getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs logfile logs <- liftIO $ listLogs (fromRawFilePath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log") $(widgetFile "control/log")

4
Assistant/WebApp/DashBoard.hs
View file

@ -118,8 +118,8 @@ getFileBrowserR = whenM openFileBrowser redirectBack
- blocking the response to the browser on it. -} - blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool openFileBrowser :: Handler Bool
openFileBrowser = do openFileBrowser = do
path <- liftIO . absPath . fromRawFilePath path <- fromRawFilePath
=<< liftAnnex (fromRepo Git.repoPath) <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath))
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
let cmd = "open" let cmd = "open"
let p = proc cmd [path] let p = proc cmd [path]

7
Assistant/WebApp/OtherRepos.hs
View file

@ -12,9 +12,10 @@ module Assistant.WebApp.OtherRepos where
import Assistant.Common import Assistant.Common
import Assistant.WebApp.Types import Assistant.WebApp.Types
import Assistant.WebApp.Page import Assistant.WebApp.Page
import Config.Files import Config.Files.AutoStart
import Utility.Yesod import Utility.Yesod
import Assistant.Restart import Assistant.Restart
import qualified Utility.RawFilePath as R
getRepositorySwitcherR :: Handler Html getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do getRepositorySwitcherR = page "Switch repository" Nothing $ do
@ -24,9 +25,9 @@ getRepositorySwitcherR = page "Switch repository" Nothing $ do
listOtherRepos :: IO [(String, String)] listOtherRepos :: IO [(String, String)]
listOtherRepos = do listOtherRepos = do
dirs <- readAutoStartFile dirs <- readAutoStartFile
pwd <- getCurrentDirectory pwd <- R.getCurrentDirectory
gooddirs <- filterM isrepo $ gooddirs <- filterM isrepo $
filter (\d -> not $ d `dirContains` pwd) dirs filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs
names <- mapM relHome gooddirs names <- mapM relHome gooddirs
return $ sort $ zip names gooddirs return $ sort $ zip names gooddirs
where where

3
CmdLine/GitAnnexShell.hs
View file

@ -124,7 +124,8 @@ builtin cmd dir params = do
"Restricted login shell for git-annex only SSH access" "Restricted login shell for git-annex only SSH access"
where where
mkrepo = do mkrepo = do
r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath r <- Git.Construct.repoAbsPath (toRawFilePath dir)
>>= Git.Construct.fromAbsPath
Git.Config.read r Git.Config.read r
`catchIO` \_ -> do `catchIO` \_ -> do
hn <- fromMaybe "unknown" <$> getHostname hn <- fromMaybe "unknown" <$> getHostname

2
CmdLine/GitAnnexShell/Checks.hs
View file

@ -71,7 +71,7 @@ checkDirectory mdir = do
canondir home d canondir home d
| "~/" `isPrefixOf` d = return d | "~/" `isPrefixOf` d = return d
| "/~/" `isPrefixOf` d = return $ drop 1 d | "/~/" `isPrefixOf` d = return $ drop 1 d
| otherwise = relHome $ fromRawFilePath <$> absPathFrom | otherwise = relHome $ fromRawFilePath $ absPathFrom
(toRawFilePath home) (toRawFilePath home)
(toRawFilePath d) (toRawFilePath d)

16
CmdLine/Seek.hs
View file

@ -49,6 +49,7 @@ import Utility.Tuple
import Control.Concurrent.Async import Control.Concurrent.Async
import System.Posix.Types import System.Posix.Types
import Data.IORef import Data.IORef
import qualified System.FilePath.ByteString as P
data AnnexedFileSeeker = AnnexedFileSeeker data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: SeekInput -> RawFilePath -> Key -> CommandStart { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart
@ -92,7 +93,7 @@ withFilesNotInGit (CheckGitIgnore ci) ww a l = do
seekFiltered (const (pure True)) a $ seekFiltered (const (pure True)) a $
seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l 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 withPathContents a params = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
forM_ params $ \p -> do forM_ params $ \p -> do
@ -102,13 +103,18 @@ withPathContents a params = do
a f a f
where where
get p = ifM (isDirectory <$> getFileStatus p) 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 <$> 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 checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ contentFile = Just (toRawFilePath f) { contentFile = Just f
, matchFile = toRawFilePath relf , matchFile = relf
} }
withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek

1
Command/Assistant.hs
View file

@ -12,6 +12,7 @@ import qualified Command.Watch
import Annex.Init import Annex.Init
import Annex.Path import Annex.Path
import Config.Files import Config.Files
import Config.Files.AutoStart
import qualified BuildInfo import qualified BuildInfo
import Utility.HumanTime import Utility.HumanTime
import Assistant.Install import Assistant.Install

56
Command/Import.hs
View file

@ -34,6 +34,7 @@ import Git.FilePath
import Git.Types import Git.Types
import Types.Import import Types.Import
import Utility.Metered import Utility.Metered
import qualified Utility.RawFilePath as R
import Control.Concurrent.STM import Control.Concurrent.STM
@ -118,10 +119,11 @@ duplicateModeParser =
seek :: ImportOptions -> CommandSeek seek :: ImportOptions -> CommandSeek
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) inrepops <- liftIO $ filter (dirContains repopath)
<$> mapM (absPath . toRawFilePath) (importFiles o)
unless (null inrepops) $ do 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 largematcher <- largeFilesMatcher
addunlockedmatcher <- addUnlockedMatcher addunlockedmatcher <- addUnlockedMatcher
(commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o)) (commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o))
@ -136,23 +138,21 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
(importToSubDir o) (importToSubDir o)
seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption 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) = startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile)
( starting "import" ai si pickaction ( starting "import" ai si pickaction
, stop , stop
) )
where where
ai = ActionItemWorkTreeFile destfile' ai = ActionItemWorkTreeFile destfile
si = SeekInput [] si = SeekInput []
destfile' = toRawFilePath destfile
deletedup k = do deletedup k = do
showNote $ "duplicate of " ++ serializeKey k showNote $ "duplicate of " ++ serializeKey k
verifyExisting k destfile verifyExisting k destfile
( do ( do
liftIO $ removeFile srcfile liftIO $ R.removeLink srcfile
next $ return True next $ return True
, do , do
warning "Could not verify that the content is still present in the annex; not removing from the import location." 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 ignored <- checkIgnored (checkGitIgnoreOption o) destfile
if ignored if ignored
then do 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 stop
else do else do
existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile) existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
case existing of case existing of
Nothing -> importfilechecked ld k Nothing -> importfilechecked ld k
Just s Just s
| isDirectory s -> notoverwriting "(is a directory)" | isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getState Annex.force) | isSymbolicLink s -> ifM (Annex.getState Annex.force)
( do ( do
liftIO $ removeWhenExistsWith removeLink destfile liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(is a symlink)" , notoverwriting "(is a symlink)"
) )
| otherwise -> ifM (Annex.getState Annex.force) | otherwise -> ifM (Annex.getState Annex.force)
( do ( do
liftIO $ removeWhenExistsWith removeLink destfile liftIO $ removeWhenExistsWith R.removeLink destfile
importfilechecked ld k importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)" , notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
) )
checkdestdir cont = do checkdestdir cont = do
let destdir = parentDir destfile let destdir = parentDir destfile
existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destdir) existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir)
case existing of case existing of
Nothing -> cont Nothing -> cont
Just s Just s
| isDirectory s -> cont | isDirectory s -> cont
| otherwise -> do | 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 stop
importfilechecked ld k = do importfilechecked ld k = do
@ -201,13 +201,17 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
-- The dest file is what will be ingested. -- The dest file is what will be ingested.
createWorkTreeDirectory (parentDir destfile) createWorkTreeDirectory (parentDir destfile)
liftIO $ if mode == Duplicate || mode == SkipDuplicates liftIO $ if mode == Duplicate || mode == SkipDuplicates
then void $ copyFileExternal CopyAllMetaData srcfile destfile then void $ copyFileExternal CopyAllMetaData
else moveFile srcfile destfile (fromRawFilePath srcfile)
(fromRawFilePath destfile)
else moveFile
(fromRawFilePath srcfile)
(fromRawFilePath destfile)
-- Get the inode cache of the dest file. It should be -- Get the inode cache of the dest file. It should be
-- weakly the same as the originally locked down file's -- weakly the same as the originally locked down file's
-- inode cache. (Since the file may have been copied, -- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.) -- 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 let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True (_, Nothing) -> True
(Just newc, Just c) | compareWeak c newc -> 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. -- is what will be ingested.
let ld' = ld let ld' = ld
{ keySource = KeySource { keySource = KeySource
{ keyFilename = destfile' { keyFilename = destfile
, contentLocation = destfile' , contentLocation = destfile
, inodeCache = newcache , inodeCache = newcache
} }
} }
@ -228,15 +232,15 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
>>= maybe >>= maybe
stop stop
(\addedk -> next $ Command.Add.cleanup addedk True) (\addedk -> next $ Command.Add.cleanup addedk True)
, next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile' , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile
) )
notoverwriting why = do notoverwriting why = do
warning $ "not overwriting existing " ++ destfile ++ " " ++ why warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why
stop stop
lockdown a = do lockdown a = do
let mi = MatchingFile $ FileInfo let mi = MatchingFile $ FileInfo
{ contentFile = Just (toRawFilePath srcfile) { contentFile = Just srcfile
, matchFile = toRawFilePath destfile , matchFile = destfile
} }
lockingfile <- not <$> addUnlocked addunlockedmatcher mi lockingfile <- not <$> addUnlocked addunlockedmatcher mi
-- Minimal lock down with no hard linking so nothing -- Minimal lock down with no hard linking so nothing
@ -245,7 +249,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
{ lockingFile = lockingfile { lockingFile = lockingfile
, hardlinkFileTmpDir = Nothing , hardlinkFileTmpDir = Nothing
} }
v <- lockDown cfg srcfile v <- lockDown cfg (fromRawFilePath srcfile)
case v of case v of
Just ld -> do Just ld -> do
backend <- chooseBackend destfile backend <- chooseBackend destfile
@ -270,7 +274,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
_ -> importfile ld k _ -> importfile ld k
skipbecause s = showNote (s ++ "; skipping") >> next (return True) 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 verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be -- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported. -- imported to, if it were imported.

15
Command/ImportFeed.hs
View file

@ -22,6 +22,7 @@ import Data.Time.LocalTime
import qualified Data.Text as T import qualified Data.Text as T
import System.Log.Logger import System.Log.Logger
import Control.Concurrent.Async import Control.Concurrent.Async
import qualified System.FilePath.ByteString as P
import Command import Command
import qualified Annex import qualified Annex
@ -188,13 +189,14 @@ performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownloa
performDownload addunlockedmatcher opts cache todownload = case location todownload of performDownload addunlockedmatcher opts cache todownload = case location todownload of
Enclosure url -> checkknown url $ Enclosure url -> checkknown url $
rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do
let f' = fromRawFilePath f
r <- Remote.claimingUrl url r <- Remote.claimingUrl url
if Remote.uuid r == webUUID || rawOption (downloadOptions opts) if Remote.uuid r == webUUID || rawOption (downloadOptions opts)
then do then do
let dlopts = (downloadOptions opts) let dlopts = (downloadOptions opts)
-- force using the filename -- force using the filename
-- chosen here -- chosen here
{ fileOption = Just f { fileOption = Just f'
-- don't use youtube-dl -- don't use youtube-dl
, rawOption = True , rawOption = True
} }
@ -218,7 +220,8 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz
Right (UrlMulti l) -> do Right (UrlMulti l) -> do
kl <- forM l $ \(url', sz, subf) -> 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 return $ Just $ if all isJust kl
then catMaybes kl then catMaybes kl
else [] else []
@ -257,7 +260,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
Nothing -> return True Nothing -> return True
Just f -> do Just f -> do
showStartOther "addurl" (Just url) (SeekInput []) showStartOther "addurl" (Just url) (SeekInput [])
getter f >>= \case getter (toRawFilePath f) >>= \case
Just ks Just ks
-- Download problem. -- Download problem.
| null ks -> do | null ks -> do
@ -307,7 +310,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
| rawOption (downloadOptions opts) = downloadlink | rawOption (downloadOptions opts) = downloadlink
| otherwise = do | otherwise = do
r <- withTmpWorkDir mediakey $ \workdir -> do r <- withTmpWorkDir mediakey $ \workdir -> do
dl <- youtubeDl linkurl workdir nullMeterUpdate dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate
case dl of case dl of
Right (Just mediafile) -> do Right (Just mediafile) -> do
let ext = case takeExtension mediafile of let ext = case takeExtension mediafile of
@ -315,7 +318,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
s -> s s -> s
ok <- rundownload linkurl ext $ \f -> ok <- rundownload linkurl ext $ \f ->
checkCanAdd (downloadOptions opts) f $ \canadd -> do 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 [mediakey])
return (Just ok) return (Just ok)
-- youtude-dl didn't support it, so -- youtude-dl didn't support it, so
@ -457,7 +460,7 @@ checkFeedBroken url = checkFeedBroken' url =<< feedState url
checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool
checkFeedBroken' url f = do checkFeedBroken' url f = do
prev <- maybe Nothing readish prev <- maybe Nothing readish
<$> liftIO (catchMaybeIO $ readFile (fromRawFlePath f)) <$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f))
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case prev of case prev of
Nothing -> do Nothing -> do

2
Command/Sync.hs
View file

@ -191,7 +191,7 @@ instance DeferredParseClass SyncOptions where
<*> pure (pushOption v) <*> pure (pushOption v)
<*> pure (contentOption v) <*> pure (contentOption v)
<*> pure (noContentOption v) <*> pure (noContentOption v)
<*> liftIO (mapM absPath (contentOfOption v)) <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v))
<*> pure (cleanupOption v) <*> pure (cleanupOption v)
<*> pure (keyOptions v) <*> pure (keyOptions v)
<*> pure (resolveMergeOverride v) <*> pure (resolveMergeOverride v)

7
Command/Undo.hs
View file

@ -16,6 +16,7 @@ import qualified Git.LsFiles as LsFiles
import qualified Git.Command as Git import qualified Git.Command as Git
import qualified Git.Branch import qualified Git.Branch
import qualified Command.Sync import qualified Command.Sync
import qualified Utility.RawFilePath as R
cmd :: Command cmd :: Command
cmd = notBareRepo $ cmd = notBareRepo $
@ -62,15 +63,15 @@ perform p = do
-- and then any adds. This order is necessary to handle eg, removing -- and then any adds. This order is necessary to handle eg, removing
-- a directory and replacing it with a file. -- a directory and replacing it with a file.
let (removals, adds) = partition (\di -> dstsha di `elem` nullShas) diff' 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 fromTopFilePath (file di) g
forM_ removals $ \di -> do forM_ removals $ \di -> do
f <- mkrel di f <- mkrel di
liftIO $ removeWhenExistsWith removeLink f liftIO $ removeWhenExistsWith R.removeLink f
forM_ adds $ \di -> do forM_ adds $ \di -> do
f <- mkrel di f <- fromRawFilePath <$> mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f] inRepo $ Git.run [Param "checkout", Param "--", File f]
next $ liftIO cleanup next $ liftIO cleanup

16
Command/WebApp.hs
View file

@ -27,7 +27,7 @@ import Git.Types (fromConfigValue)
import qualified Git.Config import qualified Git.Config
import qualified Git.CurrentRepo import qualified Git.CurrentRepo
import qualified Annex import qualified Annex
import Config.Files import Config.Files.AutoStart
import Upgrade import Upgrade
import Annex.Version import Annex.Version
import Utility.Android import Utility.Android
@ -75,15 +75,15 @@ start' allowauto o = do
listenAddress' <- if isJust (listenAddress o) listenAddress' <- if isJust (listenAddress o)
then pure (listenAddress o) then pure (listenAddress o)
else annexListen <$> Annex.getGitConfig else annexListen <$> Annex.getGitConfig
ifM (checkpid <&&> checkshim f) ifM (checkpid <&&> checkshim (fromRawFilePath f))
( if isJust (listenAddress o) ( if isJust (listenAddress o)
then giveup "The assistant is already running, so --listen cannot be used." then giveup "The assistant is already running, so --listen cannot be used."
else do else do
url <- liftIO . readFile url <- liftIO . readFile . fromRawFilePath
=<< fromRepo gitAnnexUrlFile =<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress' liftIO $ if isJust listenAddress'
then putStrLn url then putStrLn url
else liftIO $ openBrowser browser f url Nothing Nothing else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
, do , do
startDaemon True True Nothing cannotrun listenAddress' $ Just $ startDaemon True True Nothing cannotrun listenAddress' $ Just $
\origout origerr url htmlshim -> \origout origerr url htmlshim ->
@ -93,7 +93,7 @@ start' allowauto o = do
) )
checkpid = do checkpid = do
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
checkshim f = liftIO $ doesFileExist f checkshim f = liftIO $ doesFileExist f
notinitialized = do notinitialized = do
g <- Annex.gitRepo g <- Annex.gitRepo
@ -105,8 +105,8 @@ start' allowauto o = do
notHome :: Annex Bool notHome :: Annex Bool
notHome = do notHome = do
g <- Annex.gitRepo g <- Annex.gitRepo
d <- liftIO $ absPath (Git.repoLocation g) d <- liftIO $ absPath (Git.repoPath g)
h <- liftIO $ absPath =<< myHomeDir h <- liftIO $ absPath . toRawFilePath =<< myHomeDir
return (d /= h) return (d /= h)
{- When run without a repo, start the first available listed repository in {- 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 :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do openBrowser mcmd htmlshim realurl outh errh = do
htmlshim' <- absPath htmlshim htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim)
openBrowser' mcmd htmlshim' realurl outh errh openBrowser' mcmd htmlshim' realurl outh errh
openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()

6
Git/Construct.hs
View file

@ -168,11 +168,11 @@ fromRemotePath dir repo = do
- This converts such a directory to an absolute path. - This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is. - Note that it has to run on the system where the remote is.
-} -}
repoAbsPath :: FilePath -> IO FilePath repoAbsPath :: RawFilePath -> IO RawFilePath
repoAbsPath d = do repoAbsPath d = do
d' <- expandTilde d d' <- expandTilde (fromRawFilePath d)
h <- myHomeDir h <- myHomeDir
return $ h </> d' return $ toRawFilePath $ h </> d'
expandTilde :: FilePath -> IO FilePath expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS

19
Test.hs
View file

@ -31,6 +31,7 @@ import Common
import CmdLine.GitAnnex.Options import CmdLine.GitAnnex.Options
import qualified Utility.SafeCommand import qualified Utility.SafeCommand
import qualified Utility.RawFilePath as R
import qualified Annex import qualified Annex
import qualified Git.Filename import qualified Git.Filename
import qualified Git.Types import qualified Git.Types
@ -141,7 +142,7 @@ runner opts
exitWith exitcode exitWith exitcode
runsubprocesstests (Just _) = isolateGitConfig $ do runsubprocesstests (Just _) = isolateGitConfig $ do
ensuretmpdir ensuretmpdir
crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' tmpdir crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir)
adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of
Nothing -> error "No tests found!?" Nothing -> error "No tests found!?"
@ -759,7 +760,7 @@ test_lock_force = intmpclonerepo $ do
Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
Database.Keys.removeInodeCaches k Database.Keys.removeInodeCaches k
Database.Keys.closeDb Database.Keys.closeDb
liftIO . removeWhenExistsWith removeLink liftIO . removeWhenExistsWith R.removeLink
=<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache
writecontent annexedfile "test_lock_force content" writecontent annexedfile "test_lock_force content"
git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail" git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail"
@ -1022,7 +1023,7 @@ test_unused = intmpclonerepo $ do
where where
checkunused expectedkeys desc = do checkunused expectedkeys desc = do
git_annex "unused" [] @? "unused failed" git_annex "unused" [] @? "unused failed"
unusedmap <- annexeval $ Logs.Unused.readUnusedMap "" unusedmap <- annexeval $ Logs.Unused.readUnusedMap mempty
let unusedkeys = M.elems unusedmap let unusedkeys = M.elems unusedmap
assertEqual ("unused keys differ " ++ desc) assertEqual ("unused keys differ " ++ desc)
(sort expectedkeys) (sort unusedkeys) (sort expectedkeys) (sort unusedkeys)
@ -1433,7 +1434,7 @@ test_uncommitted_conflict_resolution = do
withtmpclonerepo $ \r2 -> do withtmpclonerepo $ \r2 -> do
indir r1 $ do indir r1 $ do
disconnectOrigin disconnectOrigin
createDirectoryIfMissing True (parentDir remoteconflictor) createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor)))
writecontent remoteconflictor annexedcontent writecontent remoteconflictor annexedcontent
add_annex conflictor @? "add remoteconflicter failed" add_annex conflictor @? "add remoteconflicter failed"
git_annex "sync" [] @? "sync failed in r1" git_annex "sync" [] @? "sync failed in r1"
@ -1681,7 +1682,8 @@ test_rsync_remote = intmpclonerepo $ do
test_bup_remote :: Assertion test_bup_remote :: Assertion
test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do 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 createDirectory dir
git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed"
git_annex "get" [annexedfile] @? "get of file failed" git_annex "get" [annexedfile] @? "get of file failed"
@ -1705,10 +1707,11 @@ test_crypto = do
where where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing gpgcmd = Utility.Gpg.mkGpgCmd Nothing
testscheme scheme = do testscheme scheme = do
abstmp <- absPath tmpdir abstmp <- fromRawFilePath <$> absPath (toRawFilePath tmpdir)
testscheme' scheme abstmp testscheme' scheme abstmp
testscheme' scheme abstmp = intmpclonerepo $ do testscheme' scheme abstmp = intmpclonerepo $ do
gpgtmp <- (</> "gpgtmp") <$> relPathCwdToFile abstmp gpgtmp <- (</> "gpgtmp") . fromRawFilePath
<$> relPathCwdToFile (toRawFilePath abstmp)
createDirectoryIfMissing False gpgtmp createDirectoryIfMissing False gpgtmp
Utility.Gpg.testTestHarness gpgtmp gpgcmd Utility.Gpg.testTestHarness gpgtmp gpgcmd
@? "test harness self-test failed" @? "test harness self-test failed"
@ -1805,7 +1808,7 @@ test_addurl :: Assertion
test_addurl = intmpclonerepo $ do test_addurl = intmpclonerepo $ do
-- file:// only; this test suite should not hit the network -- file:// only; this test suite should not hit the network
let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps) 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) let url = replace "\\" "/" ("file:///" ++ dropDrive f)
writecontent f "foo" writecontent f "foo"
git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url" git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url"

19
Utility/Path.hs
View file

@ -39,6 +39,7 @@ import Prelude
import Utility.Monad import Utility.Monad
import Utility.SystemDirectory import Utility.SystemDirectory
import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..", {- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator. - and removing the trailing path separator.
@ -84,13 +85,13 @@ upFrom dir
(drive, path) = splitDrive dir (drive, path) = splitDrive dir
dirs = filter (not . B.null) $ B.splitWith isPathSeparator path dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
prop_upFrom_basics :: RawFilePath -> Bool prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir prop_upFrom_basics dir
| B.null dir = True | null dir = True
| dir == "/" = p == Nothing | dir == "/" = p == Nothing
| otherwise = p /= Just dir | otherwise = p /= Just dir
where where
p = upFrom dir p = fromRawFilePath <$> upFrom (toRawFilePath dir)
{- Checks if the first RawFilePath is, or could be said to contain the second. {- 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 - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
@ -222,13 +223,15 @@ relPathDirToFileAbs from to
normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive
#endif #endif
prop_relPathDirToFileAbs_basics :: RawFilePath -> RawFilePath -> Bool prop_relPathDirToFileAbs_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFileAbs_basics from to prop_relPathDirToFileAbs_basics from to
| B.null from || B.null to = True | null from || null to = True
| from == to = B.null r | from == to = null r
| otherwise = not (B.null r) | otherwise = not (null r)
where where
r = relPathDirToFileAbs from to r = fromRawFilePath $ relPathDirToFileAbs
(toRawFilePath from)
(toRawFilePath to)
prop_relPathDirToFileAbs_regressionTest :: Bool prop_relPathDirToFileAbs_regressionTest :: Bool
prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference