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

more OsPath conversion (602/749)

Browse source 
Sponsored-by: Brock Spratlen
This commit is contained in:
Joey Hess 2025-02-07 14:46:11 -04:00
parent 2d1db7986c
commit a5d48edd94
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
25 changed files with 227 additions and 187 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Annex/Link.hs
View file

@ -71,7 +71,7 @@ getAnnexLinkTarget f = getAnnexLinkTarget' f
{- Pass False to force looking inside file, for when git checks out {- Pass False to force looking inside file, for when git checks out
- symlinks as plain files. -} - symlinks as plain files. -}
getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe LinkTarget)
getAnnexLinkTarget' file coresymlinks = if coresymlinks getAnnexLinkTarget' file coresymlinks = if coresymlinks
then check probesymlink $ then check probesymlink $
return Nothing return Nothing

2
Annex/Magic.hs
View file

@ -46,7 +46,7 @@ initMagicMime = return Nothing
getMagicMime :: Magic -> OsPath -> IO (Maybe (MimeType, MimeEncoding)) getMagicMime :: Magic -> OsPath -> IO (Maybe (MimeType, MimeEncoding))
#ifdef WITH_MAGICMIME #ifdef WITH_MAGICMIME
getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f) getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m (fromOsPath f))
where where
parse s = parse s =
let (mimetype, rest) = separate (== ';') s let (mimetype, rest) = separate (== ';') s

4
Backend.hs
View file

@ -63,11 +63,11 @@ genKey source meterupdate b = case B.genKey b of
Nothing -> giveup $ "Cannot generate a key for backend " ++ Nothing -> giveup $ "Cannot generate a key for backend " ++
decodeBS (formatKeyVariety (B.backendVariety b)) decodeBS (formatKeyVariety (B.backendVariety b))
getBackend :: FilePath -> Key -> Annex (Maybe Backend) getBackend :: OsPath -> Key -> Annex (Maybe Backend)
getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Just backend -> return $ Just backend Just backend -> return $ Just backend
Nothing -> do Nothing -> do
warning $ "skipping " <> QuotedPath (toOsPath file) <> " (" <> warning $ "skipping " <> QuotedPath file <> " (" <>
UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")" UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")"
return Nothing return Nothing

34
Command/Fix.hs
View file

@ -44,25 +44,27 @@ seek ps = unlessM crippledFileSystem $
data FixWhat = FixSymlinks | FixAll data FixWhat = FixSymlinks | FixAll
start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart start :: FixWhat -> SeekInput -> OsPath -> Key -> CommandStart
start fixwhat si file key = do start fixwhat si file key = do
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file'
wantlink <- calcRepo $ gitAnnexLink file key wantlink <- calcRepo $ gitAnnexLink file key
case currlink of case currlink of
Just l Just l
| l /= wantlink -> fixby $ fixSymlink file wantlink | l /= fromOsPath wantlink ->
fixby $ fixSymlink file wantlink
| otherwise -> stop | otherwise -> stop
Nothing -> case fixwhat of Nothing -> case fixwhat of
FixAll -> fixthin FixAll -> fixthin
FixSymlinks -> stop FixSymlinks -> stop
where where
file' = fromOsPath file
fixby = starting "fix" (mkActionItem (key, file)) si fixby = starting "fix" (mkActionItem (key, file)) si
fixthin = do fixthin = do
obj <- calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
thin <- annexThin <$> Annex.getGitConfig thin <- annexThin <$> Annex.getGitConfig
fs <- liftIO $ catchMaybeIO $ R.getFileStatus file fs <- liftIO $ catchMaybeIO $ R.getFileStatus file'
os <- liftIO $ catchMaybeIO $ R.getFileStatus obj os <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath obj)
case (linkCount <$> fs, linkCount <$> os, thin) of case (linkCount <$> fs, linkCount <$> os, thin) of
(Just 1, Just 1, True) -> (Just 1, Just 1, True) ->
fixby $ makeHardLink file key fixby $ makeHardLink file key
@ -70,10 +72,10 @@ start fixwhat si file key = do
fixby $ breakHardLink file key obj fixby $ breakHardLink file key obj
_ -> stop _ -> stop
breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform
breakHardLink file key obj = do breakHardLink file key obj = do
replaceWorkTreeFile file $ \tmp -> do replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
unlessM (checkedCopyFile key obj tmp mode) $ unlessM (checkedCopyFile key obj tmp mode) $
giveup "unable to break hard link" giveup "unable to break hard link"
thawContent tmp thawContent tmp
@ -81,26 +83,30 @@ breakHardLink file key obj = do
modifyContentDir obj $ freezeContent obj modifyContentDir obj $ freezeContent obj
next $ return True next $ return True
makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink :: OsPath -> Key -> CommandPerform
makeHardLink file key = do makeHardLink file key = do
replaceWorkTreeFile file $ \tmp -> do replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $ fileMode
<$> R.getFileStatus (fromOsPath file)
linkFromAnnex' key tmp mode >>= \case linkFromAnnex' key tmp mode >>= \case
LinkAnnexFailed -> giveup "unable to make hard link" LinkAnnexFailed -> giveup "unable to make hard link"
_ -> noop _ -> noop
next $ return True next $ return True
fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform fixSymlink :: OsPath -> OsPath -> CommandPerform
fixSymlink file link = do fixSymlink file link = do
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
-- preserve mtime of symlink -- preserve mtime of symlink
mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
<$> R.getSymbolicLinkStatus file <$> R.getSymbolicLinkStatus (fromOsPath file)
#endif #endif
replaceWorkTreeFile file $ \tmpfile -> do replaceWorkTreeFile file $ \tmpfile -> do
liftIO $ R.createSymbolicLink link tmpfile let tmpfile' = fromOsPath tmpfile
liftIO $ R.createSymbolicLink link' tmpfile'
#if ! defined(mingw32_HOST_OS) #if ! defined(mingw32_HOST_OS)
liftIO $ maybe noop (\t -> touch tmpfile t False) mtime liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime
#endif #endif
stageSymlink file =<< hashSymlink link stageSymlink file =<< hashSymlink link'
next $ return True next $ return True
where
link' = fromOsPath link

11
Command/FromKey.hs
View file

@ -59,7 +59,7 @@ seekBatch matcher fmt = batchInput fmt parse (commandAction . go)
let (keyname, file) = separate (== ' ') s let (keyname, file) = separate (== ' ') s
if not (null keyname) && not (null file) if not (null keyname) && not (null file)
then do then do
file' <- liftIO $ relPathCwdToFile (toRawFilePath file) file' <- liftIO $ relPathCwdToFile (toOsPath file)
return $ Right (file', keyOpt keyname) return $ Right (file', keyOpt keyname)
else return $ else return $
Left "Expected pairs of key and filename" Left "Expected pairs of key and filename"
@ -75,11 +75,10 @@ start matcher force (si, (keyname, file)) = do
inbackend <- inAnnex key inbackend <- inAnnex key
unless inbackend $ giveup $ unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
let file' = toOsPath file
let ai = mkActionItem (key, file') let ai = mkActionItem (key, file')
starting "fromkey" ai si $ starting "fromkey" ai si $
perform matcher key file' perform matcher key file'
where
file' = toRawFilePath file
-- From user input to a Key. -- From user input to a Key.
-- User can input either a serialized key, or an url. -- User can input either a serialized key, or an url.
@ -99,9 +98,9 @@ keyOpt' s = case parseURIPortable s of
Just k -> Right k Just k -> Right k
Nothing -> Left $ "bad key/url " ++ s Nothing -> Left $ "bad key/url " ++ s
perform :: AddUnlockedMatcher -> Key -> RawFilePath -> CommandPerform perform :: AddUnlockedMatcher -> Key -> OsPath -> CommandPerform
perform matcher key file = lookupKeyNotHidden file >>= \case perform matcher key file = lookupKeyNotHidden file >>= \case
Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file)) Nothing -> ifM (liftIO $ doesFileExist file)
( hasothercontent ( hasothercontent
, do , do
contentpresent <- inAnnex key contentpresent <- inAnnex key
@ -123,7 +122,7 @@ perform matcher key file = lookupKeyNotHidden file >>= \case
else writepointer else writepointer
, do , do
link <- calcRepo $ gitAnnexLink file key link <- calcRepo $ gitAnnexLink file key
addAnnexLink link file addAnnexLink (fromOsPath link) file
) )
next $ return True next $ return True
) )

92
Command/Fsck.hs
View file

@ -52,7 +52,6 @@ import System.Posix.Types (EpochTime)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import Data.Either import Data.Either
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime) import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime)
cmd :: Command cmd :: Command
@ -123,8 +122,8 @@ checkDeadRepo u =
whenM ((==) DeadTrusted <$> lookupTrust u) $ whenM ((==) DeadTrusted <$> lookupTrust u) $
earlyWarning "Warning: Fscking a repository that is currently marked as dead." earlyWarning "Warning: Fscking a repository that is currently marked as dead."
start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart start :: Maybe Remote -> Incremental -> SeekInput -> OsPath -> Key -> CommandStart
start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case start from inc si file key = Backend.getBackend file key >>= \case
Nothing -> stop Nothing -> stop
Just backend -> do Just backend -> do
(numcopies, _mincopies) <- getFileNumMinCopies file (numcopies, _mincopies) <- getFileNumMinCopies file
@ -135,7 +134,7 @@ start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \
go = runFsck inc si (mkActionItem (key, afile)) key go = runFsck inc si (mkActionItem (key, afile)) key
afile = AssociatedFile (Just file) afile = AssociatedFile (Just file)
perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool perform :: Key -> OsPath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = do perform key file backend numcopies = do
keystatus <- getKeyFileStatus key file keystatus <- getKeyFileStatus key file
check check
@ -194,11 +193,11 @@ performRemote key afile numcopies remote =
pid <- liftIO getPID pid <- liftIO getPID
t <- fromRepo gitAnnexTmpObjectDir t <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory t createAnnexDirectory t
let tmp = t P.</> "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key let tmp = t </> literalOsPath "fsck" <> toOsPath (show pid) <> literalOsPath "." <> keyFile key
let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop) let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
cleanup cleanup
cleanup `after` a tmp cleanup `after` a tmp
getfile tmp = ifM (checkDiskSpace Nothing (Just (P.takeDirectory tmp)) key 0 True) getfile tmp = ifM (checkDiskSpace Nothing (Just (takeDirectory tmp)) key 0 True)
( ifM (getcheap tmp) ( ifM (getcheap tmp)
( return (Just (Right UnVerified)) ( return (Just (Right UnVerified))
, ifM (Annex.getRead Annex.fast) , ifM (Annex.getRead Annex.fast)
@ -208,9 +207,9 @@ performRemote key afile numcopies remote =
) )
, return Nothing , return Nothing
) )
getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) nullMeterUpdate (RemoteVerify remote) getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp nullMeterUpdate (RemoteVerify remote)
getcheap tmp = case Remote.retrieveKeyFileCheap remote of getcheap tmp = case Remote.retrieveKeyFileCheap remote of
Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) Just a -> isRight <$> tryNonAsync (a key afile tmp)
Nothing -> return False Nothing -> return False
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart
@ -236,10 +235,10 @@ check :: [Annex Bool] -> Annex Bool
check cs = and <$> sequence cs check cs = and <$> sequence cs
{- Checks that symlinks points correctly to the annexed content. -} {- Checks that symlinks points correctly to the annexed content. -}
fixLink :: Key -> RawFilePath -> Annex Bool fixLink :: Key -> OsPath -> Annex Bool
fixLink key file = do fixLink key file = do
want <- calcRepo $ gitAnnexLink file key want <- calcRepo $ gitAnnexLink file key
have <- getAnnexLinkTarget file have <- fmap toOsPath <$> getAnnexLinkTarget file
maybe noop (go want) have maybe noop (go want) have
return True return True
where where
@ -247,8 +246,8 @@ fixLink key file = do
| want /= fromInternalGitPath have = do | want /= fromInternalGitPath have = do
showNote "fixing link" showNote "fixing link"
createWorkTreeDirectory (parentDir file) createWorkTreeDirectory (parentDir file)
liftIO $ R.removeLink file liftIO $ R.removeLink (fromOsPath file)
addAnnexLink want file addAnnexLink (fromOsPath want) file
| otherwise = noop | otherwise = noop
{- A repository that supports symlinks and is not bare may have in the past {- A repository that supports symlinks and is not bare may have in the past
@ -272,7 +271,7 @@ fixObjectLocation key = do
idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key) idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key)
if loc == idealloc if loc == idealloc
then return True then return True
else ifM (liftIO $ R.doesPathExist loc) else ifM (liftIO $ R.doesPathExist $ fromOsPath loc)
( moveobjdir loc idealloc ( moveobjdir loc idealloc
`catchNonAsync` \_e -> return True `catchNonAsync` \_e -> return True
, return True , return True
@ -291,14 +290,12 @@ fixObjectLocation key = do
-- Thaw the content directory to allow renaming it. -- Thaw the content directory to allow renaming it.
thawContentDir src thawContentDir src
createAnnexDirectory (parentDir destdir) createAnnexDirectory (parentDir destdir)
liftIO $ renameDirectory liftIO $ renameDirectory srcdir destdir
(fromRawFilePath srcdir)
(fromRawFilePath destdir)
-- Since the directory was moved, lockContentForRemoval -- Since the directory was moved, lockContentForRemoval
-- will not be able to remove the lock file it -- will not be able to remove the lock file it
-- made. So, remove the lock file here. -- made. So, remove the lock file here.
mlockfile <- contentLockFile key =<< getVersion mlockfile <- contentLockFile key =<< getVersion
liftIO $ maybe noop (removeWhenExistsWith R.removeLink) mlockfile liftIO $ maybe noop (removeWhenExistsWith removeFile) mlockfile
freezeContentDir dest freezeContentDir dest
cleanObjectDirs src cleanObjectDirs src
return True return True
@ -310,7 +307,7 @@ verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
verifyLocationLog key keystatus ai = do verifyLocationLog key keystatus ai = do
obj <- calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
present <- if isKeyUnlockedThin keystatus present <- if isKeyUnlockedThin keystatus
then liftIO (doesFileExist (fromRawFilePath obj)) then liftIO (doesFileExist obj)
else inAnnex key else inAnnex key
u <- getUUID u <- getUUID
@ -324,7 +321,7 @@ verifyLocationLog key keystatus ai = do
checkContentWritePerm obj >>= \case checkContentWritePerm obj >>= \case
Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set" Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set"
_ -> return () _ -> return ()
whenM (liftIO $ R.doesPathExist $ parentDir obj) $ whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
freezeContentDir obj freezeContentDir obj
{- Warn when annex.securehashesonly is set and content using an {- Warn when annex.securehashesonly is set and content using an
@ -401,7 +398,7 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
verifyRequiredContent _ _ = return True verifyRequiredContent _ _ = return True
{- Verifies the associated file records. -} {- Verifies the associated file records. -}
verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool verifyAssociatedFiles :: Key -> KeyStatus -> OsPath -> Annex Bool
verifyAssociatedFiles key keystatus file = do verifyAssociatedFiles key keystatus file = do
when (isKeyUnlockedThin keystatus) $ do when (isKeyUnlockedThin keystatus) $ do
f <- inRepo $ toTopFilePath file f <- inRepo $ toTopFilePath file
@ -410,7 +407,7 @@ verifyAssociatedFiles key keystatus file = do
Database.Keys.addAssociatedFile key f Database.Keys.addAssociatedFile key f
return True return True
verifyWorkTree :: Key -> RawFilePath -> Annex Bool verifyWorkTree :: Key -> OsPath -> Annex Bool
verifyWorkTree key file = do verifyWorkTree key file = do
{- Make sure that a pointer file is replaced with its content, {- Make sure that a pointer file is replaced with its content,
- when the content is available. -} - when the content is available. -}
@ -419,7 +416,9 @@ verifyWorkTree key file = do
Just k | k == key -> whenM (inAnnex key) $ do Just k | k == key -> whenM (inAnnex key) $ do
showNote "fixing worktree content" showNote "fixing worktree content"
replaceWorkTreeFile file $ \tmp -> do replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus
(fromOsPath file)
ifM (annexThin <$> Annex.getGitConfig) ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex' key tmp mode ( void $ linkFromAnnex' key tmp mode
, do , do
@ -440,20 +439,20 @@ checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool
checkKeySize _ KeyUnlockedThin _ = return True checkKeySize _ KeyUnlockedThin _ = return True
checkKeySize key _ ai = do checkKeySize key _ ai = do
file <- calcRepo $ gitAnnexLocation key file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ R.doesPathExist file) ifM (liftIO $ R.doesPathExist (fromOsPath file))
( checkKeySizeOr badContent key file ai ( checkKeySizeOr badContent key file ai
, return True , return True
) )
withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool withLocalCopy :: Maybe OsPath -> (OsPath -> Annex Bool) -> Annex Bool
withLocalCopy Nothing _ = return True withLocalCopy Nothing _ = return True
withLocalCopy (Just localcopy) f = f localcopy withLocalCopy (Just localcopy) f = f localcopy
checkKeySizeRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool checkKeySizeRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool
checkKeySizeRemote key remote ai localcopy = checkKeySizeRemote key remote ai localcopy =
checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai
checkKeySizeOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool checkKeySizeOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool
checkKeySizeOr bad key file ai = case fromKey keySize key of checkKeySizeOr bad key file ai = case fromKey keySize key of
Nothing -> return True Nothing -> return True
Just size -> do Just size -> do
@ -505,7 +504,7 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool
checkBackend key keystatus afile = do checkBackend key keystatus afile = do
content <- calcRepo (gitAnnexLocation key) content <- calcRepo (gitAnnexLocation key)
ifM (liftIO $ R.doesPathExist content) ifM (liftIO $ R.doesPathExist (fromOsPath content))
( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
( nocheck ( nocheck
, do , do
@ -524,11 +523,11 @@ checkBackend key keystatus afile = do
ai = mkActionItem (key, afile) ai = mkActionItem (key, afile)
checkBackendRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool checkBackendRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool
checkBackendRemote key remote ai localcopy = checkBackendRemote key remote ai localcopy =
checkBackendOr (badContentRemote remote localcopy) key localcopy ai checkBackendOr (badContentRemote remote localcopy) key localcopy ai
checkBackendOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool checkBackendOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool
checkBackendOr bad key file ai = checkBackendOr bad key file ai =
ifM (Annex.getRead Annex.fast) ifM (Annex.getRead Annex.fast)
( return True ( return True
@ -552,7 +551,7 @@ checkBackendOr bad key file ai =
- verified to be correct. The InodeCache is generated again to detect if - verified to be correct. The InodeCache is generated again to detect if
- the object file was changed while the content was being verified. - the object file was changed while the content was being verified.
-} -}
checkInodeCache :: Key -> RawFilePath -> Maybe InodeCache -> ActionItem -> Annex () checkInodeCache :: Key -> OsPath -> Maybe InodeCache -> ActionItem -> Annex ()
checkInodeCache key content mic ai = case mic of checkInodeCache key content mic ai = case mic of
Nothing -> noop Nothing -> noop
Just ic -> do Just ic -> do
@ -569,7 +568,7 @@ checkInodeCache key content mic ai = case mic of
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do checkKeyNumCopies key afile numcopies = do
let (desc, hasafile) = case afile of let (desc, hasafile) = case afile of
AssociatedFile Nothing -> (serializeKey' key, False) AssociatedFile Nothing -> (toOsPath (serializeKey'' key), False)
AssociatedFile (Just af) -> (af, True) AssociatedFile (Just af) -> (af, True)
locs <- loggedLocations key locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
@ -590,7 +589,7 @@ checkKeyNumCopies key afile numcopies = do
) )
else return True else return True
missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath missingNote :: OsPath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
missingNote file 0 _ [] dead = missingNote file 0 _ [] dead =
"** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead) "** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead)
missingNote file 0 _ untrusted dead = missingNote file 0 _ untrusted dead =
@ -615,25 +614,24 @@ honorDead dead
badContent :: Key -> Annex String badContent :: Key -> Annex String
badContent key = do badContent key = do
dest <- moveBad key dest <- moveBad key
return $ "moved to " ++ fromRawFilePath dest return $ "moved to " ++ fromOsPath dest
{- Bad content is dropped from the remote. We have downloaded a copy {- Bad content is dropped from the remote. We have downloaded a copy
- from the remote to a temp file already (in some cases, it's just a - from the remote to a temp file already (in some cases, it's just a
- symlink to a file in the remote). To avoid any further data loss, - symlink to a file in the remote). To avoid any further data loss,
- that temp file is moved to the bad content directory unless - that temp file is moved to the bad content directory unless
- the local annex has a copy of the content. -} - the local annex has a copy of the content. -}
badContentRemote :: Remote -> RawFilePath -> Key -> Annex String badContentRemote :: Remote -> OsPath -> Key -> Annex String
badContentRemote remote localcopy key = do badContentRemote remote localcopy key = do
bad <- fromRepo gitAnnexBadDir bad <- fromRepo gitAnnexBadDir
let destbad = bad P.</> keyFile key let destbad = bad </> keyFile key
let destbad' = fromRawFilePath destbad movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad))
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad'))
( return False ( return False
, do , do
createAnnexDirectory (parentDir destbad) createAnnexDirectory (parentDir destbad)
liftIO $ catchDefaultIO False $ liftIO $ catchDefaultIO False $
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy) ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath localcopy))
( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad' ( copyFileExternal CopyTimeStamps localcopy destbad
, do , do
moveFile localcopy destbad moveFile localcopy destbad
return True return True
@ -645,7 +643,7 @@ badContentRemote remote localcopy key = do
Remote.logStatus NoLiveUpdate remote key InfoMissing Remote.logStatus NoLiveUpdate remote key InfoMissing
return $ case (movedbad, dropped) of return $ case (movedbad, dropped) of
(True, Right ()) -> "moved from " ++ Remote.name remote ++ (True, Right ()) -> "moved from " ++ Remote.name remote ++
" to " ++ fromRawFilePath destbad " to " ++ fromOsPath destbad
(False, Right ()) -> "dropped from " ++ Remote.name remote (False, Right ()) -> "dropped from " ++ Remote.name remote
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e (_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
@ -678,10 +676,10 @@ recordStartTime :: UUID -> Annex ()
recordStartTime u = do recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u) f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f createAnnexDirectory $ parentDir f
liftIO $ removeWhenExistsWith R.removeLink f liftIO $ removeWhenExistsWith removeFile f
liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do liftIO $ F.withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
t <- modificationTime <$> R.getFileStatus f t <- modificationTime <$> R.getFileStatus (fromOsPath f)
#else #else
t <- getPOSIXTime t <- getPOSIXTime
#endif #endif
@ -692,7 +690,7 @@ recordStartTime u = do
showTime = show showTime = show
resetStartTime :: UUID -> Annex () resetStartTime :: UUID -> Annex ()
resetStartTime u = liftIO . removeWhenExistsWith R.removeLink resetStartTime u = liftIO . removeWhenExistsWith removeFile
=<< fromRepo (gitAnnexFsckState u) =<< fromRepo (gitAnnexFsckState u)
{- Gets the incremental fsck start time. -} {- Gets the incremental fsck start time. -}
@ -700,9 +698,9 @@ getStartTime :: UUID -> Annex (Maybe EpochTime)
getStartTime u = do getStartTime u = do
f <- fromRepo (gitAnnexFsckState u) f <- fromRepo (gitAnnexFsckState u)
liftIO $ catchDefaultIO Nothing $ do liftIO $ catchDefaultIO Nothing $ do
timestamp <- modificationTime <$> R.getFileStatus f timestamp <- modificationTime <$> R.getFileStatus (fromOsPath f)
let fromstatus = Just (realToFrac timestamp) let fromstatus = Just (realToFrac timestamp)
fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f) fromfile <- parsePOSIXTime <$> F.readFile' f
return $ if matchingtimestamp fromfile fromstatus return $ if matchingtimestamp fromfile fromstatus
then Just timestamp then Just timestamp
else Nothing else Nothing

36
Command/FuzzTest.hs
View file

@ -123,13 +123,14 @@ instance ToFilePath FuzzDir where
toFilePath (FuzzDir d) = d toFilePath (FuzzDir d) = d
isFuzzFile :: FilePath -> Bool isFuzzFile :: FilePath -> Bool
isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f isFuzzFile f = "fuzzfile_" `isPrefixOf` fromOsPath (takeFileName (toOsPath f))
isFuzzDir :: FilePath -> Bool isFuzzDir :: FilePath -> Bool
isFuzzDir d = "fuzzdir_" `isPrefixOf` d isFuzzDir d = "fuzzdir_" `isPrefixOf` d
mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file) mkFuzzFile file dirs = FuzzFile $ fromOsPath $
joinPath (map (toOsPath . toFilePath) dirs) </> toOsPath ("fuzzfile_" ++ file)
mkFuzzDir :: Int -> FuzzDir mkFuzzDir :: Int -> FuzzDir
mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n
@ -175,15 +176,15 @@ instance Arbitrary FuzzAction where
runFuzzAction :: FuzzAction -> Annex () runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = do runFuzzAction (FuzzAdd (FuzzFile f)) = do
createWorkTreeDirectory (parentDir (toRawFilePath f)) createWorkTreeDirectory (parentDir (toOsPath f))
n <- liftIO (getStdRandom random :: IO Int) n <- liftIO (getStdRandom random :: IO Int)
liftIO $ writeFile f $ show n ++ "\n" liftIO $ writeFile f $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $
removeWhenExistsWith R.removeLink (toRawFilePath f) removeWhenExistsWith removeFile (toOsPath f)
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
R.rename (toRawFilePath src) (toRawFilePath dest) R.rename (toRawFilePath src) (toRawFilePath dest)
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
removeDirectoryRecursive d removeDirectoryRecursive (toOsPath d)
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
R.rename (toRawFilePath src) (toRawFilePath dest) R.rename (toRawFilePath src) (toRawFilePath dest)
runFuzzAction (FuzzPause d) = randomDelay d runFuzzAction (FuzzPause d) = randomDelay d
@ -210,7 +211,7 @@ genFuzzAction = do
case md of case md of
Nothing -> genFuzzAction Nothing -> genFuzzAction
Just d -> do Just d -> do
newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d) newd <- liftIO $ newDir (parentDir $ toOsPath $ toFilePath d)
maybe genFuzzAction (return . FuzzMoveDir d) newd maybe genFuzzAction (return . FuzzMoveDir d) newd
FuzzDeleteDir _ -> do FuzzDeleteDir _ -> do
d <- liftIO existingDir d <- liftIO existingDir
@ -221,7 +222,8 @@ existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
existingFile 0 _ = return Nothing existingFile 0 _ = return Nothing
existingFile n top = do existingFile n top = do
dir <- existingDirIncludingTop dir <- existingDirIncludingTop
contents <- catchDefaultIO [] (getDirectoryContents dir) contents <- map fromOsPath
<$> catchDefaultIO [] (getDirectoryContents (toOsPath dir))
let files = filter isFuzzFile contents let files = filter isFuzzFile contents
if null files if null files
then do then do
@ -230,19 +232,21 @@ existingFile n top = do
then return Nothing then return Nothing
else do else do
i <- getStdRandom $ randomR (0, length dirs - 1) i <- getStdRandom $ randomR (0, length dirs - 1)
existingFile (n - 1) (top </> dirs !! i) existingFile (n - 1) (fromOsPath (toOsPath top </> toOsPath (dirs !! i)))
else do else do
i <- getStdRandom $ randomR (0, length files - 1) i <- getStdRandom $ randomR (0, length files - 1)
return $ Just $ FuzzFile $ top </> dir </> files !! i return $ Just $ FuzzFile $ fromOsPath $
toOsPath top </> toOsPath dir </> toOsPath (files !! i)
existingDirIncludingTop :: IO FilePath existingDirIncludingTop :: IO FilePath
existingDirIncludingTop = do existingDirIncludingTop = do
dirs <- filter isFuzzDir <$> getDirectoryContents "." dirs <- filter (isFuzzDir . fromOsPath)
<$> getDirectoryContents (literalOsPath ".")
if null dirs if null dirs
then return "." then return "."
else do else do
n <- getStdRandom $ randomR (0, length dirs) n <- getStdRandom $ randomR (0, length dirs)
return $ ("." : dirs) !! n return $ fromOsPath $ (literalOsPath "." : dirs) !! n
existingDir :: IO (Maybe FuzzDir) existingDir :: IO (Maybe FuzzDir)
existingDir = do existingDir = do
@ -257,21 +261,21 @@ newFile = go (100 :: Int)
go 0 = return Nothing go 0 = return Nothing
go n = do go n = do
f <- genFuzzFile f <- genFuzzFile
ifM (doesnotexist (toFilePath f)) ifM (doesnotexist (toOsPath (toFilePath f)))
( return $ Just f ( return $ Just f
, go (n - 1) , go (n - 1)
) )
newDir :: RawFilePath -> IO (Maybe FuzzDir) newDir :: OsPath -> IO (Maybe FuzzDir)
newDir parent = go (100 :: Int) newDir parent = go (100 :: Int)
where where
go 0 = return Nothing go 0 = return Nothing
go n = do go n = do
(FuzzDir d) <- genFuzzDir (FuzzDir d) <- genFuzzDir
ifM (doesnotexist (fromRawFilePath parent </> d)) ifM (doesnotexist (parent </> toOsPath d))
( return $ Just $ FuzzDir d ( return $ Just $ FuzzDir d
, go (n - 1) , go (n - 1)
) )
doesnotexist :: FilePath -> IO Bool doesnotexist :: OsPath -> IO Bool
doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f))

28
Command/Info.hs
View file

@ -14,7 +14,7 @@ import "mtl" Control.Monad.State.Strict
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified System.FilePath.ByteString as P import Data.ByteString.Short (fromShort)
import System.PosixCompat.Files (isDirectory) import System.PosixCompat.Files (isDirectory)
import Data.Ord import Data.Ord
import qualified Data.Semigroup as Sem import qualified Data.Semigroup as Sem
@ -188,9 +188,9 @@ itemInfo o (si, p) = ifM (isdir (toRawFilePath p))
Right r -> remoteInfo o r si Right r -> remoteInfo o r si
Left _ -> Remote.nameToUUID' p >>= \case Left _ -> Remote.nameToUUID' p >>= \case
([], _) -> do ([], _) -> do
relp <- liftIO $ relPathCwdToFile (toRawFilePath p) relp <- liftIO $ relPathCwdToFile (toOsPath p)
lookupKey relp >>= \case lookupKey relp >>= \case
Just k -> fileInfo o (fromRawFilePath relp) si k Just k -> fileInfo o (fromOsPath relp) si k
Nothing -> treeishInfo o p si Nothing -> treeishInfo o p si
([u], _) -> uuidInfo o u si ([u], _) -> uuidInfo o u si
(_us, msg) -> noInfo p si msg (_us, msg) -> noInfo p si msg
@ -203,7 +203,7 @@ noInfo s si msg = do
-- The string may not really be a file, but use ActionItemTreeFile, -- The string may not really be a file, but use ActionItemTreeFile,
-- rather than ActionItemOther to avoid breaking back-compat of -- rather than ActionItemOther to avoid breaking back-compat of
-- json output. -- json output.
let ai = ActionItemTreeFile (toRawFilePath s) let ai = ActionItemTreeFile (toOsPath s)
showStartMessage (StartMessage "info" ai si) showStartMessage (StartMessage "info" ai si)
showNote (UnquotedString msg) showNote (UnquotedString msg)
showEndFail showEndFail
@ -237,7 +237,7 @@ treeishInfo o t si = do
fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex () fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()
fileInfo o file si k = do fileInfo o file si k = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
let file' = toRawFilePath file let file' = toOsPath file
whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $ whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $
showCustom (unwords ["info", file]) si $ do showCustom (unwords ["info", file]) si $ do
evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o) evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)
@ -502,17 +502,17 @@ transfer_list = stat desc $ nojson $ lift $ do
where where
desc = "transfers in progress" desc = "transfers in progress"
line qp uuidmap t i = unwords line qp uuidmap t i = unwords
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing" [ decodeBS $ fromShort (formatDirection (transferDirection t)) <> "ing"
, fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem , decodeBS $ quote qp $ actionItemDesc $ mkActionItem
(transferKey t, associatedFile i) (transferKey t, associatedFile i)
, if transferDirection t == Upload then "to" else "from" , if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $ , maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap M.lookup (transferUUID t) uuidmap
] ]
jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $ jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $
[ ("transfer", toJSON' (formatDirection (transferDirection t))) [ ("transfer", toJSON' (fromShort (formatDirection (transferDirection t))))
, ("key", toJSON' (transferKey t)) , ("key", toJSON' (transferKey t))
, ("file", toJSON' (fromRawFilePath <$> afile)) , ("file", toJSON' ((fromOsPath <$> afile) :: Maybe FilePath))
, ("remote", toJSON' (fromUUID (transferUUID t) :: String)) , ("remote", toJSON' (fromUUID (transferUUID t) :: String))
] ]
where where
@ -522,7 +522,7 @@ disk_size :: Stat
disk_size = simpleStat "available local disk space" $ disk_size = simpleStat "available local disk space" $
calcfree calcfree
<$> (lift $ annexDiskReserve <$> Annex.getGitConfig) <$> (lift $ annexDiskReserve <$> Annex.getGitConfig)
<*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir) <*> (lift $ inRepo $ getDiskFree . fromOsPath . gitAnnexDir)
<*> mkSizer <*> mkSizer
where where
calcfree reserve (Just have) sizer = unwords calcfree reserve (Just have) sizer = unwords
@ -700,7 +700,7 @@ getDirStatInfo o dir = do
fast <- Annex.getRead Annex.fast fast <- Annex.getRead Annex.fast
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
(presentdata, referenceddata, numcopiesstats, repodata) <- (presentdata, referenceddata, numcopiesstats, repodata) <-
Command.Unused.withKeysFilesReferencedIn dir initial Command.Unused.withKeysFilesReferencedIn (toOsPath dir) initial
(update matcher fast) (update matcher fast)
return $ StatInfo return $ StatInfo
(Just presentdata) (Just presentdata)
@ -797,7 +797,7 @@ updateRepoData key locs m = m'
M.fromList $ zip locs (map update locs) M.fromList $ zip locs (map update locs)
update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m) update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m)
updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats updateNumCopiesStats :: OsPath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats
updateNumCopiesStats file (NumCopiesStats m) locs = do updateNumCopiesStats file (NumCopiesStats m) locs = do
have <- trustExclude UnTrusted locs have <- trustExclude UnTrusted locs
!variance <- Variance <$> numCopiesCheck' file (-) have !variance <- Variance <$> numCopiesCheck' file (-) have
@ -817,7 +817,7 @@ showSizeKeys d = do
"+ " ++ show (unknownSizeKeys d) ++ "+ " ++ show (unknownSizeKeys d) ++
" unknown size" " unknown size"
staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat staleSize :: String -> (Git.Repo -> OsPath) -> Stat
staleSize label dirspec = go =<< lift (dirKeys dirspec) staleSize label dirspec = go =<< lift (dirKeys dirspec)
where where
go [] = nostat go [] = nostat
@ -830,7 +830,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec)
keysizes keys = do keysizes keys = do
dir <- lift $ fromRepo dirspec dir <- lift $ fromRepo dirspec
liftIO $ forM keys $ \k -> liftIO $ forM keys $ \k ->
catchDefaultIO 0 $ getFileSize (dir P.</> keyFile k) catchDefaultIO 0 $ getFileSize (dir </> keyFile k)
aside :: String -> String aside :: String -> String
aside s = " (" ++ s ++ ")" aside s = " (" ++ s ++ ")"

9
Command/Inprogress.hs
View file

@ -51,14 +51,17 @@ seek o = do
where where
ww = WarnUnmatchLsFiles "inprogress" ww = WarnUnmatchLsFiles "inprogress"
start :: IsTerminal -> S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart start :: IsTerminal -> S.Set Key -> SeekInput -> OsPath -> Key -> CommandStart
start isterminal s _si _file k start isterminal s _si _file k
| S.member k s = start' isterminal k | S.member k s = start' isterminal k
| otherwise = stop | otherwise = stop
start' :: IsTerminal -> Key -> CommandStart start' :: IsTerminal -> Key -> CommandStart
start' (IsTerminal isterminal) k = startingCustomOutput k $ do start' (IsTerminal isterminal) k = startingCustomOutput k $ do
tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k) tmpf <- fromRepo (gitAnnexTmpObjectLocation k)
whenM (liftIO $ doesFileExist tmpf) $ whenM (liftIO $ doesFileExist tmpf) $
liftIO $ putStrLn (if isterminal then safeOutput tmpf else tmpf) liftIO $ putStrLn $
if isterminal
then safeOutput (fromOsPath tmpf)
else fromOsPath tmpf
next $ return True next $ return True

4
Command/List.hs
View file

@ -82,7 +82,7 @@ getList o
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
printHeader l = liftIO $ putStrLn $ safeOutput $ lheader $ map (\(_, n, t) -> (n, t)) l printHeader l = liftIO $ putStrLn $ safeOutput $ lheader $ map (\(_, n, t) -> (n, t)) l
start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> OsPath -> Key -> CommandStart
start l _si file key = do start l _si file key = do
ls <- S.fromList <$> keyLocations key ls <- S.fromList <$> keyLocations key
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
@ -100,7 +100,7 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length
trust UnTrusted = " (untrusted)" trust UnTrusted = " (untrusted)"
trust _ = "" trust _ = ""
format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath format :: [(TrustLevel, Present)] -> OsPath -> StringContainingQuotedPath
format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file
where where
thereMap = concatMap there remotes thereMap = concatMap there remotes

12
Command/Lock.hs
View file

@ -39,7 +39,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
, usesLocationLog = False , usesLocationLog = False
} }
start :: SeekInput -> RawFilePath -> Key -> CommandStart start :: SeekInput -> OsPath -> Key -> CommandStart
start si file key = ifM (isJust <$> isAnnexLink file) start si file key = ifM (isJust <$> isAnnexLink file)
( stop ( stop
, starting "lock" (mkActionItem (key, file)) si $ , starting "lock" (mkActionItem (key, file)) si $
@ -59,7 +59,7 @@ start si file key = ifM (isJust <$> isAnnexLink file)
) )
cont = perform file key cont = perform file key
perform :: RawFilePath -> Key -> CommandPerform perform :: OsPath -> Key -> CommandPerform
perform file key = do perform file key = do
lockdown =<< calcRepo (gitAnnexLocation key) lockdown =<< calcRepo (gitAnnexLocation key)
addSymlink file key =<< withTSDelta (liftIO . genInodeCache file) addSymlink file key =<< withTSDelta (liftIO . genInodeCache file)
@ -70,12 +70,14 @@ perform file key = do
( breakhardlink obj ( breakhardlink obj
, repopulate obj , repopulate obj
) )
whenM (liftIO $ R.doesPathExist obj) $ whenM (liftIO $ doesFileExist obj) $
freezeContent obj freezeContent obj
getlinkcount obj = linkCount <$> liftIO (R.getFileStatus (fromOsPath obj))
-- It's ok if the file is hard linked to obj, but if some other -- It's ok if the file is hard linked to obj, but if some other
-- associated file is, we need to break that link to lock down obj. -- associated file is, we need to break that link to lock down obj.
breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do breakhardlink obj = whenM (catchBoolIO $ (> 1) <$> getlinkcount obj) $ do
mfc <- withTSDelta (liftIO . genInodeCache file) mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do
@ -89,7 +91,7 @@ perform file key = do
fs <- map (`fromTopFilePath` g) fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key <$> Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs mfile <- firstM (isUnmodified key) fs
liftIO $ removeWhenExistsWith R.removeLink obj liftIO $ removeWhenExistsWith removeFile obj
case mfile of case mfile of
Just unmodified -> Just unmodified ->
ifM (checkedCopyFile key unmodified obj Nothing) ifM (checkedCopyFile key unmodified obj Nothing)

28
Command/Log.hs
View file

@ -15,7 +15,6 @@ import Data.Char
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Time import Data.Time
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async import Control.Concurrent.Async
import Command import Command
@ -34,6 +33,7 @@ import Git.CatFile
import Types.TrustLevel import Types.TrustLevel
import Utility.DataUnits import Utility.DataUnits
import Utility.HumanTime import Utility.HumanTime
import qualified Utility.FileIO as F
data LogChange = Added | Removed data LogChange = Added | Removed
@ -282,15 +282,15 @@ getKeyLog key os = do
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
p <- liftIO $ relPathCwdToFile top p <- liftIO $ relPathCwdToFile top
config <- Annex.getGitConfig config <- Annex.getGitConfig
let logfile = p P.</> locationLogFile config key let logfile = p </> locationLogFile config key
getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os) getGitLogAnnex [logfile] (Param "--remove-empty" : os)
getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool) getGitLogAnnex :: [OsPath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool)
getGitLogAnnex fs os = do getGitLogAnnex fs os = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
let fileselector = \_sha f -> let fileselector = \_sha f ->
locationLogFileKey config (toRawFilePath f) locationLogFileKey config f
inRepo $ getGitLog Annex.Branch.fullname Nothing fs os fileselector inRepo $ getGitLog Annex.Branch.fullname Nothing (map fromOsPath fs) os fileselector
showTimeStamp :: TimeZone -> String -> POSIXTime -> String showTimeStamp :: TimeZone -> String -> POSIXTime -> String
showTimeStamp zone format = formatTime defaultTimeLocale format showTimeStamp zone format = formatTime defaultTimeLocale format
@ -320,11 +320,11 @@ sizeHistoryInfo mu o = do
-- and to the trust log. -- and to the trust log.
getlog = do getlog = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
let fileselector = \_sha f -> let f' = toRawFilePath f in let fileselector = \_sha f ->
case locationLogFileKey config f' of case locationLogFileKey config f of
Just k -> Just (Right k) Just k -> Just (Right k)
Nothing Nothing
| f' == trustLog -> Just (Left ()) | f == trustLog -> Just (Left ())
| otherwise -> Nothing | otherwise -> Nothing
inRepo $ getGitLog Annex.Branch.fullname Nothing [] inRepo $ getGitLog Annex.Branch.fullname Nothing []
[ Param "--date-order" [ Param "--date-order"
@ -409,10 +409,10 @@ sizeHistoryInfo mu o = do
displaystart uuidmap zone displaystart uuidmap zone
| gnuplotOption o = do | gnuplotOption o = do
file <- (</>) file <- (</>)
<$> fromRepo (fromRawFilePath . gitAnnexDir) <$> fromRepo gitAnnexDir
<*> pure "gnuplot" <*> pure (literalOsPath "gnuplot")
liftIO $ putStrLn $ "Generating gnuplot script in " ++ file liftIO $ putStrLn $ "Generating gnuplot script in " ++ fromOsPath file
h <- liftIO $ openFile file WriteMode h <- liftIO $ F.openFile file WriteMode
liftIO $ mapM_ (hPutStrLn h) liftIO $ mapM_ (hPutStrLn h)
[ "set datafile separator ','" [ "set datafile separator ','"
, "set timefmt \"%Y-%m-%dT%H:%M:%S\"" , "set timefmt \"%Y-%m-%dT%H:%M:%S\""
@ -442,7 +442,7 @@ sizeHistoryInfo mu o = do
hFlush h hFlush h
putStrLn $ "Running gnuplot..." putStrLn $ "Running gnuplot..."
void $ liftIO $ boolSystem "gnuplot" void $ liftIO $ boolSystem "gnuplot"
[Param "-p", File file] [Param "-p", File (fromOsPath file)]
return (dispst h endaction) return (dispst h endaction)
| sizesOption o = do | sizesOption o = do
liftIO $ putStrLn uuidmapheader liftIO $ putStrLn uuidmapheader

10
Command/LookupKey.hs
View file

@ -37,7 +37,7 @@ run o _ file
| refOption o = catKey (Ref (toRawFilePath file)) >>= display | refOption o = catKey (Ref (toRawFilePath file)) >>= display
| otherwise = do | otherwise = do
checkNotBareRepo checkNotBareRepo
seekSingleGitFile file >>= \case seekSingleGitFile (toOsPath file) >>= \case
Nothing -> return False Nothing -> return False
Just file' -> catKeyFile file' >>= display Just file' -> catKeyFile file' >>= display
@ -51,13 +51,13 @@ display Nothing = return False
-- To support absolute filenames, pass through git ls-files. -- To support absolute filenames, pass through git ls-files.
-- But, this plumbing command does not recurse through directories. -- But, this plumbing command does not recurse through directories.
seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath) seekSingleGitFile :: OsPath -> Annex (Maybe OsPath)
seekSingleGitFile file seekSingleGitFile file
| isRelative file = return (Just (toRawFilePath file)) | isRelative file = return (Just file)
| otherwise = do | otherwise = do
(l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file]) (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [file])
r <- case l of r <- case l of
(f:[]) | takeFileName (fromRawFilePath f) == takeFileName file -> (f:[]) | takeFileName f == takeFileName file ->
return (Just f) return (Just f)
_ -> return Nothing _ -> return Nothing
void $ liftIO cleanup void $ liftIO cleanup

16
Command/Map.hs
View file

@ -49,22 +49,22 @@ start = startingNoMessage (ActionItemOther Nothing) $ do
trustmap <- trustMapLoad trustmap <- trustMapLoad
file <- (</>) file <- (</>)
<$> fromRepo (fromRawFilePath . gitAnnexDir) <$> fromRepo gitAnnexDir
<*> pure "map.dot" <*> pure (literalOsPath "map.dot")
liftIO $ writeFile file (drawMap rs trustmap umap) liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap)
next $ next $
ifM (Annex.getRead Annex.fast) ifM (Annex.getRead Annex.fast)
( runViewer file [] ( runViewer file []
, runViewer file , runViewer file
[ ("xdot", [File file]) [ ("xdot", [File (fromOsPath file)])
, ("dot", [Param "-Tx11", File file]) , ("dot", [Param "-Tx11", File (fromOsPath file)])
] ]
) )
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool runViewer :: OsPath -> [(String, [CommandParam])] -> Annex Bool
runViewer file [] = do runViewer file [] = do
showLongNote $ UnquotedString $ "left map in " ++ file showLongNote $ UnquotedString $ "left map in " ++ fromOsPath file
return True return True
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c) runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
( do ( do
@ -244,7 +244,7 @@ tryScan r
where where
remotecmd = "sh -c " ++ shellEscape remotecmd = "sh -c " ++ shellEscape
(cddir ++ " && " ++ "git config --null --list") (cddir ++ " && " ++ "git config --null --list")
dir = fromRawFilePath $ Git.repoPath r dir = fromOsPath $ Git.repoPath r
cddir cddir
| "/~" `isPrefixOf` dir = | "/~" `isPrefixOf` dir =
let (userhome, reldir) = span (/= '/') (drop 1 dir) let (userhome, reldir) = span (/= '/') (drop 1 dir)

2
Command/MatchExpression.hs
View file

@ -39,7 +39,7 @@ optParser desc = MatchExpressionOptions
<*> (MatchingUserInfo . addkeysize <$> dataparser) <*> (MatchingUserInfo . addkeysize <$> dataparser)
where where
dataparser = UserProvidedInfo dataparser = UserProvidedInfo
<$> optinfo "file" (strOption <$> optinfo "file" ((fmap stringToOsPath . strOption)
( long "file" <> metavar paramFile ( long "file" <> metavar paramFile
<> help "specify filename to match against" <> help "specify filename to match against"
)) ))

8
Command/MetaData.hs
View file

@ -99,7 +99,7 @@ seek o = case batchOption o of
) )
_ -> giveup "--batch is currently only supported in --json mode" _ -> giveup "--batch is currently only supported in --json mode"
start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> OsPath -> Key -> CommandStart
start c o si file k = startKeys c o (si, k, mkActionItem (k, afile)) start c o si file k = startKeys c o (si, k, mkActionItem (k, afile))
where where
afile = AssociatedFile (Just file) afile = AssociatedFile (Just file)
@ -134,7 +134,7 @@ cleanup k = do
unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs) showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs)
parseJSONInput :: String -> Annex (Either String (Either RawFilePath Key, MetaData)) parseJSONInput :: String -> Annex (Either String (Either OsPath Key, MetaData))
parseJSONInput i = case eitherDecode (BU.fromString i) of parseJSONInput i = case eitherDecode (BU.fromString i) of
Left e -> return (Left e) Left e -> return (Left e)
Right v -> do Right v -> do
@ -145,12 +145,12 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of
(Just k, _) -> return $ (Just k, _) -> return $
Right (Right k, m) Right (Right k, m)
(Nothing, Just f) -> do (Nothing, Just f) -> do
f' <- liftIO $ relPathCwdToFile (toRawFilePath f) f' <- liftIO $ relPathCwdToFile f
return $ Right (Left f', m) return $ Right (Left f', m)
(Nothing, Nothing) -> return $ (Nothing, Nothing) -> return $
Left "JSON input is missing either file or key" Left "JSON input is missing either file or key"
startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart startBatch :: (SeekInput, (Either OsPath Key, MetaData)) -> CommandStart
startBatch (si, (i, (MetaData m))) = case i of startBatch (si, (i, (MetaData m))) = case i of
Left f -> do Left f -> do
mk <- lookupKeyStaged f mk <- lookupKeyStaged f

6
Command/Migrate.hs
View file

@ -79,10 +79,10 @@ seekDistributedMigrations incremental =
-- by multiple jobs. -- by multiple jobs.
void $ includeCommandAction $ update oldkey newkey void $ includeCommandAction $ update oldkey newkey
start :: MigrateOptions -> Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart start :: MigrateOptions -> Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
start o ksha si file key = do start o ksha si file key = do
forced <- Annex.getRead Annex.force forced <- Annex.getRead Annex.force
v <- Backend.getBackend (fromRawFilePath file) key v <- Backend.getBackend file key
case v of case v of
Nothing -> stop Nothing -> stop
Just oldbackend -> do Just oldbackend -> do
@ -118,7 +118,7 @@ start o ksha si file key = do
- data cannot get corrupted after the fsck but before the new key is - data cannot get corrupted after the fsck but before the new key is
- generated. - generated.
-} -}
perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform perform :: Bool -> MigrateOptions -> OsPath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform
perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< genkey (fastMigrate oldbackend)
where where
go Nothing = stop go Nothing = stop

55
Command/Multicast.hs
View file

@ -28,7 +28,6 @@ import Utility.Hash
import Utility.Tmp import Utility.Tmp
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Utility.Process.Transcript import Utility.Process.Transcript
import qualified Utility.RawFilePath as R
import Data.Char import Data.Char
import qualified Data.ByteString.Lazy.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as B8
@ -85,9 +84,9 @@ genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ d
(s, ok) <- case k of (s, ok) <- case k of
KeyContainer s -> liftIO $ genkey (Param s) KeyContainer s -> liftIO $ genkey (Param s)
KeyFile f -> do KeyFile f -> do
createAnnexDirectory (toRawFilePath (takeDirectory f)) createAnnexDirectory (takeDirectory f)
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) liftIO $ removeWhenExistsWith removeFile f
liftIO $ protectedOutput $ genkey (File f) liftIO $ protectedOutput $ genkey (File (fromOsPath f))
case (ok, parseFingerprint s) of case (ok, parseFingerprint s) of
(False, _) -> giveup $ "uftp_keymgt failed: " ++ s (False, _) -> giveup $ "uftp_keymgt failed: " ++ s
(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s (_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s
@ -130,19 +129,18 @@ send ups fs = do
-- the names of keys, and would have to be copied, which is too -- the names of keys, and would have to be copied, which is too
-- expensive. -- expensive.
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
withTmpFile (toOsPath "send") $ \t h -> do withTmpFile (literalOsPath "send") $ \t h -> do
let ww = WarnUnmatchLsFiles "multicast" let ww = WarnUnmatchLsFiles "multicast"
(fs', cleanup) <- seekHelper id ww LsFiles.inRepo (fs', cleanup) <- seekHelper id ww LsFiles.inRepo
=<< workTreeItems ww fs =<< workTreeItems ww fs
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $ let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $
liftIO $ hPutStrLn h o liftIO $ hPutStrLn h (fromOsPath o)
forM_ fs' $ \(_, f) -> do forM_ fs' $ \(_, f) -> do
mk <- lookupKey f mk <- lookupKey f
case mk of case mk of
Nothing -> noop Nothing -> noop
Just k -> withObjectLoc k $ Just k -> withObjectLoc k $ addlist f
addlist f . fromRawFilePath
liftIO $ hClose h liftIO $ hClose h
liftIO $ void cleanup liftIO $ void cleanup
@ -161,9 +159,9 @@ send ups fs = do
, Param "-k", uftpKeyParam serverkey , Param "-k", uftpKeyParam serverkey
, Param "-U", Param (uftpUID u) , Param "-U", Param (uftpUID u)
-- only allow clients on the authlist -- only allow clients on the authlist
, Param "-H", Param ("@"++authlist) , Param "-H", Param ("@"++fromOsPath authlist)
-- pass in list of files to send -- pass in list of files to send
, Param "-i", File (fromRawFilePath (fromOsPath t)) , Param "-i", File (fromOsPath t)
] ++ ups ] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult liftIO (boolSystem "uftp" ps) >>= showEndResult
next $ return True next $ return True
@ -178,9 +176,9 @@ receive ups = starting "receiving multicast files" ai si $ do
(callback, environ, statush) <- liftIO multicastCallbackEnv (callback, environ, statush) <- liftIO multicastCallbackEnv
tmpobjdir <- fromRepo gitAnnexTmpObjectDir tmpobjdir <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory tmpobjdir createAnnexDirectory tmpobjdir
withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do withTmpDirIn tmpobjdir (literalOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir) abstmpdir <- liftIO $ absPath tmpdir
abscallback <- liftIO $ searchPath callback abscallback <- liftIO $ searchPath (fromOsPath callback)
let ps = let ps =
-- Avoid it running as a daemon. -- Avoid it running as a daemon.
[ Param "-d" [ Param "-d"
@ -189,42 +187,43 @@ receive ups = starting "receiving multicast files" ai si $ do
, Param "-k", uftpKeyParam clientkey , Param "-k", uftpKeyParam clientkey
, Param "-U", Param (uftpUID u) , Param "-U", Param (uftpUID u)
-- Only allow servers on the authlist -- Only allow servers on the authlist
, Param "-S", Param authlist , Param "-S", Param (fromOsPath authlist)
-- Receive files into tmpdir -- Receive files into tmpdir
-- (it needs an absolute path) -- (it needs an absolute path)
, Param "-D", File (fromRawFilePath abstmpdir) , Param "-D", File (fromOsPath abstmpdir)
-- Run callback after each file received -- Run callback after each file received
-- (it needs an absolute path) -- (it needs an absolute path)
, Param "-s", Param (fromMaybe callback abscallback) , Param "-s", Param (fromOsPath $ fromMaybe callback abscallback)
] ++ ups ] ++ ups
runner <- liftIO $ async $ runner <- liftIO $ async $
hClose statush hClose statush
`after` boolSystemEnv "uftpd" ps (Just environ) `after` boolSystemEnv "uftpd" ps (Just environ)
mapM_ storeReceived . lines =<< liftIO (hGetContents statush) mapM_ storeReceived . map toOsPath . lines
=<< liftIO (hGetContents statush)
showEndResult =<< liftIO (wait runner) showEndResult =<< liftIO (wait runner)
next $ return True next $ return True
where where
ai = ActionItemOther Nothing ai = ActionItemOther Nothing
si = SeekInput [] si = SeekInput []
storeReceived :: FilePath -> Annex () storeReceived :: OsPath -> Annex ()
storeReceived f = do storeReceived f = do
case deserializeKey (takeFileName f) of case deserializeKey' (fromOsPath (takeFileName f)) of
Nothing -> do Nothing -> do
warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file." warning $ "Received a file " <> QuotedPath f <> " that is not a git-annex key. Deleting this file."
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) liftIO $ removeWhenExistsWith removeFile f
Just k -> void $ logStatusAfter NoLiveUpdate k $ Just k -> void $ logStatusAfter NoLiveUpdate k $
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
liftIO $ catchBoolIO $ do liftIO $ catchBoolIO $ do
R.rename (toRawFilePath f) dest renameFile f dest
return True return True
-- Under Windows, uftp uses key containers, which are not files on the -- Under Windows, uftp uses key containers, which are not files on the
-- filesystem. -- filesystem.
data UftpKey = KeyFile FilePath | KeyContainer String data UftpKey = KeyFile OsPath | KeyContainer String
uftpKeyParam :: UftpKey -> CommandParam uftpKeyParam :: UftpKey -> CommandParam
uftpKeyParam (KeyFile f) = File f uftpKeyParam (KeyFile f) = File (fromOsPath f)
uftpKeyParam (KeyContainer s) = Param s uftpKeyParam (KeyContainer s) = Param s
uftpKey :: Annex UftpKey uftpKey :: Annex UftpKey
@ -233,7 +232,7 @@ uftpKey = do
u <- getUUID u <- getUUID
return $ KeyContainer $ "annex-" ++ fromUUID u return $ KeyContainer $ "annex-" ++ fromUUID u
#else #else
uftpKey = KeyFile <$> credsFile "multicast" uftpKey = KeyFile <$> credsFile (literalOsPath "multicast")
#endif #endif
-- uftp needs a unique UID for each client and server, which -- uftp needs a unique UID for each client and server, which
@ -242,13 +241,13 @@ uftpKey = KeyFile <$> credsFile "multicast"
uftpUID :: UUID -> String uftpUID :: UUID -> String
uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u)) uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u))
withAuthList :: (FilePath -> Annex a) -> Annex a withAuthList :: (OsPath -> Annex a) -> Annex a
withAuthList a = do withAuthList a = do
m <- knownFingerPrints m <- knownFingerPrints
withTmpFile (toOsPath "authlist") $ \t h -> do withTmpFile (literalOsPath "authlist") $ \t h -> do
liftIO $ hPutStr h (genAuthList m) liftIO $ hPutStr h (genAuthList m)
liftIO $ hClose h liftIO $ hClose h
a (fromRawFilePath (fromOsPath t)) a t
genAuthList :: M.Map UUID Fingerprint -> String genAuthList :: M.Map UUID Fingerprint -> String
genAuthList = unlines . map fmt . M.toList genAuthList = unlines . map fmt . M.toList

4
Command/PreCommit.hs
View file

@ -62,14 +62,14 @@ addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
addViewMetaData v f k = starting "metadata" ai si $ addViewMetaData v f k = starting "metadata" ai si $
next $ changeMetaData k $ fromView v f next $ changeMetaData k $ fromView v f
where where
ai = mkActionItem (k, toRawFilePath f) ai = mkActionItem (k, f)
si = SeekInput [] si = SeekInput []
removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
removeViewMetaData v f k = starting "metadata" ai si $ removeViewMetaData v f k = starting "metadata" ai si $
next $ changeMetaData k $ unsetMetaData $ fromView v f next $ changeMetaData k $ unsetMetaData $ fromView v f
where where
ai = mkActionItem (k, toRawFilePath f) ai = mkActionItem (k, f)
si = SeekInput [] si = SeekInput []
changeMetaData :: Key -> MetaData -> CommandCleanup changeMetaData :: Key -> MetaData -> CommandCleanup

3
Git/Types.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module Git.Types where module Git.Types where
@ -107,8 +108,10 @@ instance FromConfigValue S.ByteString where
instance FromConfigValue String where instance FromConfigValue String where
fromConfigValue = decodeBS . fromConfigValue fromConfigValue = decodeBS . fromConfigValue
#ifdef WITH_OSPATH
instance FromConfigValue OsPath where instance FromConfigValue OsPath where
fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString) fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString)
#endif
instance Show ConfigValue where instance Show ConfigValue where
show = fromConfigValue show = fromConfigValue

13
Messages/JSON.hs
View file

@ -34,6 +34,7 @@ module Messages.JSON (
import Control.Applicative import Control.Applicative
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Aeson.KeyMap as HM import qualified Data.Aeson.KeyMap as HM
import System.IO import System.IO
@ -84,7 +85,7 @@ start command file key si _ = case j of
j = toJSON' $ JSONActionItem j = toJSON' $ JSONActionItem
{ itemCommand = Just command { itemCommand = Just command
, itemKey = key , itemKey = key
, itemFile = fromOsPath <$> file , itemFile = file
, itemUUID = Nothing , itemUUID = Nothing
, itemFields = Nothing :: Maybe Bool , itemFields = Nothing :: Maybe Bool
, itemSeekInput = si , itemSeekInput = si
@ -98,7 +99,7 @@ startActionItem command ai si _ = case j of
j = toJSON' $ JSONActionItem j = toJSON' $ JSONActionItem
{ itemCommand = Just command { itemCommand = Just command
, itemKey = actionItemKey ai , itemKey = actionItemKey ai
, itemFile = fromOsPath <$> actionItemFile ai , itemFile = actionItemFile ai
, itemUUID = actionItemUUID ai , itemUUID = actionItemUUID ai
, itemFields = Nothing :: Maybe Bool , itemFields = Nothing :: Maybe Bool
, itemSeekInput = si , itemSeekInput = si
@ -206,7 +207,7 @@ instance ToJSON' a => ToJSON' (ObjectMap a) where
data JSONActionItem a = JSONActionItem data JSONActionItem a = JSONActionItem
{ itemCommand :: Maybe String { itemCommand :: Maybe String
, itemKey :: Maybe Key , itemKey :: Maybe Key
, itemFile :: Maybe FilePath , itemFile :: Maybe OsPath
, itemUUID :: Maybe UUID , itemUUID :: Maybe UUID
, itemFields :: Maybe a , itemFields :: Maybe a
, itemSeekInput :: SeekInput , itemSeekInput :: SeekInput
@ -220,7 +221,9 @@ instance ToJSON' a => ToJSON' (JSONActionItem a) where
Just k -> Just $ "key" .= toJSON' k Just k -> Just $ "key" .= toJSON' k
Nothing -> Nothing Nothing -> Nothing
, case itemFile i of , case itemFile i of
Just f -> Just $ "file" .= toJSON' f Just f ->
let f' = (fromOsPath f) :: S.ByteString
in Just $ "file" .= toJSON' f'
Nothing -> Nothing Nothing -> Nothing
, case itemFields i of , case itemFields i of
Just f -> Just $ "fields" .= toJSON' f Just f -> Just $ "fields" .= toJSON' f
@ -235,7 +238,7 @@ instance FromJSON a => FromJSON (JSONActionItem a) where
parseJSON (Object v) = JSONActionItem parseJSON (Object v) = JSONActionItem
<$> (v .:? "command") <$> (v .:? "command")
<*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) <*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))
<*> (v .:? "file") <*> (fmap stringToOsPath <$> (v .:? "file"))
<*> (v .:? "uuid") <*> (v .:? "uuid")
<*> (v .:? "fields") <*> (v .:? "fields")
-- ^ fields is used for metadata, which is currently the -- ^ fields is used for metadata, which is currently the

5
Test/Framework.hs
View file

@ -432,8 +432,9 @@ checklocationlog f expected = do
checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do checkbackend file expected = do
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) let file' = toOsPath file
=<< Annex.WorkTree.lookupKey (toOsPath file) b <- annexeval $ maybe (return Nothing) (Backend.getBackend file')
=<< Annex.WorkTree.lookupKey file'
assertEqual ("backend for " ++ file) (Just expected) b assertEqual ("backend for " ++ file) (Just expected) b
checkispointerfile :: FilePath -> Assertion checkispointerfile :: FilePath -> Assertion

9
Types/UUID.hs
View file

@ -5,7 +5,9 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Types.UUID where module Types.UUID where
@ -20,11 +22,10 @@ import Data.ByteString.Builder
import Control.DeepSeq import Control.DeepSeq
import qualified Data.Semigroup as Sem import qualified Data.Semigroup as Sem
import Common
import Git.Types (ConfigValue(..)) import Git.Types (ConfigValue(..))
import Utility.FileSystemEncoding
import Utility.QuickCheck import Utility.QuickCheck
import Utility.Aeson import Utility.Aeson
import Utility.OsPath
import qualified Utility.SimpleProtocol as Proto import qualified Utility.SimpleProtocol as Proto
-- A UUID is either an arbitrary opaque string, or UUID info may be missing. -- A UUID is either an arbitrary opaque string, or UUID info may be missing.
@ -65,6 +66,7 @@ instance ToUUID SB.ShortByteString where
| SB.null b = NoUUID | SB.null b = NoUUID
| otherwise = UUID (SB.fromShort b) | otherwise = UUID (SB.fromShort b)
#ifdef WITH_OSPATH
-- OsPath is a ShortByteString internally, so this is the most -- OsPath is a ShortByteString internally, so this is the most
-- efficient conversion. -- efficient conversion.
instance FromUUID OsPath where instance FromUUID OsPath where
@ -72,6 +74,7 @@ instance FromUUID OsPath where
instance ToUUID OsPath where instance ToUUID OsPath where
toUUID s = toUUID (fromOsPath s :: SB.ShortByteString) toUUID s = toUUID (fromOsPath s :: SB.ShortByteString)
#endif
instance FromUUID String where instance FromUUID String where
fromUUID s = decodeBS (fromUUID s) fromUUID s = decodeBS (fromUUID s)

11
Utility/OsString.hs
View file

@ -13,7 +13,10 @@
module Utility.OsString ( module Utility.OsString (
module X, module X,
length length,
#ifndef WITH_OSPATH
toChar,
#endif
) where ) where
#ifdef WITH_OSPATH #ifdef WITH_OSPATH
@ -30,4 +33,10 @@ length = B.length . fromOsPath
#else #else
import Data.ByteString as X hiding (length) import Data.ByteString as X hiding (length)
import Data.ByteString (length) import Data.ByteString (length)
import Data.Char
import Data.Word
import Prelude (fromIntegral, (.))
toChar :: Word8 -> Char
toChar = chr . fromIntegral
#endif #endif

10
Utility/SafeOutput.hs
View file

@ -17,6 +17,11 @@ module Utility.SafeOutput (
import Data.Char import Data.Char
import qualified Data.ByteString as S import qualified Data.ByteString as S
#ifdef WITH_OSPATH
import qualified Utility.OsString as OS
import Utility.OsPath
#endif
class SafeOutputtable t where class SafeOutputtable t where
safeOutput :: t -> t safeOutput :: t -> t
@ -26,6 +31,11 @@ instance SafeOutputtable String where
instance SafeOutputtable S.ByteString where instance SafeOutputtable S.ByteString where
safeOutput = S.filter (safeOutputChar . chr . fromIntegral) safeOutput = S.filter (safeOutputChar . chr . fromIntegral)
#ifdef WITH_OSPATH
instance SafeOutputtable OsString where
safeOutput = OS.filter (safeOutputChar . toChar)
#endif
safeOutputChar :: Char -> Bool safeOutputChar :: Char -> Bool
safeOutputChar c safeOutputChar c
| not (isControl c) = True | not (isControl c) = True