more OsPath conversion (602/749)
Sponsored-by: Brock Spratlen
This commit is contained in:
Joey Hess
parent
2d1db7986c
commit
a5d48edd94
25 changed files with 227 additions and 187 deletions
|
|
@ -71,7 +71,7 @@ getAnnexLinkTarget f = getAnnexLinkTarget' f
|
|||
|
||||
{- Pass False to force looking inside file, for when git checks out
|
||||
- symlinks as plain files. -}
|
||||
getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe S.ByteString)
|
||||
getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe LinkTarget)
|
||||
getAnnexLinkTarget' file coresymlinks = if coresymlinks
|
||||
then check probesymlink $
|
||||
return Nothing
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ initMagicMime = return Nothing
|
|||
|
||||
getMagicMime :: Magic -> OsPath -> IO (Maybe (MimeType, MimeEncoding))
|
||||
#ifdef WITH_MAGICMIME
|
||||
getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f)
|
||||
getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m (fromOsPath f))
|
||||
where
|
||||
parse s =
|
||||
let (mimetype, rest) = separate (== ';') s
|
||||
|
|
|
|||
|
|
@ -63,11 +63,11 @@ genKey source meterupdate b = case B.genKey b of
|
|||
Nothing -> giveup $ "Cannot generate a key for backend " ++
|
||||
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
|
||||
Just backend -> return $ Just backend
|
||||
Nothing -> do
|
||||
warning $ "skipping " <> QuotedPath (toOsPath file) <> " (" <>
|
||||
warning $ "skipping " <> QuotedPath file <> " (" <>
|
||||
UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")"
|
||||
return Nothing
|
||||
|
||||
|
|
|
|||
|
|
@ -44,25 +44,27 @@ seek ps = unlessM crippledFileSystem $
|
|||
|
||||
data FixWhat = FixSymlinks | FixAll
|
||||
|
||||
start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start :: FixWhat -> SeekInput -> OsPath -> Key -> CommandStart
|
||||
start fixwhat si file key = do
|
||||
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file
|
||||
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file'
|
||||
wantlink <- calcRepo $ gitAnnexLink file key
|
||||
case currlink of
|
||||
Just l
|
||||
| l /= wantlink -> fixby $ fixSymlink file wantlink
|
||||
| l /= fromOsPath wantlink ->
|
||||
fixby $ fixSymlink file wantlink
|
||||
| otherwise -> stop
|
||||
Nothing -> case fixwhat of
|
||||
FixAll -> fixthin
|
||||
FixSymlinks -> stop
|
||||
where
|
||||
file' = fromOsPath file
|
||||
fixby = starting "fix" (mkActionItem (key, file)) si
|
||||
fixthin = do
|
||||
obj <- calcRepo (gitAnnexLocation key)
|
||||
stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
|
||||
thin <- annexThin <$> Annex.getGitConfig
|
||||
fs <- liftIO $ catchMaybeIO $ R.getFileStatus file
|
||||
os <- liftIO $ catchMaybeIO $ R.getFileStatus obj
|
||||
fs <- liftIO $ catchMaybeIO $ R.getFileStatus file'
|
||||
os <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath obj)
|
||||
case (linkCount <$> fs, linkCount <$> os, thin) of
|
||||
(Just 1, Just 1, True) ->
|
||||
fixby $ makeHardLink file key
|
||||
|
|
@ -70,10 +72,10 @@ start fixwhat si file key = do
|
|||
fixby $ breakHardLink file key obj
|
||||
_ -> stop
|
||||
|
||||
breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
|
||||
breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform
|
||||
breakHardLink file key obj = 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) $
|
||||
giveup "unable to break hard link"
|
||||
thawContent tmp
|
||||
|
|
@ -81,26 +83,30 @@ breakHardLink file key obj = do
|
|||
modifyContentDir obj $ freezeContent obj
|
||||
next $ return True
|
||||
|
||||
makeHardLink :: RawFilePath -> Key -> CommandPerform
|
||||
makeHardLink :: OsPath -> Key -> CommandPerform
|
||||
makeHardLink file key = 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
|
||||
LinkAnnexFailed -> giveup "unable to make hard link"
|
||||
_ -> noop
|
||||
next $ return True
|
||||
|
||||
fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform
|
||||
fixSymlink :: OsPath -> OsPath -> CommandPerform
|
||||
fixSymlink file link = do
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
-- preserve mtime of symlink
|
||||
mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
|
||||
<$> R.getSymbolicLinkStatus file
|
||||
<$> R.getSymbolicLinkStatus (fromOsPath file)
|
||||
#endif
|
||||
replaceWorkTreeFile file $ \tmpfile -> do
|
||||
liftIO $ R.createSymbolicLink link tmpfile
|
||||
let tmpfile' = fromOsPath tmpfile
|
||||
liftIO $ R.createSymbolicLink link' tmpfile'
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
liftIO $ maybe noop (\t -> touch tmpfile t False) mtime
|
||||
liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime
|
||||
#endif
|
||||
stageSymlink file =<< hashSymlink link
|
||||
stageSymlink file =<< hashSymlink link'
|
||||
next $ return True
|
||||
where
|
||||
link' = fromOsPath link
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ seekBatch matcher fmt = batchInput fmt parse (commandAction . go)
|
|||
let (keyname, file) = separate (== ' ') s
|
||||
if not (null keyname) && not (null file)
|
||||
then do
|
||||
file' <- liftIO $ relPathCwdToFile (toRawFilePath file)
|
||||
file' <- liftIO $ relPathCwdToFile (toOsPath file)
|
||||
return $ Right (file', keyOpt keyname)
|
||||
else return $
|
||||
Left "Expected pairs of key and filename"
|
||||
|
|
@ -75,11 +75,10 @@ start matcher force (si, (keyname, file)) = do
|
|||
inbackend <- inAnnex key
|
||||
unless inbackend $ giveup $
|
||||
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
|
||||
let file' = toOsPath file
|
||||
let ai = mkActionItem (key, file')
|
||||
starting "fromkey" ai si $
|
||||
perform matcher key file'
|
||||
where
|
||||
file' = toRawFilePath file
|
||||
|
||||
-- From user input to a Key.
|
||||
-- User can input either a serialized key, or an url.
|
||||
|
|
@ -99,9 +98,9 @@ keyOpt' s = case parseURIPortable s of
|
|||
Just k -> Right k
|
||||
Nothing -> Left $ "bad key/url " ++ s
|
||||
|
||||
perform :: AddUnlockedMatcher -> Key -> RawFilePath -> CommandPerform
|
||||
perform :: AddUnlockedMatcher -> Key -> OsPath -> CommandPerform
|
||||
perform matcher key file = lookupKeyNotHidden file >>= \case
|
||||
Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file))
|
||||
Nothing -> ifM (liftIO $ doesFileExist file)
|
||||
( hasothercontent
|
||||
, do
|
||||
contentpresent <- inAnnex key
|
||||
|
|
@ -123,7 +122,7 @@ perform matcher key file = lookupKeyNotHidden file >>= \case
|
|||
else writepointer
|
||||
, do
|
||||
link <- calcRepo $ gitAnnexLink file key
|
||||
addAnnexLink link file
|
||||
addAnnexLink (fromOsPath link) file
|
||||
)
|
||||
next $ return True
|
||||
)
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@ import System.Posix.Types (EpochTime)
|
|||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import Data.Either
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime)
|
||||
|
||||
cmd :: Command
|
||||
|
|
@ -123,8 +122,8 @@ checkDeadRepo u =
|
|||
whenM ((==) DeadTrusted <$> lookupTrust u) $
|
||||
earlyWarning "Warning: Fscking a repository that is currently marked as dead."
|
||||
|
||||
start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case
|
||||
start :: Maybe Remote -> Incremental -> SeekInput -> OsPath -> Key -> CommandStart
|
||||
start from inc si file key = Backend.getBackend file key >>= \case
|
||||
Nothing -> stop
|
||||
Just backend -> do
|
||||
(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
|
||||
afile = AssociatedFile (Just file)
|
||||
|
||||
perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool
|
||||
perform :: Key -> OsPath -> Backend -> NumCopies -> Annex Bool
|
||||
perform key file backend numcopies = do
|
||||
keystatus <- getKeyFileStatus key file
|
||||
check
|
||||
|
|
@ -194,11 +193,11 @@ performRemote key afile numcopies remote =
|
|||
pid <- liftIO getPID
|
||||
t <- fromRepo gitAnnexTmpObjectDir
|
||||
createAnnexDirectory t
|
||||
let tmp = t P.</> "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key
|
||||
let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop)
|
||||
let tmp = t </> literalOsPath "fsck" <> toOsPath (show pid) <> literalOsPath "." <> keyFile key
|
||||
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
|
||||
cleanup
|
||||
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)
|
||||
( return (Just (Right UnVerified))
|
||||
, ifM (Annex.getRead Annex.fast)
|
||||
|
|
@ -208,9 +207,9 @@ performRemote key afile numcopies remote =
|
|||
)
|
||||
, 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
|
||||
Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp))
|
||||
Just a -> isRight <$> tryNonAsync (a key afile tmp)
|
||||
Nothing -> return False
|
||||
|
||||
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart
|
||||
|
|
@ -236,10 +235,10 @@ check :: [Annex Bool] -> Annex Bool
|
|||
check cs = and <$> sequence cs
|
||||
|
||||
{- Checks that symlinks points correctly to the annexed content. -}
|
||||
fixLink :: Key -> RawFilePath -> Annex Bool
|
||||
fixLink :: Key -> OsPath -> Annex Bool
|
||||
fixLink key file = do
|
||||
want <- calcRepo $ gitAnnexLink file key
|
||||
have <- getAnnexLinkTarget file
|
||||
have <- fmap toOsPath <$> getAnnexLinkTarget file
|
||||
maybe noop (go want) have
|
||||
return True
|
||||
where
|
||||
|
|
@ -247,8 +246,8 @@ fixLink key file = do
|
|||
| want /= fromInternalGitPath have = do
|
||||
showNote "fixing link"
|
||||
createWorkTreeDirectory (parentDir file)
|
||||
liftIO $ R.removeLink file
|
||||
addAnnexLink want file
|
||||
liftIO $ R.removeLink (fromOsPath file)
|
||||
addAnnexLink (fromOsPath want) file
|
||||
| otherwise = noop
|
||||
|
||||
{- 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)
|
||||
if loc == idealloc
|
||||
then return True
|
||||
else ifM (liftIO $ R.doesPathExist loc)
|
||||
else ifM (liftIO $ R.doesPathExist $ fromOsPath loc)
|
||||
( moveobjdir loc idealloc
|
||||
`catchNonAsync` \_e -> return True
|
||||
, return True
|
||||
|
|
@ -291,14 +290,12 @@ fixObjectLocation key = do
|
|||
-- Thaw the content directory to allow renaming it.
|
||||
thawContentDir src
|
||||
createAnnexDirectory (parentDir destdir)
|
||||
liftIO $ renameDirectory
|
||||
(fromRawFilePath srcdir)
|
||||
(fromRawFilePath destdir)
|
||||
liftIO $ renameDirectory srcdir destdir
|
||||
-- Since the directory was moved, lockContentForRemoval
|
||||
-- will not be able to remove the lock file it
|
||||
-- made. So, remove the lock file here.
|
||||
mlockfile <- contentLockFile key =<< getVersion
|
||||
liftIO $ maybe noop (removeWhenExistsWith R.removeLink) mlockfile
|
||||
liftIO $ maybe noop (removeWhenExistsWith removeFile) mlockfile
|
||||
freezeContentDir dest
|
||||
cleanObjectDirs src
|
||||
return True
|
||||
|
|
@ -310,7 +307,7 @@ verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool
|
|||
verifyLocationLog key keystatus ai = do
|
||||
obj <- calcRepo (gitAnnexLocation key)
|
||||
present <- if isKeyUnlockedThin keystatus
|
||||
then liftIO (doesFileExist (fromRawFilePath obj))
|
||||
then liftIO (doesFileExist obj)
|
||||
else inAnnex key
|
||||
u <- getUUID
|
||||
|
||||
|
|
@ -324,7 +321,7 @@ verifyLocationLog key keystatus ai = do
|
|||
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"
|
||||
_ -> return ()
|
||||
whenM (liftIO $ R.doesPathExist $ parentDir obj) $
|
||||
whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
|
||||
freezeContentDir obj
|
||||
|
||||
{- 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
|
||||
|
||||
{- Verifies the associated file records. -}
|
||||
verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool
|
||||
verifyAssociatedFiles :: Key -> KeyStatus -> OsPath -> Annex Bool
|
||||
verifyAssociatedFiles key keystatus file = do
|
||||
when (isKeyUnlockedThin keystatus) $ do
|
||||
f <- inRepo $ toTopFilePath file
|
||||
|
|
@ -410,7 +407,7 @@ verifyAssociatedFiles key keystatus file = do
|
|||
Database.Keys.addAssociatedFile key f
|
||||
return True
|
||||
|
||||
verifyWorkTree :: Key -> RawFilePath -> Annex Bool
|
||||
verifyWorkTree :: Key -> OsPath -> Annex Bool
|
||||
verifyWorkTree key file = do
|
||||
{- Make sure that a pointer file is replaced with its content,
|
||||
- when the content is available. -}
|
||||
|
|
@ -419,7 +416,9 @@ verifyWorkTree key file = do
|
|||
Just k | k == key -> whenM (inAnnex key) $ do
|
||||
showNote "fixing worktree content"
|
||||
replaceWorkTreeFile file $ \tmp -> do
|
||||
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
|
||||
mode <- liftIO $ catchMaybeIO $
|
||||
fileMode <$> R.getFileStatus
|
||||
(fromOsPath file)
|
||||
ifM (annexThin <$> Annex.getGitConfig)
|
||||
( void $ linkFromAnnex' key tmp mode
|
||||
, do
|
||||
|
|
@ -440,20 +439,20 @@ checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool
|
|||
checkKeySize _ KeyUnlockedThin _ = return True
|
||||
checkKeySize key _ ai = do
|
||||
file <- calcRepo $ gitAnnexLocation key
|
||||
ifM (liftIO $ R.doesPathExist file)
|
||||
ifM (liftIO $ R.doesPathExist (fromOsPath file))
|
||||
( checkKeySizeOr badContent key file ai
|
||||
, return True
|
||||
)
|
||||
|
||||
withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool
|
||||
withLocalCopy :: Maybe OsPath -> (OsPath -> Annex Bool) -> Annex Bool
|
||||
withLocalCopy Nothing _ = return True
|
||||
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 =
|
||||
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
|
||||
Nothing -> return True
|
||||
Just size -> do
|
||||
|
|
@ -505,7 +504,7 @@ checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
|
|||
checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool
|
||||
checkBackend key keystatus afile = do
|
||||
content <- calcRepo (gitAnnexLocation key)
|
||||
ifM (liftIO $ R.doesPathExist content)
|
||||
ifM (liftIO $ R.doesPathExist (fromOsPath content))
|
||||
( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
|
||||
( nocheck
|
||||
, do
|
||||
|
|
@ -524,11 +523,11 @@ checkBackend key keystatus afile = do
|
|||
|
||||
ai = mkActionItem (key, afile)
|
||||
|
||||
checkBackendRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool
|
||||
checkBackendRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool
|
||||
checkBackendRemote key remote ai localcopy =
|
||||
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 =
|
||||
ifM (Annex.getRead Annex.fast)
|
||||
( return True
|
||||
|
|
@ -552,7 +551,7 @@ checkBackendOr bad key file ai =
|
|||
- verified to be correct. The InodeCache is generated again to detect if
|
||||
- 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
|
||||
Nothing -> noop
|
||||
Just ic -> do
|
||||
|
|
@ -569,7 +568,7 @@ checkInodeCache key content mic ai = case mic of
|
|||
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
|
||||
checkKeyNumCopies key afile numcopies = do
|
||||
let (desc, hasafile) = case afile of
|
||||
AssociatedFile Nothing -> (serializeKey' key, False)
|
||||
AssociatedFile Nothing -> (toOsPath (serializeKey'' key), False)
|
||||
AssociatedFile (Just af) -> (af, True)
|
||||
locs <- loggedLocations key
|
||||
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
|
||||
|
|
@ -590,7 +589,7 @@ checkKeyNumCopies key afile numcopies = do
|
|||
)
|
||||
else return True
|
||||
|
||||
missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
|
||||
missingNote :: OsPath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
|
||||
missingNote file 0 _ [] dead =
|
||||
"** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead)
|
||||
missingNote file 0 _ untrusted dead =
|
||||
|
|
@ -615,25 +614,24 @@ honorDead dead
|
|||
badContent :: Key -> Annex String
|
||||
badContent key = do
|
||||
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
|
||||
- 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,
|
||||
- that temp file is moved to the bad content directory unless
|
||||
- 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
|
||||
bad <- fromRepo gitAnnexBadDir
|
||||
let destbad = bad P.</> keyFile key
|
||||
let destbad' = fromRawFilePath destbad
|
||||
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad'))
|
||||
let destbad = bad </> keyFile key
|
||||
movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad))
|
||||
( return False
|
||||
, do
|
||||
createAnnexDirectory (parentDir destbad)
|
||||
liftIO $ catchDefaultIO False $
|
||||
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy)
|
||||
( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad'
|
||||
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath localcopy))
|
||||
( copyFileExternal CopyTimeStamps localcopy destbad
|
||||
, do
|
||||
moveFile localcopy destbad
|
||||
return True
|
||||
|
|
@ -645,7 +643,7 @@ badContentRemote remote localcopy key = do
|
|||
Remote.logStatus NoLiveUpdate remote key InfoMissing
|
||||
return $ case (movedbad, dropped) of
|
||||
(True, Right ()) -> "moved from " ++ Remote.name remote ++
|
||||
" to " ++ fromRawFilePath destbad
|
||||
" to " ++ fromOsPath destbad
|
||||
(False, Right ()) -> "dropped from " ++ Remote.name remote
|
||||
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
|
||||
|
||||
|
|
@ -678,10 +676,10 @@ recordStartTime :: UUID -> Annex ()
|
|||
recordStartTime u = do
|
||||
f <- fromRepo (gitAnnexFsckState u)
|
||||
createAnnexDirectory $ parentDir f
|
||||
liftIO $ removeWhenExistsWith R.removeLink f
|
||||
liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do
|
||||
liftIO $ removeWhenExistsWith removeFile f
|
||||
liftIO $ F.withFile f WriteMode $ \h -> do
|
||||
#ifndef mingw32_HOST_OS
|
||||
t <- modificationTime <$> R.getFileStatus f
|
||||
t <- modificationTime <$> R.getFileStatus (fromOsPath f)
|
||||
#else
|
||||
t <- getPOSIXTime
|
||||
#endif
|
||||
|
|
@ -692,7 +690,7 @@ recordStartTime u = do
|
|||
showTime = show
|
||||
|
||||
resetStartTime :: UUID -> Annex ()
|
||||
resetStartTime u = liftIO . removeWhenExistsWith R.removeLink
|
||||
resetStartTime u = liftIO . removeWhenExistsWith removeFile
|
||||
=<< fromRepo (gitAnnexFsckState u)
|
||||
|
||||
{- Gets the incremental fsck start time. -}
|
||||
|
|
@ -700,9 +698,9 @@ getStartTime :: UUID -> Annex (Maybe EpochTime)
|
|||
getStartTime u = do
|
||||
f <- fromRepo (gitAnnexFsckState u)
|
||||
liftIO $ catchDefaultIO Nothing $ do
|
||||
timestamp <- modificationTime <$> R.getFileStatus f
|
||||
timestamp <- modificationTime <$> R.getFileStatus (fromOsPath f)
|
||||
let fromstatus = Just (realToFrac timestamp)
|
||||
fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f)
|
||||
fromfile <- parsePOSIXTime <$> F.readFile' f
|
||||
return $ if matchingtimestamp fromfile fromstatus
|
||||
then Just timestamp
|
||||
else Nothing
|
||||
|
|
|
|||
|
|
@ -123,13 +123,14 @@ instance ToFilePath FuzzDir where
|
|||
toFilePath (FuzzDir d) = d
|
||||
|
||||
isFuzzFile :: FilePath -> Bool
|
||||
isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f
|
||||
isFuzzFile f = "fuzzfile_" `isPrefixOf` fromOsPath (takeFileName (toOsPath f))
|
||||
|
||||
isFuzzDir :: FilePath -> Bool
|
||||
isFuzzDir d = "fuzzdir_" `isPrefixOf` d
|
||||
|
||||
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 n = FuzzDir $ "fuzzdir_" ++ show n
|
||||
|
|
@ -175,15 +176,15 @@ instance Arbitrary FuzzAction where
|
|||
|
||||
runFuzzAction :: FuzzAction -> Annex ()
|
||||
runFuzzAction (FuzzAdd (FuzzFile f)) = do
|
||||
createWorkTreeDirectory (parentDir (toRawFilePath f))
|
||||
createWorkTreeDirectory (parentDir (toOsPath f))
|
||||
n <- liftIO (getStdRandom random :: IO Int)
|
||||
liftIO $ writeFile f $ show n ++ "\n"
|
||||
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $
|
||||
removeWhenExistsWith R.removeLink (toRawFilePath f)
|
||||
removeWhenExistsWith removeFile (toOsPath f)
|
||||
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
|
||||
R.rename (toRawFilePath src) (toRawFilePath dest)
|
||||
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
|
||||
removeDirectoryRecursive d
|
||||
removeDirectoryRecursive (toOsPath d)
|
||||
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
|
||||
R.rename (toRawFilePath src) (toRawFilePath dest)
|
||||
runFuzzAction (FuzzPause d) = randomDelay d
|
||||
|
|
@ -210,7 +211,7 @@ genFuzzAction = do
|
|||
case md of
|
||||
Nothing -> genFuzzAction
|
||||
Just d -> do
|
||||
newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d)
|
||||
newd <- liftIO $ newDir (parentDir $ toOsPath $ toFilePath d)
|
||||
maybe genFuzzAction (return . FuzzMoveDir d) newd
|
||||
FuzzDeleteDir _ -> do
|
||||
d <- liftIO existingDir
|
||||
|
|
@ -221,7 +222,8 @@ existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
|
|||
existingFile 0 _ = return Nothing
|
||||
existingFile n top = do
|
||||
dir <- existingDirIncludingTop
|
||||
contents <- catchDefaultIO [] (getDirectoryContents dir)
|
||||
contents <- map fromOsPath
|
||||
<$> catchDefaultIO [] (getDirectoryContents (toOsPath dir))
|
||||
let files = filter isFuzzFile contents
|
||||
if null files
|
||||
then do
|
||||
|
|
@ -230,19 +232,21 @@ existingFile n top = do
|
|||
then return Nothing
|
||||
else do
|
||||
i <- getStdRandom $ randomR (0, length dirs - 1)
|
||||
existingFile (n - 1) (top </> dirs !! i)
|
||||
existingFile (n - 1) (fromOsPath (toOsPath top </> toOsPath (dirs !! i)))
|
||||
else do
|
||||
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 = do
|
||||
dirs <- filter isFuzzDir <$> getDirectoryContents "."
|
||||
dirs <- filter (isFuzzDir . fromOsPath)
|
||||
<$> getDirectoryContents (literalOsPath ".")
|
||||
if null dirs
|
||||
then return "."
|
||||
else do
|
||||
n <- getStdRandom $ randomR (0, length dirs)
|
||||
return $ ("." : dirs) !! n
|
||||
return $ fromOsPath $ (literalOsPath "." : dirs) !! n
|
||||
|
||||
existingDir :: IO (Maybe FuzzDir)
|
||||
existingDir = do
|
||||
|
|
@ -257,21 +261,21 @@ newFile = go (100 :: Int)
|
|||
go 0 = return Nothing
|
||||
go n = do
|
||||
f <- genFuzzFile
|
||||
ifM (doesnotexist (toFilePath f))
|
||||
ifM (doesnotexist (toOsPath (toFilePath f)))
|
||||
( return $ Just f
|
||||
, go (n - 1)
|
||||
)
|
||||
|
||||
newDir :: RawFilePath -> IO (Maybe FuzzDir)
|
||||
newDir :: OsPath -> IO (Maybe FuzzDir)
|
||||
newDir parent = go (100 :: Int)
|
||||
where
|
||||
go 0 = return Nothing
|
||||
go n = do
|
||||
(FuzzDir d) <- genFuzzDir
|
||||
ifM (doesnotexist (fromRawFilePath parent </> d))
|
||||
ifM (doesnotexist (parent </> toOsPath d))
|
||||
( return $ Just $ FuzzDir d
|
||||
, go (n - 1)
|
||||
)
|
||||
|
||||
doesnotexist :: FilePath -> IO Bool
|
||||
doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f))
|
||||
doesnotexist :: OsPath -> IO Bool
|
||||
doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ import "mtl" Control.Monad.State.Strict
|
|||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Vector as V
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import Data.ByteString.Short (fromShort)
|
||||
import System.PosixCompat.Files (isDirectory)
|
||||
import Data.Ord
|
||||
import qualified Data.Semigroup as Sem
|
||||
|
|
@ -188,9 +188,9 @@ itemInfo o (si, p) = ifM (isdir (toRawFilePath p))
|
|||
Right r -> remoteInfo o r si
|
||||
Left _ -> Remote.nameToUUID' p >>= \case
|
||||
([], _) -> do
|
||||
relp <- liftIO $ relPathCwdToFile (toRawFilePath p)
|
||||
relp <- liftIO $ relPathCwdToFile (toOsPath p)
|
||||
lookupKey relp >>= \case
|
||||
Just k -> fileInfo o (fromRawFilePath relp) si k
|
||||
Just k -> fileInfo o (fromOsPath relp) si k
|
||||
Nothing -> treeishInfo o p si
|
||||
([u], _) -> uuidInfo o u si
|
||||
(_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,
|
||||
-- rather than ActionItemOther to avoid breaking back-compat of
|
||||
-- json output.
|
||||
let ai = ActionItemTreeFile (toRawFilePath s)
|
||||
let ai = ActionItemTreeFile (toOsPath s)
|
||||
showStartMessage (StartMessage "info" ai si)
|
||||
showNote (UnquotedString msg)
|
||||
showEndFail
|
||||
|
|
@ -237,7 +237,7 @@ treeishInfo o t si = do
|
|||
fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()
|
||||
fileInfo o file si k = do
|
||||
matcher <- Limit.getMatcher
|
||||
let file' = toRawFilePath file
|
||||
let file' = toOsPath file
|
||||
whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $
|
||||
showCustom (unwords ["info", file]) si $ do
|
||||
evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)
|
||||
|
|
@ -502,17 +502,17 @@ transfer_list = stat desc $ nojson $ lift $ do
|
|||
where
|
||||
desc = "transfers in progress"
|
||||
line qp uuidmap t i = unwords
|
||||
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
|
||||
, fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem
|
||||
[ decodeBS $ fromShort (formatDirection (transferDirection t)) <> "ing"
|
||||
, decodeBS $ quote qp $ actionItemDesc $ mkActionItem
|
||||
(transferKey t, associatedFile i)
|
||||
, if transferDirection t == Upload then "to" else "from"
|
||||
, maybe (fromUUID $ transferUUID t) Remote.name $
|
||||
M.lookup (transferUUID t) uuidmap
|
||||
]
|
||||
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))
|
||||
, ("file", toJSON' (fromRawFilePath <$> afile))
|
||||
, ("file", toJSON' ((fromOsPath <$> afile) :: Maybe FilePath))
|
||||
, ("remote", toJSON' (fromUUID (transferUUID t) :: String))
|
||||
]
|
||||
where
|
||||
|
|
@ -522,7 +522,7 @@ disk_size :: Stat
|
|||
disk_size = simpleStat "available local disk space" $
|
||||
calcfree
|
||||
<$> (lift $ annexDiskReserve <$> Annex.getGitConfig)
|
||||
<*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir)
|
||||
<*> (lift $ inRepo $ getDiskFree . fromOsPath . gitAnnexDir)
|
||||
<*> mkSizer
|
||||
where
|
||||
calcfree reserve (Just have) sizer = unwords
|
||||
|
|
@ -700,7 +700,7 @@ getDirStatInfo o dir = do
|
|||
fast <- Annex.getRead Annex.fast
|
||||
matcher <- Limit.getMatcher
|
||||
(presentdata, referenceddata, numcopiesstats, repodata) <-
|
||||
Command.Unused.withKeysFilesReferencedIn dir initial
|
||||
Command.Unused.withKeysFilesReferencedIn (toOsPath dir) initial
|
||||
(update matcher fast)
|
||||
return $ StatInfo
|
||||
(Just presentdata)
|
||||
|
|
@ -797,7 +797,7 @@ updateRepoData key locs m = m'
|
|||
M.fromList $ zip locs (map update locs)
|
||||
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
|
||||
have <- trustExclude UnTrusted locs
|
||||
!variance <- Variance <$> numCopiesCheck' file (-) have
|
||||
|
|
@ -817,7 +817,7 @@ showSizeKeys d = do
|
|||
"+ " ++ show (unknownSizeKeys d) ++
|
||||
" unknown size"
|
||||
|
||||
staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat
|
||||
staleSize :: String -> (Git.Repo -> OsPath) -> Stat
|
||||
staleSize label dirspec = go =<< lift (dirKeys dirspec)
|
||||
where
|
||||
go [] = nostat
|
||||
|
|
@ -830,7 +830,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec)
|
|||
keysizes keys = do
|
||||
dir <- lift $ fromRepo dirspec
|
||||
liftIO $ forM keys $ \k ->
|
||||
catchDefaultIO 0 $ getFileSize (dir P.</> keyFile k)
|
||||
catchDefaultIO 0 $ getFileSize (dir </> keyFile k)
|
||||
|
||||
aside :: String -> String
|
||||
aside s = " (" ++ s ++ ")"
|
||||
|
|
|
|||
|
|
@ -51,14 +51,17 @@ seek o = do
|
|||
where
|
||||
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
|
||||
| S.member k s = start' isterminal k
|
||||
| otherwise = stop
|
||||
|
||||
start' :: IsTerminal -> Key -> CommandStart
|
||||
start' (IsTerminal isterminal) k = startingCustomOutput k $ do
|
||||
tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k)
|
||||
tmpf <- fromRepo (gitAnnexTmpObjectLocation k)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ getList o
|
|||
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
|
||||
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
|
||||
ls <- S.fromList <$> keyLocations key
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
|
|
@ -100,7 +100,7 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length
|
|||
trust UnTrusted = " (untrusted)"
|
||||
trust _ = ""
|
||||
|
||||
format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath
|
||||
format :: [(TrustLevel, Present)] -> OsPath -> StringContainingQuotedPath
|
||||
format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file
|
||||
where
|
||||
thereMap = concatMap there remotes
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
|
|||
, usesLocationLog = False
|
||||
}
|
||||
|
||||
start :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start :: SeekInput -> OsPath -> Key -> CommandStart
|
||||
start si file key = ifM (isJust <$> isAnnexLink file)
|
||||
( stop
|
||||
, starting "lock" (mkActionItem (key, file)) si $
|
||||
|
|
@ -59,7 +59,7 @@ start si file key = ifM (isJust <$> isAnnexLink file)
|
|||
)
|
||||
cont = perform file key
|
||||
|
||||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
perform :: OsPath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
lockdown =<< calcRepo (gitAnnexLocation key)
|
||||
addSymlink file key =<< withTSDelta (liftIO . genInodeCache file)
|
||||
|
|
@ -70,12 +70,14 @@ perform file key = do
|
|||
( breakhardlink obj
|
||||
, repopulate obj
|
||||
)
|
||||
whenM (liftIO $ R.doesPathExist obj) $
|
||||
whenM (liftIO $ doesFileExist 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
|
||||
-- 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)
|
||||
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
|
||||
modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do
|
||||
|
|
@ -89,7 +91,7 @@ perform file key = do
|
|||
fs <- map (`fromTopFilePath` g)
|
||||
<$> Database.Keys.getAssociatedFiles key
|
||||
mfile <- firstM (isUnmodified key) fs
|
||||
liftIO $ removeWhenExistsWith R.removeLink obj
|
||||
liftIO $ removeWhenExistsWith removeFile obj
|
||||
case mfile of
|
||||
Just unmodified ->
|
||||
ifM (checkedCopyFile key unmodified obj Nothing)
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ import Data.Char
|
|||
import Data.Time.Clock.POSIX
|
||||
import Data.Time
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import Control.Concurrent.Async
|
||||
|
||||
import Command
|
||||
|
|
@ -34,6 +33,7 @@ import Git.CatFile
|
|||
import Types.TrustLevel
|
||||
import Utility.DataUnits
|
||||
import Utility.HumanTime
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
data LogChange = Added | Removed
|
||||
|
||||
|
|
@ -282,15 +282,15 @@ getKeyLog key os = do
|
|||
top <- fromRepo Git.repoPath
|
||||
p <- liftIO $ relPathCwdToFile top
|
||||
config <- Annex.getGitConfig
|
||||
let logfile = p P.</> locationLogFile config key
|
||||
getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os)
|
||||
let logfile = p </> locationLogFile config key
|
||||
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
|
||||
config <- Annex.getGitConfig
|
||||
let fileselector = \_sha f ->
|
||||
locationLogFileKey config (toRawFilePath f)
|
||||
inRepo $ getGitLog Annex.Branch.fullname Nothing fs os fileselector
|
||||
locationLogFileKey config f
|
||||
inRepo $ getGitLog Annex.Branch.fullname Nothing (map fromOsPath fs) os fileselector
|
||||
|
||||
showTimeStamp :: TimeZone -> String -> POSIXTime -> String
|
||||
showTimeStamp zone format = formatTime defaultTimeLocale format
|
||||
|
|
@ -320,11 +320,11 @@ sizeHistoryInfo mu o = do
|
|||
-- and to the trust log.
|
||||
getlog = do
|
||||
config <- Annex.getGitConfig
|
||||
let fileselector = \_sha f -> let f' = toRawFilePath f in
|
||||
case locationLogFileKey config f' of
|
||||
let fileselector = \_sha f ->
|
||||
case locationLogFileKey config f of
|
||||
Just k -> Just (Right k)
|
||||
Nothing
|
||||
| f' == trustLog -> Just (Left ())
|
||||
| f == trustLog -> Just (Left ())
|
||||
| otherwise -> Nothing
|
||||
inRepo $ getGitLog Annex.Branch.fullname Nothing []
|
||||
[ Param "--date-order"
|
||||
|
|
@ -409,10 +409,10 @@ sizeHistoryInfo mu o = do
|
|||
displaystart uuidmap zone
|
||||
| gnuplotOption o = do
|
||||
file <- (</>)
|
||||
<$> fromRepo (fromRawFilePath . gitAnnexDir)
|
||||
<*> pure "gnuplot"
|
||||
liftIO $ putStrLn $ "Generating gnuplot script in " ++ file
|
||||
h <- liftIO $ openFile file WriteMode
|
||||
<$> fromRepo gitAnnexDir
|
||||
<*> pure (literalOsPath "gnuplot")
|
||||
liftIO $ putStrLn $ "Generating gnuplot script in " ++ fromOsPath file
|
||||
h <- liftIO $ F.openFile file WriteMode
|
||||
liftIO $ mapM_ (hPutStrLn h)
|
||||
[ "set datafile separator ','"
|
||||
, "set timefmt \"%Y-%m-%dT%H:%M:%S\""
|
||||
|
|
@ -442,7 +442,7 @@ sizeHistoryInfo mu o = do
|
|||
hFlush h
|
||||
putStrLn $ "Running gnuplot..."
|
||||
void $ liftIO $ boolSystem "gnuplot"
|
||||
[Param "-p", File file]
|
||||
[Param "-p", File (fromOsPath file)]
|
||||
return (dispst h endaction)
|
||||
| sizesOption o = do
|
||||
liftIO $ putStrLn uuidmapheader
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ run o _ file
|
|||
| refOption o = catKey (Ref (toRawFilePath file)) >>= display
|
||||
| otherwise = do
|
||||
checkNotBareRepo
|
||||
seekSingleGitFile file >>= \case
|
||||
seekSingleGitFile (toOsPath file) >>= \case
|
||||
Nothing -> return False
|
||||
Just file' -> catKeyFile file' >>= display
|
||||
|
||||
|
|
@ -51,13 +51,13 @@ display Nothing = return False
|
|||
|
||||
-- To support absolute filenames, pass through git ls-files.
|
||||
-- But, this plumbing command does not recurse through directories.
|
||||
seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath)
|
||||
seekSingleGitFile :: OsPath -> Annex (Maybe OsPath)
|
||||
seekSingleGitFile file
|
||||
| isRelative file = return (Just (toRawFilePath file))
|
||||
| isRelative file = return (Just file)
|
||||
| otherwise = do
|
||||
(l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file])
|
||||
(l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [file])
|
||||
r <- case l of
|
||||
(f:[]) | takeFileName (fromRawFilePath f) == takeFileName file ->
|
||||
(f:[]) | takeFileName f == takeFileName file ->
|
||||
return (Just f)
|
||||
_ -> return Nothing
|
||||
void $ liftIO cleanup
|
||||
|
|
|
|||
|
|
@ -49,22 +49,22 @@ start = startingNoMessage (ActionItemOther Nothing) $ do
|
|||
trustmap <- trustMapLoad
|
||||
|
||||
file <- (</>)
|
||||
<$> fromRepo (fromRawFilePath . gitAnnexDir)
|
||||
<*> pure "map.dot"
|
||||
<$> fromRepo gitAnnexDir
|
||||
<*> pure (literalOsPath "map.dot")
|
||||
|
||||
liftIO $ writeFile file (drawMap rs trustmap umap)
|
||||
liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap)
|
||||
next $
|
||||
ifM (Annex.getRead Annex.fast)
|
||||
( runViewer file []
|
||||
, runViewer file
|
||||
[ ("xdot", [File file])
|
||||
, ("dot", [Param "-Tx11", File file])
|
||||
[ ("xdot", [File (fromOsPath file)])
|
||||
, ("dot", [Param "-Tx11", File (fromOsPath file)])
|
||||
]
|
||||
)
|
||||
|
||||
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
|
||||
runViewer :: OsPath -> [(String, [CommandParam])] -> Annex Bool
|
||||
runViewer file [] = do
|
||||
showLongNote $ UnquotedString $ "left map in " ++ file
|
||||
showLongNote $ UnquotedString $ "left map in " ++ fromOsPath file
|
||||
return True
|
||||
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
|
||||
( do
|
||||
|
|
@ -244,7 +244,7 @@ tryScan r
|
|||
where
|
||||
remotecmd = "sh -c " ++ shellEscape
|
||||
(cddir ++ " && " ++ "git config --null --list")
|
||||
dir = fromRawFilePath $ Git.repoPath r
|
||||
dir = fromOsPath $ Git.repoPath r
|
||||
cddir
|
||||
| "/~" `isPrefixOf` dir =
|
||||
let (userhome, reldir) = span (/= '/') (drop 1 dir)
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ optParser desc = MatchExpressionOptions
|
|||
<*> (MatchingUserInfo . addkeysize <$> dataparser)
|
||||
where
|
||||
dataparser = UserProvidedInfo
|
||||
<$> optinfo "file" (strOption
|
||||
<$> optinfo "file" ((fmap stringToOsPath . strOption)
|
||||
( long "file" <> metavar paramFile
|
||||
<> help "specify filename to match against"
|
||||
))
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ seek o = case batchOption o of
|
|||
)
|
||||
_ -> 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))
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
|
|
@ -134,7 +134,7 @@ cleanup k = do
|
|||
unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
|
||||
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
|
||||
Left e -> return (Left e)
|
||||
Right v -> do
|
||||
|
|
@ -145,12 +145,12 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of
|
|||
(Just k, _) -> return $
|
||||
Right (Right k, m)
|
||||
(Nothing, Just f) -> do
|
||||
f' <- liftIO $ relPathCwdToFile (toRawFilePath f)
|
||||
f' <- liftIO $ relPathCwdToFile f
|
||||
return $ Right (Left f', m)
|
||||
(Nothing, Nothing) -> return $
|
||||
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
|
||||
Left f -> do
|
||||
mk <- lookupKeyStaged f
|
||||
|
|
|
|||
|
|
@ -79,10 +79,10 @@ seekDistributedMigrations incremental =
|
|||
-- by multiple jobs.
|
||||
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
|
||||
forced <- Annex.getRead Annex.force
|
||||
v <- Backend.getBackend (fromRawFilePath file) key
|
||||
v <- Backend.getBackend file key
|
||||
case v of
|
||||
Nothing -> stop
|
||||
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
|
||||
- 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)
|
||||
where
|
||||
go Nothing = stop
|
||||
|
|
|
|||
|
|
@ -28,7 +28,6 @@ import Utility.Hash
|
|||
import Utility.Tmp
|
||||
import Utility.Tmp.Dir
|
||||
import Utility.Process.Transcript
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
import Data.Char
|
||||
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
|
||||
KeyContainer s -> liftIO $ genkey (Param s)
|
||||
KeyFile f -> do
|
||||
createAnnexDirectory (toRawFilePath (takeDirectory f))
|
||||
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
|
||||
liftIO $ protectedOutput $ genkey (File f)
|
||||
createAnnexDirectory (takeDirectory f)
|
||||
liftIO $ removeWhenExistsWith removeFile f
|
||||
liftIO $ protectedOutput $ genkey (File (fromOsPath f))
|
||||
case (ok, parseFingerprint s) of
|
||||
(False, _) -> giveup $ "uftp_keymgt failed: " ++ 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
|
||||
-- expensive.
|
||||
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
|
||||
withTmpFile (toOsPath "send") $ \t h -> do
|
||||
withTmpFile (literalOsPath "send") $ \t h -> do
|
||||
let ww = WarnUnmatchLsFiles "multicast"
|
||||
(fs', cleanup) <- seekHelper id ww LsFiles.inRepo
|
||||
=<< workTreeItems ww fs
|
||||
matcher <- Limit.getMatcher
|
||||
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $
|
||||
liftIO $ hPutStrLn h o
|
||||
liftIO $ hPutStrLn h (fromOsPath o)
|
||||
forM_ fs' $ \(_, f) -> do
|
||||
mk <- lookupKey f
|
||||
case mk of
|
||||
Nothing -> noop
|
||||
Just k -> withObjectLoc k $
|
||||
addlist f . fromRawFilePath
|
||||
Just k -> withObjectLoc k $ addlist f
|
||||
liftIO $ hClose h
|
||||
liftIO $ void cleanup
|
||||
|
||||
|
|
@ -161,9 +159,9 @@ send ups fs = do
|
|||
, Param "-k", uftpKeyParam serverkey
|
||||
, Param "-U", Param (uftpUID u)
|
||||
-- only allow clients on the authlist
|
||||
, Param "-H", Param ("@"++authlist)
|
||||
, Param "-H", Param ("@"++fromOsPath authlist)
|
||||
-- pass in list of files to send
|
||||
, Param "-i", File (fromRawFilePath (fromOsPath t))
|
||||
, Param "-i", File (fromOsPath t)
|
||||
] ++ ups
|
||||
liftIO (boolSystem "uftp" ps) >>= showEndResult
|
||||
next $ return True
|
||||
|
|
@ -178,9 +176,9 @@ receive ups = starting "receiving multicast files" ai si $ do
|
|||
(callback, environ, statush) <- liftIO multicastCallbackEnv
|
||||
tmpobjdir <- fromRepo gitAnnexTmpObjectDir
|
||||
createAnnexDirectory tmpobjdir
|
||||
withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
|
||||
abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir)
|
||||
abscallback <- liftIO $ searchPath callback
|
||||
withTmpDirIn tmpobjdir (literalOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
|
||||
abstmpdir <- liftIO $ absPath tmpdir
|
||||
abscallback <- liftIO $ searchPath (fromOsPath callback)
|
||||
let ps =
|
||||
-- Avoid it running as a daemon.
|
||||
[ Param "-d"
|
||||
|
|
@ -189,42 +187,43 @@ receive ups = starting "receiving multicast files" ai si $ do
|
|||
, Param "-k", uftpKeyParam clientkey
|
||||
, Param "-U", Param (uftpUID u)
|
||||
-- Only allow servers on the authlist
|
||||
, Param "-S", Param authlist
|
||||
, Param "-S", Param (fromOsPath authlist)
|
||||
-- Receive files into tmpdir
|
||||
-- (it needs an absolute path)
|
||||
, Param "-D", File (fromRawFilePath abstmpdir)
|
||||
, Param "-D", File (fromOsPath abstmpdir)
|
||||
-- Run callback after each file received
|
||||
-- (it needs an absolute path)
|
||||
, Param "-s", Param (fromMaybe callback abscallback)
|
||||
, Param "-s", Param (fromOsPath $ fromMaybe callback abscallback)
|
||||
] ++ ups
|
||||
runner <- liftIO $ async $
|
||||
hClose statush
|
||||
`after` boolSystemEnv "uftpd" ps (Just environ)
|
||||
mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
|
||||
mapM_ storeReceived . map toOsPath . lines
|
||||
=<< liftIO (hGetContents statush)
|
||||
showEndResult =<< liftIO (wait runner)
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther Nothing
|
||||
si = SeekInput []
|
||||
|
||||
storeReceived :: FilePath -> Annex ()
|
||||
storeReceived :: OsPath -> Annex ()
|
||||
storeReceived f = do
|
||||
case deserializeKey (takeFileName f) of
|
||||
case deserializeKey' (fromOsPath (takeFileName f)) of
|
||||
Nothing -> do
|
||||
warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file."
|
||||
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
|
||||
warning $ "Received a file " <> QuotedPath f <> " that is not a git-annex key. Deleting this file."
|
||||
liftIO $ removeWhenExistsWith removeFile f
|
||||
Just k -> void $ logStatusAfter NoLiveUpdate k $
|
||||
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
|
||||
liftIO $ catchBoolIO $ do
|
||||
R.rename (toRawFilePath f) dest
|
||||
renameFile f dest
|
||||
return True
|
||||
|
||||
-- Under Windows, uftp uses key containers, which are not files on the
|
||||
-- filesystem.
|
||||
data UftpKey = KeyFile FilePath | KeyContainer String
|
||||
data UftpKey = KeyFile OsPath | KeyContainer String
|
||||
|
||||
uftpKeyParam :: UftpKey -> CommandParam
|
||||
uftpKeyParam (KeyFile f) = File f
|
||||
uftpKeyParam (KeyFile f) = File (fromOsPath f)
|
||||
uftpKeyParam (KeyContainer s) = Param s
|
||||
|
||||
uftpKey :: Annex UftpKey
|
||||
|
|
@ -233,7 +232,7 @@ uftpKey = do
|
|||
u <- getUUID
|
||||
return $ KeyContainer $ "annex-" ++ fromUUID u
|
||||
#else
|
||||
uftpKey = KeyFile <$> credsFile "multicast"
|
||||
uftpKey = KeyFile <$> credsFile (literalOsPath "multicast")
|
||||
#endif
|
||||
|
||||
-- uftp needs a unique UID for each client and server, which
|
||||
|
|
@ -242,13 +241,13 @@ uftpKey = KeyFile <$> credsFile "multicast"
|
|||
uftpUID :: UUID -> String
|
||||
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
|
||||
m <- knownFingerPrints
|
||||
withTmpFile (toOsPath "authlist") $ \t h -> do
|
||||
withTmpFile (literalOsPath "authlist") $ \t h -> do
|
||||
liftIO $ hPutStr h (genAuthList m)
|
||||
liftIO $ hClose h
|
||||
a (fromRawFilePath (fromOsPath t))
|
||||
a t
|
||||
|
||||
genAuthList :: M.Map UUID Fingerprint -> String
|
||||
genAuthList = unlines . map fmt . M.toList
|
||||
|
|
|
|||
|
|
@ -62,14 +62,14 @@ addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
|
|||
addViewMetaData v f k = starting "metadata" ai si $
|
||||
next $ changeMetaData k $ fromView v f
|
||||
where
|
||||
ai = mkActionItem (k, toRawFilePath f)
|
||||
ai = mkActionItem (k, f)
|
||||
si = SeekInput []
|
||||
|
||||
removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
|
||||
removeViewMetaData v f k = starting "metadata" ai si $
|
||||
next $ changeMetaData k $ unsetMetaData $ fromView v f
|
||||
where
|
||||
ai = mkActionItem (k, toRawFilePath f)
|
||||
ai = mkActionItem (k, f)
|
||||
si = SeekInput []
|
||||
|
||||
changeMetaData :: Key -> MetaData -> CommandCleanup
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Git.Types where
|
||||
|
||||
|
|
@ -107,8 +108,10 @@ instance FromConfigValue S.ByteString where
|
|||
instance FromConfigValue String where
|
||||
fromConfigValue = decodeBS . fromConfigValue
|
||||
|
||||
#ifdef WITH_OSPATH
|
||||
instance FromConfigValue OsPath where
|
||||
fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString)
|
||||
#endif
|
||||
|
||||
instance Show ConfigValue where
|
||||
show = fromConfigValue
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ module Messages.JSON (
|
|||
import Control.Applicative
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Aeson.KeyMap as HM
|
||||
import System.IO
|
||||
|
|
@ -84,7 +85,7 @@ start command file key si _ = case j of
|
|||
j = toJSON' $ JSONActionItem
|
||||
{ itemCommand = Just command
|
||||
, itemKey = key
|
||||
, itemFile = fromOsPath <$> file
|
||||
, itemFile = file
|
||||
, itemUUID = Nothing
|
||||
, itemFields = Nothing :: Maybe Bool
|
||||
, itemSeekInput = si
|
||||
|
|
@ -98,7 +99,7 @@ startActionItem command ai si _ = case j of
|
|||
j = toJSON' $ JSONActionItem
|
||||
{ itemCommand = Just command
|
||||
, itemKey = actionItemKey ai
|
||||
, itemFile = fromOsPath <$> actionItemFile ai
|
||||
, itemFile = actionItemFile ai
|
||||
, itemUUID = actionItemUUID ai
|
||||
, itemFields = Nothing :: Maybe Bool
|
||||
, itemSeekInput = si
|
||||
|
|
@ -206,7 +207,7 @@ instance ToJSON' a => ToJSON' (ObjectMap a) where
|
|||
data JSONActionItem a = JSONActionItem
|
||||
{ itemCommand :: Maybe String
|
||||
, itemKey :: Maybe Key
|
||||
, itemFile :: Maybe FilePath
|
||||
, itemFile :: Maybe OsPath
|
||||
, itemUUID :: Maybe UUID
|
||||
, itemFields :: Maybe a
|
||||
, itemSeekInput :: SeekInput
|
||||
|
|
@ -220,7 +221,9 @@ instance ToJSON' a => ToJSON' (JSONActionItem a) where
|
|||
Just k -> Just $ "key" .= toJSON' k
|
||||
Nothing -> Nothing
|
||||
, 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
|
||||
, case itemFields i of
|
||||
Just f -> Just $ "fields" .= toJSON' f
|
||||
|
|
@ -235,7 +238,7 @@ instance FromJSON a => FromJSON (JSONActionItem a) where
|
|||
parseJSON (Object v) = JSONActionItem
|
||||
<$> (v .:? "command")
|
||||
<*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))
|
||||
<*> (v .:? "file")
|
||||
<*> (fmap stringToOsPath <$> (v .:? "file"))
|
||||
<*> (v .:? "uuid")
|
||||
<*> (v .:? "fields")
|
||||
-- ^ fields is used for metadata, which is currently the
|
||||
|
|
|
|||
|
|
@ -432,8 +432,9 @@ checklocationlog f expected = do
|
|||
|
||||
checkbackend :: FilePath -> Types.Backend -> Assertion
|
||||
checkbackend file expected = do
|
||||
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
|
||||
=<< Annex.WorkTree.lookupKey (toOsPath file)
|
||||
let file' = toOsPath file
|
||||
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file')
|
||||
=<< Annex.WorkTree.lookupKey file'
|
||||
assertEqual ("backend for " ++ file) (Just expected) b
|
||||
|
||||
checkispointerfile :: FilePath -> Assertion
|
||||
|
|
|
|||
|
|
@ -5,7 +5,9 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Types.UUID where
|
||||
|
||||
|
|
@ -20,11 +22,10 @@ import Data.ByteString.Builder
|
|||
import Control.DeepSeq
|
||||
import qualified Data.Semigroup as Sem
|
||||
|
||||
import Common
|
||||
import Git.Types (ConfigValue(..))
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.QuickCheck
|
||||
import Utility.Aeson
|
||||
import Utility.OsPath
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
||||
-- 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
|
||||
| otherwise = UUID (SB.fromShort b)
|
||||
|
||||
#ifdef WITH_OSPATH
|
||||
-- OsPath is a ShortByteString internally, so this is the most
|
||||
-- efficient conversion.
|
||||
instance FromUUID OsPath where
|
||||
|
|
@ -72,6 +74,7 @@ instance FromUUID OsPath where
|
|||
|
||||
instance ToUUID OsPath where
|
||||
toUUID s = toUUID (fromOsPath s :: SB.ShortByteString)
|
||||
#endif
|
||||
|
||||
instance FromUUID String where
|
||||
fromUUID s = decodeBS (fromUUID s)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,10 @@
|
|||
|
||||
module Utility.OsString (
|
||||
module X,
|
||||
length
|
||||
length,
|
||||
#ifndef WITH_OSPATH
|
||||
toChar,
|
||||
#endif
|
||||
) where
|
||||
|
||||
#ifdef WITH_OSPATH
|
||||
|
|
@ -30,4 +33,10 @@ length = B.length . fromOsPath
|
|||
#else
|
||||
import Data.ByteString as X hiding (length)
|
||||
import Data.ByteString (length)
|
||||
import Data.Char
|
||||
import Data.Word
|
||||
import Prelude (fromIntegral, (.))
|
||||
|
||||
toChar :: Word8 -> Char
|
||||
toChar = chr . fromIntegral
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -17,6 +17,11 @@ module Utility.SafeOutput (
|
|||
import Data.Char
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
#ifdef WITH_OSPATH
|
||||
import qualified Utility.OsString as OS
|
||||
import Utility.OsPath
|
||||
#endif
|
||||
|
||||
class SafeOutputtable t where
|
||||
safeOutput :: t -> t
|
||||
|
||||
|
|
@ -26,6 +31,11 @@ instance SafeOutputtable String where
|
|||
instance SafeOutputtable S.ByteString where
|
||||
safeOutput = S.filter (safeOutputChar . chr . fromIntegral)
|
||||
|
||||
#ifdef WITH_OSPATH
|
||||
instance SafeOutputtable OsString where
|
||||
safeOutput = OS.filter (safeOutputChar . toChar)
|
||||
#endif
|
||||
|
||||
safeOutputChar :: Char -> Bool
|
||||
safeOutputChar c
|
||||
| not (isControl c) = True
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue