more OsPath conversion (602/749)

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

View file

@ -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