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

more OsPath conversion (749/749)

Browse source 
Builds with and without OsPath build flag.

Unfortunately, the test suite fails.

Sponsored-by: unqueued on Patreon
This commit is contained in:
Joey Hess 2025-02-10 14:57:25 -04:00
parent 20ed039d59
commit c730d00b6e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
41 changed files with 416 additions and 427 deletions
Download patch file Download diff file Expand all files Collapse all files

14
Annex/Locations.hs
View file

@ -556,12 +556,10 @@ gitAnnexCredsDir r = addTrailingPathSeparator $
{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
- when HTTPS is enabled -} - when HTTPS is enabled -}
gitAnnexWebCertificate :: Git.Repo -> FilePath gitAnnexWebCertificate :: Git.Repo -> OsPath
gitAnnexWebCertificate r = fromOsPath $ gitAnnexWebCertificate r = gitAnnexDir r </> literalOsPath "certificate.pem"
gitAnnexDir r </> literalOsPath "certificate.pem" gitAnnexWebPrivKey :: Git.Repo -> OsPath
gitAnnexWebPrivKey :: Git.Repo -> FilePath gitAnnexWebPrivKey r = gitAnnexDir r </> literalOsPath "privkey.pem"
gitAnnexWebPrivKey r = fromOsPath $
gitAnnexDir r </> literalOsPath "privkey.pem"
{- .git/annex/feeds/ is used to record per-key (url) state by importfeed -} {- .git/annex/feeds/ is used to record per-key (url) state by importfeed -}
gitAnnexFeedStateDir :: Git.Repo -> OsPath gitAnnexFeedStateDir :: Git.Repo -> OsPath
@ -686,8 +684,8 @@ gitAnnexRemotesDir r = addTrailingPathSeparator $
{- This is the base directory name used by the assistant when making {- This is the base directory name used by the assistant when making
- repositories, by default. -} - repositories, by default. -}
gitAnnexAssistantDefaultDir :: FilePath gitAnnexAssistantDefaultDir :: OsPath
gitAnnexAssistantDefaultDir = "annex" gitAnnexAssistantDefaultDir = literalOsPath "annex"
gitAnnexSimDir :: Git.Repo -> OsPath gitAnnexSimDir :: Git.Repo -> OsPath
gitAnnexSimDir r = addTrailingPathSeparator $ gitAnnexSimDir r = addTrailingPathSeparator $

6
Annex/Path.hs
View file

@ -53,7 +53,7 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR"
else pure "git-annex" else pure "git-annex"
p <- if isAbsolute (toOsPath exe) p <- if isAbsolute (toOsPath exe)
then return exe then return exe
else fromMaybe exe <$> readProgramFile else maybe exe fromOsPath <$> readProgramFile
maybe cannotFindProgram return =<< searchPath p maybe cannotFindProgram return =<< searchPath p
reqgitannex name reqgitannex name
@ -62,10 +62,10 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR"
isgitannex = flip M.notMember otherMulticallCommands isgitannex = flip M.notMember otherMulticallCommands
{- Returns the path for git-annex that is recorded in the programFile. -} {- Returns the path for git-annex that is recorded in the programFile. -}
readProgramFile :: IO (Maybe FilePath) readProgramFile :: IO (Maybe OsPath)
readProgramFile = catchDefaultIO Nothing $ do readProgramFile = catchDefaultIO Nothing $ do
programfile <- programFile programfile <- programFile
headMaybe . lines <$> readFile (fromOsPath programfile) fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile)
cannotFindProgram :: IO a cannotFindProgram :: IO a
cannotFindProgram = do cannotFindProgram = do

21
Assistant.hs
View file

@ -62,40 +62,39 @@ import qualified Utility.Debug as Debug
import Network.Socket (HostName, PortNumber) import Network.Socket (HostName, PortNumber)
stopDaemon :: Annex () stopDaemon :: Annex ()
stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
=<< fromRepo gitAnnexPidFile
{- Starts the daemon. If the daemon is run in the foreground, once it's {- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser. - running, can start the browser.
- -
- startbrowser is passed the url and html shim file, as well as the original - startbrowser is passed the url and html shim file, as well as the original
- stdout and stderr descriptors. -} - stdout and stderr descriptors. -}
startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> OsPath -> IO ()) -> Annex ()
startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do
Annex.changeState $ \s -> s { Annex.daemon = True } Annex.changeState $ \s -> s { Annex.daemon = True }
enableInteractiveBranchAccess enableInteractiveBranchAccess
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexDaemonLogFile logfile <- fromRepo gitAnnexDaemonLogFile
liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
createAnnexDirectory (parentDir pidfile) createAnnexDirectory (parentDir pidfile)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile) createAnnexDirectory (parentDir logfile)
let logfd = handleToFd =<< openLog (fromRawFilePath logfile) let logfd = handleToFd =<< openLog (fromOsPath logfile)
if foreground if foreground
then do then do
origout <- liftIO $ catchMaybeIO $ origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $ origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError fdToHandle =<< dup stdError
let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile)) let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
start undaemonize $ start undaemonize $
case startbrowser of case startbrowser of
Nothing -> Nothing Nothing -> Nothing
Just a -> Just $ a origout origerr Just a -> Just $ a origout origerr
else do else do
git_annex <- liftIO programPath git_annex <- fromOsPath <$> liftIO programPath
ps <- gitAnnexDaemonizeParams ps <- gitAnnexDaemonizeParams
start (Utility.Daemon.daemonize git_annex ps logfd (Just (fromRawFilePath pidfile)) False) Nothing start (Utility.Daemon.daemonize git_annex ps logfd (Just pidfile) False) Nothing
#else #else
-- Windows doesn't daemonize, but does redirect output to the -- Windows doesn't daemonize, but does redirect output to the
-- log file. The only way to do so is to restart the program. -- log file. The only way to do so is to restart the program.
@ -104,7 +103,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star
createAnnexDirectory (parentDir logfile) createAnnexDirectory (parentDir logfile)
ifM (liftIO $ isNothing <$> getEnv flag) ifM (liftIO $ isNothing <$> getEnv flag)
( liftIO $ withNullHandle $ \nullh -> do ( liftIO $ withNullHandle $ \nullh -> do
loghandle <- openLog (fromRawFilePath logfile) loghandle <- openLog (fromOsPath logfile)
e <- getEnvironment e <- getEnvironment
cmd <- programPath cmd <- programPath
ps <- getArgs ps <- getArgs
@ -117,7 +116,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star
exitcode <- withCreateProcess p $ \_ _ _ pid -> exitcode <- withCreateProcess p $ \_ _ _ pid ->
waitForProcess pid waitForProcess pid
exitWith exitcode exitWith exitcode
, start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $ , start (Utility.Daemon.foreground (Just (fromOsPath pidfile))) $
case startbrowser of case startbrowser of
Nothing -> Nothing Nothing -> Nothing
Just a -> Just $ a Nothing Nothing Just a -> Just $ a Nothing Nothing
@ -128,7 +127,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star
checkCanWatch checkCanWatch
dstatus <- startDaemonStatus dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexDaemonLogFile logfile <- fromRepo gitAnnexDaemonLogFile
liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
liftIO $ daemonize $ liftIO $ daemonize $
flip runAssistant (go webappwaiter) flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus =<< newAssistantData st dstatus

2
Assistant/Alert.hs
View file

@ -395,7 +395,7 @@ fileAlert msg files = (activityAlert Nothing shortfiles)
maxfilesshown = 10 maxfilesshown = 10
(!somefiles, !counter) = splitcounter (dedupadjacent files) (!somefiles, !counter) = splitcounter (dedupadjacent files)
!shortfiles = map (fromString . shortFile . takeFileName) somefiles !shortfiles = map (fromString . shortFile . fromOsPath . takeFileName . toOsPath) somefiles
renderer alert = tenseWords $ msg : alertData alert ++ showcounter renderer alert = tenseWords $ msg : alertData alert ++ showcounter
where where

4
Assistant/Changes.hs
View file

@ -15,14 +15,14 @@ import Data.Time.Clock
import Control.Concurrent.STM import Control.Concurrent.STM
{- Handlers call this when they made a change that needs to get committed. -} {- Handlers call this when they made a change that needs to get committed. -}
madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change) madeChange :: OsPath -> ChangeInfo -> Assistant (Maybe Change)
madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t) madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)
noChange :: Assistant (Maybe Change) noChange :: Assistant (Maybe Change)
noChange = return Nothing noChange = return Nothing
{- Indicates an add needs to be done, but has not started yet. -} {- Indicates an add needs to be done, but has not started yet. -}
pendingAddChange :: FilePath -> Assistant (Maybe Change) pendingAddChange :: OsPath -> Assistant (Maybe Change)
pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f) pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)
{- Gets all unhandled changes. {- Gets all unhandled changes.

55
Assistant/Install.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Assistant.Install where module Assistant.Install where
@ -31,8 +32,8 @@ import Utility.Android
import System.PosixCompat.Files (ownerExecuteMode) import System.PosixCompat.Files (ownerExecuteMode)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
standaloneAppBase :: IO (Maybe FilePath) standaloneAppBase :: IO (Maybe OsPath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" standaloneAppBase = fmap toOsPath <$> getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process. {- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant - So when it's run, it needs to set up autostarting of the assistant
@ -51,13 +52,12 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
, go =<< standaloneAppBase , go =<< standaloneAppBase
) )
where where
go Nothing = installFileManagerHooks "git-annex" go Nothing = installFileManagerHooks (literalOsPath "git-annex")
go (Just base) = do go (Just base) = do
let program = base </> "git-annex" let program = base </> literalOsPath "git-annex"
programfile <- programFile programfile <- programFile
createDirectoryIfMissing True $ createDirectoryIfMissing True (parentDir programfile)
fromRawFilePath (parentDir (toRawFilePath programfile)) writeFile (fromOsPath programfile) (fromOsPath program)
writeFile programfile program
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
autostartfile <- userAutoStart osxAutoStartLabel autostartfile <- userAutoStart osxAutoStartLabel
@ -67,24 +67,24 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
( do ( do
-- Integration with the Termux:Boot app. -- Integration with the Termux:Boot app.
home <- myHomeDir home <- myHomeDir
let bootfile = home </> ".termux" </> "boot" </> "git-annex" let bootfile = toOsPath home </> literalOsPath ".termux" </> literalOsPath "boot" </> literalOsPath "git-annex"
unlessM (doesFileExist bootfile) $ do unlessM (doesFileExist bootfile) $ do
createDirectoryIfMissing True (takeDirectory bootfile) createDirectoryIfMissing True (takeDirectory bootfile)
writeFile bootfile "git-annex assistant --autostart" writeFile (fromOsPath bootfile) "git-annex assistant --autostart"
, do , do
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir icondir <- iconDir <$> userDataDir
installMenu program menufile base icondir installMenu (fromOsPath program) menufile base icondir
autostartfile <- autoStartPath "git-annex" <$> userConfigDir autostartfile <- autoStartPath "git-annex" <$> userConfigDir
installAutoStart program autostartfile installAutoStart (fromOsPath program) autostartfile
) )
#endif #endif
sshdir <- sshDir sshdir <- sshDir
let runshell var = "exec " ++ base </> "runshell " ++ var let runshell var = "exec " ++ fromOsPath (base </> literalOsPath "runshell ") ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\"" let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $ installWrapper (sshdir </> literalOsPath "git-annex-shell") $
[ shebang [ shebang
, "set -e" , "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
@ -93,7 +93,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
, rungitannexshell "$@" , rungitannexshell "$@"
, "fi" , "fi"
] ]
installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $ installWrapper (sshdir </> literalOsPath "git-annex-wrapper") $
[ shebang [ shebang
, "set -e" , "set -e"
, runshell "\"$@\"" , runshell "\"$@\""
@ -101,47 +101,46 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
installFileManagerHooks program installFileManagerHooks program
installWrapper :: RawFilePath -> [String] -> IO () installWrapper :: OsPath -> [String] -> IO ()
installWrapper file content = do installWrapper file content = do
let content' = map encodeBS content let content' = map encodeBS content
curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file) curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file
when (curr /= content') $ do when (curr /= content') $ do
createDirectoryIfMissing True (fromRawFilePath (parentDir file)) createDirectoryIfMissing True (parentDir file)
viaTmp F.writeFile' (toOsPath file) $ viaTmp F.writeFile' file $ linesFile' (S8.unlines content')
linesFile' (S8.unlines content')
modifyFileMode file $ addModes [ownerExecuteMode] modifyFileMode file $ addModes [ownerExecuteMode]
installFileManagerHooks :: FilePath -> IO () installFileManagerHooks :: OsPath -> IO ()
#ifdef linux_HOST_OS #ifdef linux_HOST_OS
installFileManagerHooks program = unlessM osAndroid $ do installFileManagerHooks program = unlessM osAndroid $ do
let actions = ["get", "drop", "undo"] let actions = ["get", "drop", "undo"]
-- Gnome -- Gnome
nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir nautilusScriptdir <- (\d -> d </> literalOsPath "nautilus" </> literalOsPath "scripts") <$> userDataDir
createDirectoryIfMissing True nautilusScriptdir createDirectoryIfMissing True nautilusScriptdir
forM_ actions $ forM_ actions $
genNautilusScript nautilusScriptdir genNautilusScript nautilusScriptdir
-- KDE -- KDE
userdata <- userDataDir userdata <- userDataDir
let kdeServiceMenusdir = userdata </> "kservices5" </> "ServiceMenus" let kdeServiceMenusdir = userdata </> literalOsPath "kservices5" </> literalOsPath "ServiceMenus"
createDirectoryIfMissing True kdeServiceMenusdir createDirectoryIfMissing True kdeServiceMenusdir
writeFile (kdeServiceMenusdir </> "git-annex.desktop") writeFile (fromOsPath (kdeServiceMenusdir </> literalOsPath "git-annex.desktop"))
(kdeDesktopFile actions) (kdeDesktopFile actions)
where where
genNautilusScript scriptdir action = genNautilusScript scriptdir action =
installscript (toRawFilePath (scriptdir </> scriptname action)) $ unlines installscript (scriptdir </> toOsPath (scriptname action)) $ unlines
[ shebang [ shebang
, autoaddedcomment , autoaddedcomment
, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" , "exec " ++ fromOsPath program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
] ]
scriptname action = "git-annex " ++ action scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do installscript f c = whenM (safetoinstallscript f) $ do
writeFile (fromRawFilePath f) c writeFile (fromOsPath f) c
modifyFileMode f $ addModes [ownerExecuteMode] modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $ safetoinstallscript f = catchDefaultIO True $
elem (encodeBS autoaddedcomment) . fileLines' elem (encodeBS autoaddedcomment) . fileLines'
<$> F.readFile' (toOsPath f) <$> F.readFile' f
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit." autoaddedmsg = "Automatically added by git-annex, do not edit."
@ -167,7 +166,7 @@ installFileManagerHooks program = unlessM osAndroid $ do
, "Icon=git-annex" , "Icon=git-annex"
, unwords , unwords
[ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&" [ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&"
, program , fromOsPath program
, command , command
, "--notify-start --notify-finish -- \"$1\"'" , "--notify-start --notify-finish -- \"$1\"'"
, "false" -- this becomes $0 in sh, so unused , "false" -- this becomes $0 in sh, so unused

16
Assistant/MakeRepo.hs
View file

@ -28,7 +28,7 @@ import Config
{- Makes a new git repository. Or, if a git repository already {- Makes a new git repository. Or, if a git repository already
- exists, returns False. -} - exists, returns False. -}
makeRepo :: FilePath -> Bool -> IO Bool makeRepo :: OsPath -> Bool -> IO Bool
makeRepo path bare = ifM (probeRepoExists path) makeRepo path bare = ifM (probeRepoExists path)
( return False ( return False
, do , do
@ -41,19 +41,19 @@ makeRepo path bare = ifM (probeRepoExists path)
where where
baseparams = [Param "init", Param "--quiet"] baseparams = [Param "init", Param "--quiet"]
params params
| bare = baseparams ++ [Param "--bare", File path] | bare = baseparams ++ [Param "--bare", File (fromOsPath path)]
| otherwise = baseparams ++ [File path] | otherwise = baseparams ++ [File (fromOsPath path)]
{- Runs an action in the git repository in the specified directory. -} {- Runs an action in the git repository in the specified directory. -}
inDir :: FilePath -> Annex a -> IO a inDir :: OsPath -> Annex a -> IO a
inDir dir a = do inDir dir a = do
state <- Annex.new state <- Annex.new
=<< Git.Config.read =<< Git.Config.read
=<< Git.Construct.fromPath (toRawFilePath dir) =<< Git.Construct.fromPath dir
Annex.eval state $ a `finally` quiesce True Annex.eval state $ a `finally` quiesce True
{- Creates a new repository, and returns its UUID. -} {- Creates a new repository, and returns its UUID. -}
initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID initRepo :: Bool -> Bool -> OsPath -> Maybe String -> Maybe StandardGroup -> IO UUID
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
initRepo' desc mgroup initRepo' desc mgroup
{- Initialize the master branch, so things that expect {- Initialize the master branch, so things that expect
@ -94,6 +94,6 @@ initRepo' desc mgroup = unlessM isInitialized $ do
Annex.Branch.commit =<< Annex.Branch.commitMessage Annex.Branch.commit =<< Annex.Branch.commitMessage
{- Checks if a git repo exists at a location. -} {- Checks if a git repo exists at a location. -}
probeRepoExists :: FilePath -> IO Bool probeRepoExists :: OsPath -> IO Bool
probeRepoExists dir = isJust <$> probeRepoExists dir = isJust <$>
catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir)) catchDefaultIO Nothing (Git.Construct.checkForRepo dir)

6
Assistant/Pairing/MakeRemote.hs
View file

@ -22,11 +22,11 @@ import qualified Data.Text as T
{- Authorized keys are set up before pairing is complete, so that the other {- Authorized keys are set up before pairing is complete, so that the other
- side can immediately begin syncing. -} - side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> FilePath -> IO () setupAuthorizedKeys :: PairMsg -> OsPath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> giveup err Left err -> giveup err
Right pubkey -> do Right pubkey -> do
absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir) absdir <- absPath repodir
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $ unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
giveup "failed setting up ssh authorized keys" giveup "failed setting up ssh authorized keys"
@ -66,7 +66,7 @@ pairMsgToSshData msg = do
{ sshHostName = T.pack hostname { sshHostName = T.pack hostname
, sshUserName = Just (T.pack $ remoteUserName d) , sshUserName = Just (T.pack $ remoteUserName d)
, sshDirectory = T.pack dir , sshDirectory = T.pack dir
, sshRepoName = genSshRepoName hostname dir , sshRepoName = genSshRepoName hostname (toOsPath dir)
, sshPort = 22 , sshPort = 22
, needsPubKey = True , needsPubKey = True
, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]

22
Assistant/Repair.hs
View file

@ -31,11 +31,9 @@ import qualified Data.Text as T
#endif #endif
import qualified Utility.Lsof as Lsof import qualified Utility.Lsof as Lsof
import Utility.ThreadScheduler import Utility.ThreadScheduler
import qualified Utility.RawFilePath as R import qualified Utility.OsString as OS
import Control.Concurrent.Async import Control.Concurrent.Async
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive {- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -} - repair. If that fails, pops up an alert. -}
@ -98,7 +96,7 @@ runRepair u mrmt destructiverepair = do
thisrepopath <- liftIO . absPath thisrepopath <- liftIO . absPath
=<< liftAnnex (fromRepo Git.repoPath) =<< liftAnnex (fromRepo Git.repoPath)
a <- liftAnnex $ mkrepair $ a <- liftAnnex $ mkrepair $
repair fsckresults (Just (fromRawFilePath thisrepopath)) repair fsckresults (Just (fromOsPath thisrepopath))
liftIO $ catchBoolIO a liftIO $ catchBoolIO a
repair fsckresults referencerepo = do repair fsckresults referencerepo = do
@ -110,7 +108,7 @@ runRepair u mrmt destructiverepair = do
backgroundfsck params = liftIO $ void $ async $ do backgroundfsck params = liftIO $ void $ async $ do
program <- programPath program <- programPath
batchCommand program (Param "fsck" : params) batchCommand (fromOsPath program) (Param "fsck" : params)
{- Detect when a git lock file exists and has no git process currently {- Detect when a git lock file exists and has no git process currently
- writing to it. This strongly suggests it is a stale lock file. - writing to it. This strongly suggests it is a stale lock file.
@ -135,26 +133,26 @@ repairStaleGitLocks r = do
repairStaleLocks lockfiles repairStaleLocks lockfiles
return $ not $ null lockfiles return $ not $ null lockfiles
where where
findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f islock f
| "gc.pid" `S.isInfixOf` f = False | literalOsPath "gc.pid" `OS.isInfixOf` f = False
| ".lock" `S.isSuffixOf` f = True | literalOsPath ".lock" `OS.isSuffixOf` f = True
| P.takeFileName f == "MERGE_HEAD" = True | takeFileName f == literalOsPath "MERGE_HEAD" = True
| otherwise = False | otherwise = False
repairStaleLocks :: [RawFilePath] -> Assistant () repairStaleLocks :: [OsPath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes repairStaleLocks lockfiles = go =<< getsizes
where where
getsize lf = catchMaybeIO $ (\s -> (lf, s)) getsize lf = catchMaybeIO $ (\s -> (lf, s))
<$> getFileSize lf <$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return () go [] = return ()
go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l)) go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l))
( do ( do
waitforit "to check stale git lock file" waitforit "to check stale git lock file"
l' <- getsizes l' <- getsizes
if l' == l if l' == l
then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l
else go l' else go l'
, do , do
waitforit "for git lock file writer" waitforit "for git lock file writer"

21
Assistant/Restart.hs
View file

@ -18,7 +18,6 @@ import Utility.NotificationBroadcaster
import Utility.Url import Utility.Url
import Utility.Url.Parse import Utility.Url.Parse
import Utility.PID import Utility.PID
import qualified Utility.RawFilePath as R
import qualified Git.Construct import qualified Git.Construct
import qualified Git.Config import qualified Git.Config
import qualified Annex import qualified Annex
@ -41,8 +40,8 @@ import Network.URI
prepRestart :: Assistant () prepRestart :: Assistant ()
prepRestart = do prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url {- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp. - to any web browsers that are displaying the webapp.
@ -66,21 +65,21 @@ terminateSelf =
runRestart :: Assistant URLString runRestart :: Assistant URLString
runRestart = liftIO . newAssistantUrl runRestart = liftIO . newAssistantUrl
=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo) =<< liftAnnex (Git.repoPath <$> Annex.gitRepo)
{- Starts up the assistant in the repository, and waits for it to create {- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. -} - connections by testing the url. -}
newAssistantUrl :: FilePath -> IO URLString newAssistantUrl :: OsPath -> IO URLString
newAssistantUrl repo = do newAssistantUrl repo = do
startAssistant repo startAssistant repo
geturl geturl
where where
geturl = do geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo) r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ fromRawFilePath $ gitAnnexUrlFile r waiturl $ gitAnnexUrlFile r
waiturl urlfile = do waiturl urlfile = do
v <- tryIO $ readFile urlfile v <- tryIO $ readFile (fromOsPath urlfile)
case v of case v of
Left _ -> delayed $ waiturl urlfile Left _ -> delayed $ waiturl urlfile
Right url -> ifM (assistantListening url) Right url -> ifM (assistantListening url)
@ -112,8 +111,8 @@ assistantListening url = catchBoolIO $ do
- On windows, the assistant does not daemonize, which is why the forkIO is - On windows, the assistant does not daemonize, which is why the forkIO is
- done. - done.
-} -}
startAssistant :: FilePath -> IO () startAssistant :: OsPath -> IO ()
startAssistant repo = void $ forkIO $ do startAssistant repo = void $ forkIO $ do
program <- programPath program <- fromOsPath <$> programPath
let p = (proc program ["assistant"]) { cwd = Just repo } let p = (proc program ["assistant"]) { cwd = Just (fromOsPath repo) }
withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid

19
Assistant/Ssh.hs
View file

@ -20,6 +20,7 @@ import Git.Remote
import Utility.SshHost import Utility.SshHost
import Utility.Process.Transcript import Utility.Process.Transcript
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified Utility.OsString as OS
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -103,7 +104,7 @@ parseSshUrl u
{ sshHostName = T.pack host { sshHostName = T.pack host
, sshUserName = if null user then Nothing else Just $ T.pack user , sshUserName = if null user then Nothing else Just $ T.pack user
, sshDirectory = T.pack dir , sshDirectory = T.pack dir
, sshRepoName = genSshRepoName host dir , sshRepoName = genSshRepoName host (toOsPath dir)
-- dummy values, cannot determine from url -- dummy values, cannot determine from url
, sshPort = 22 , sshPort = 22
, needsPubKey = True , needsPubKey = True
@ -120,10 +121,10 @@ parseSshUrl u
fromssh = mkdata . break (== '/') fromssh = mkdata . break (== '/')
{- Generates a git remote name, like host_dir or host -} {- Generates a git remote name, like host_dir or host -}
genSshRepoName :: String -> FilePath -> String genSshRepoName :: String -> OsPath -> String
genSshRepoName host dir genSshRepoName host dir
| null dir = makeLegalName host | OS.null dir = makeLegalName host
| otherwise = makeLegalName $ host ++ "_" ++ dir | otherwise = makeLegalName $ host ++ "_" ++ fromOsPath dir
{- The output of ssh, including both stdout and stderr. -} {- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool) sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
@ -151,13 +152,13 @@ validateSshPubKey pubkey
where where
(ssh, keytype) = separate (== '-') prefix (ssh, keytype) = separate (== '-') prefix
addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool addAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO Bool
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
{- Should only be used within the same process that added the line; {- Should only be used within the same process that added the line;
- the layout of the line is not kepy stable across versions. -} - the layout of the line is not kepy stable across versions. -}
removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO () removeAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir sshdir <- sshDir
@ -173,7 +174,7 @@ removeAuthorizedKeys gitannexshellonly dir pubkey = do
- The ~/.ssh/git-annex-shell wrapper script is created if not already - The ~/.ssh/git-annex-shell wrapper script is created if not already
- present. - present.
-} -}
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String addAuthorizedKeysCommand :: Bool -> OsPath -> SshPubKey -> String
addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh" [ "mkdir -p ~/.ssh"
, intercalate "; " , intercalate "; "
@ -204,14 +205,14 @@ addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
] ]
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\"" runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String authorizedKeysLine :: Bool -> OsPath -> SshPubKey -> String
authorizedKeysLine gitannexshellonly dir pubkey authorizedKeysLine gitannexshellonly dir pubkey
| gitannexshellonly = limitcommand ++ pubkey | gitannexshellonly = limitcommand ++ pubkey
{- TODO: Locking down rsync is difficult, requiring a rather {- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -} - long perl script. -}
| otherwise = pubkey | otherwise = pubkey
where where
limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape (fromOsPath dir)++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
{- Generates a ssh key pair. -} {- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair genSshKeyPair :: IO SshKeyPair

58
Assistant/Threads/Committer.hs
View file

@ -67,11 +67,10 @@ commitThread = namedThread "Committer" $ do
liftAnnex $ do liftAnnex $ do
-- Clean up anything left behind by a previous process -- Clean up anything left behind by a previous process
-- on unclean shutdown. -- on unclean shutdown.
void $ liftIO $ tryIO $ removeDirectoryRecursive void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
(fromRawFilePath lockdowndir)
void $ createAnnexDirectory lockdowndir void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $ readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $
simplifyChanges changes simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges if shouldCommit False time (length readychanges) readychanges
then do then do
@ -276,12 +275,12 @@ commitStaged msg = do
- Any pending adds that are not ready yet are put back into the ChangeChan, - Any pending adds that are not ready yet are put back into the ChangeChan,
- where they will be retried later. - where they will be retried later.
-} -}
handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig let lockdownconfig = LockDownConfig
{ lockingFile = False { lockingFile = False
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True , checkWritePerms = True
} }
(postponed, toadd) <- partitionEithers (postponed, toadd) <- partitionEithers
@ -307,12 +306,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
| otherwise = a | otherwise = a
checkpointerfile change = do checkpointerfile change = do
let file = toRawFilePath $ changeFile change let file = changeFile change
mk <- liftIO $ isPointerFile file mk <- liftIO $ isPointerFile file
case mk of case mk of
Nothing -> return (Right change) Nothing -> return (Right change)
Just key -> do Just key -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file mode <- liftIO $ catchMaybeIO $
fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
return $ Left $ Change return $ Left $ Change
(changeTime change) (changeTime change)
@ -328,7 +328,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
else checkmatcher else checkmatcher
| otherwise = checkmatcher | otherwise = checkmatcher
where where
f = toRawFilePath (changeFile change) f = changeFile change
checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)
( return (Left change) ( return (Left change)
, return (Right change) , return (Right change)
@ -336,9 +336,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
addsmall [] = noop addsmall [] = noop
addsmall toadd = liftAnnex $ void $ tryIO $ addsmall toadd = liftAnnex $ void $ tryIO $
forM (map (toRawFilePath . changeFile) toadd) $ \f -> forM (map changeFile toadd) $ \f ->
Command.Add.addFile Command.Add.Small f Command.Add.addFile Command.Add.Small f
=<< liftIO (R.getSymbolicLinkStatus f) =<< liftIO (R.getSymbolicLinkStatus (fromOsPath f))
{- Avoid overhead of re-injesting a renamed unlocked file, by {- Avoid overhead of re-injesting a renamed unlocked file, by
- examining the other Changes to see if a removed file has the - examining the other Changes to see if a removed file has the
@ -353,13 +353,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
delta <- liftAnnex getTSDelta delta <- liftAnnex getTSDelta
let cfg = LockDownConfig let cfg = LockDownConfig
{ lockingFile = False { lockingFile = False
, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True , checkWritePerms = True
} }
if M.null m if M.null m
then forM toadd (addannexed' cfg) then forM toadd (addannexed' cfg)
else forM toadd $ \c -> do else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of case mcache of
Nothing -> addannexed' cfg c Nothing -> addannexed' cfg c
Just cache -> Just cache ->
@ -376,19 +376,19 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
(mkey, _mcache) <- liftAnnex $ do (mkey, _mcache) <- liftAnnex $ do
showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput [])) showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput []))
ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey maybe (failedingest change) (done change $ keyFilename ks) mkey
addannexed' _ _ = return Nothing addannexed' _ _ = return Nothing
fastadd :: Change -> Key -> Assistant (Maybe Change) fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do fastadd change key = do
let source = keySource $ lockedDown change let source = keySource $ lockedDown change
liftAnnex $ finishIngestUnlocked key source liftAnnex $ finishIngestUnlocked key source
done change (fromRawFilePath $ keyFilename source) key done change (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c -> mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ toRawFilePath $ changeFile c catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks) M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
@ -401,8 +401,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
done change file key = liftAnnex $ do done change file key = liftAnnex $ do
logStatus NoLiveUpdate key InfoPresent logStatus NoLiveUpdate key InfoPresent
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) mode <- liftIO $ catchMaybeIO $
stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key fileMode <$> R.getFileStatus (fromOsPath file)
stagePointerFile file mode =<< hashPointerFile key
showEndOk showEndOk
return $ Just $ finishedChange change key return $ Just $ finishedChange change key
@ -410,14 +411,14 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
- and is still a hard link to its contentLocation, - and is still a hard link to its contentLocation,
- before ingesting it. -} - before ingesting it. -}
sanitycheck keysource a = do sanitycheck keysource a = do
fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource
ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource
if deviceID ks == deviceID fs && fileID ks == fileID fs if deviceID ks == deviceID fs && fileID ks == fileID fs
then a then a
else do else do
-- remove the hard link -- remove the hard link
when (contentLocation keysource /= keyFilename keysource) $ when (contentLocation keysource /= keyFilename keysource) $
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
return Nothing return Nothing
{- Shown an alert while performing an action to add a file or {- Shown an alert while performing an action to add a file or
@ -430,7 +431,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
- the add succeeded. - the add succeeded.
-} -}
addaction [] a = a addaction [] a = a
addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $ addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $
(,) (,)
<$> pure True <$> pure True
<*> a <*> a
@ -440,7 +441,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret
- -
- Check by running lsof on the repository. - Check by running lsof on the repository.
-} -}
safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ _ _ [] [] = return [] safeToAdd _ _ _ _ [] [] = return []
safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd maybe noop (liftIO . threadDelaySeconds) delayadd
@ -451,7 +452,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
then S.fromList . map fst3 . filter openwrite <$> then S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map (keySource . lockedDown) inprocess') findopenfiles (map (keySource . lockedDown) inprocess')
else pure S.empty else pure S.empty
let checked = map (check openfiles) inprocess' let openfiles' = S.map toOsPath openfiles
let checked = map (check openfiles') inprocess'
{- If new events are received when files are closed, {- If new events are received when files are closed,
- there's no need to retry any changes that cannot - there's no need to retry any changes that cannot
@ -463,7 +465,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
else return checked else return checked
where where
check openfiles change@(InProcessAddChange { lockedDown = ld }) check openfiles change@(InProcessAddChange { lockedDown = ld })
| S.member (fromRawFilePath (contentLocation (keySource ld))) openfiles = Left change | S.member (contentLocation (keySource ld)) openfiles = Left change
check _ change = Right change check _ change = Right change
mkinprocess (c, Just ld) = Just InProcessAddChange mkinprocess (c, Just ld) = Just InProcessAddChange
@ -478,7 +480,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
<> " still has writers, not adding" <> " still has writers, not adding"
-- remove the hard link -- remove the hard link
when (contentLocation ks /= keyFilename ks) $ when (contentLocation ks /= keyFilename ks) $
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks void $ liftIO $ tryIO $ removeFile $ contentLocation ks
canceladd _ = noop canceladd _ = noop
openwrite (_file, mode, _pid) openwrite (_file, mode, _pid)
@ -498,9 +500,9 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
findopenfiles keysources = ifM crippledFileSystem findopenfiles keysources = ifM crippledFileSystem
( liftIO $ do ( liftIO $ do
let segments = segmentXargsUnordered $ let segments = segmentXargsUnordered $
map (fromRawFilePath . keyFilename) keysources map (fromOsPath . keyFilename) keysources
concat <$> forM segments (\fs -> Lsof.query $ "--" : fs) concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
, liftIO $ Lsof.queryDir lockdowndir , liftIO $ Lsof.queryDir (fromOsPath lockdowndir)
) )
{- After a Change is committed, queue any necessary transfers or drops {- After a Change is committed, queue any necessary transfers or drops
@ -521,5 +523,5 @@ checkChangeContent change@(Change { changeInfo = i }) =
handleDrops "file renamed" present k af [] handleDrops "file renamed" present k af []
where where
f = changeFile change f = changeFile change
af = AssociatedFile (Just (toRawFilePath f)) af = AssociatedFile (Just f)
checkChangeContent _ = noop checkChangeContent _ = noop

8
Assistant/Threads/ConfigMonitor.hs
View file

@ -44,7 +44,7 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
when (old /= new) $ do when (old /= new) $ do
let changedconfigs = new `S.difference` old let changedconfigs = new `S.difference` old
debug $ "reloading config" : debug $ "reloading config" :
map (fromRawFilePath . fst) map (fromOsPath . fst)
(S.toList changedconfigs) (S.toList changedconfigs)
reloadConfigs new reloadConfigs new
{- Record a commit to get this config {- Record a commit to get this config
@ -54,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
loop new loop new
{- Config files, and their checksums. -} {- Config files, and their checksums. -}
type Configs = S.Set (RawFilePath, Sha) type Configs = S.Set (OsPath, Sha)
{- All git-annex's config files, and actions to run when they change. -} {- All git-annex's config files, and actions to run when they change. -}
configFilesActions :: [(RawFilePath, Assistant ())] configFilesActions :: [(OsPath, Assistant ())]
configFilesActions = configFilesActions =
[ (uuidLog, void $ liftAnnex uuidDescMapLoad) [ (uuidLog, void $ liftAnnex uuidDescMapLoad)
, (remoteLog, void $ liftAnnex remotesChanged) , (remoteLog, void $ liftAnnex remotesChanged)
@ -91,5 +91,5 @@ getConfigs :: Assistant Configs
getConfigs = S.fromList . map extract getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files) <$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files)
where where
files = map (fromRawFilePath . fst) configFilesActions files = map (fromOsPath . fst) configFilesActions
extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)

4
Assistant/Threads/Cronner.hs
View file

@ -181,7 +181,7 @@ runActivity urlrenderer activity nowt = do
runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant () runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
runActivity' urlrenderer (ScheduledSelfFsck _ d) = do runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
program <- liftIO programPath program <- fromOsPath <$> liftIO programPath
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
void $ batchCommand program (Param "fsck" : annexFsckParams d) void $ batchCommand program (Param "fsck" : annexFsckParams d)
@ -196,7 +196,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
Nothing -> go rmt $ do Nothing -> go rmt $ do
program <- programPath program <- fromOsPath <$> programPath
void $ batchCommand program $ void $ batchCommand program $
[ Param "fsck" [ Param "fsck"
-- avoid downloading files -- avoid downloading files

31
Assistant/Threads/Merger.hs
View file

@ -24,8 +24,7 @@ import qualified Git
import qualified Git.Branch import qualified Git.Branch
import qualified Git.Ref import qualified Git.Ref
import qualified Command.Sync import qualified Command.Sync
import qualified Utility.OsString as OS
import qualified System.FilePath.ByteString as P
{- This thread watches for changes to .git/refs/, and handles incoming {- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -} - pushes. -}
@ -33,7 +32,7 @@ mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
let gitd = Git.localGitDir g let gitd = Git.localGitDir g
let dir = gitd P.</> "refs" let dir = gitd </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gitd] dir liftIO $ createDirectoryUnder [gitd] dir
let hook a = Just <$> asIO2 (runHandler a) let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange changehook <- hook onChange
@ -43,21 +42,21 @@ mergeThread = namedThread "Merger" $ do
, modifyHook = changehook , modifyHook = changehook
, errHook = errhook , errHook = errhook
} }
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching", fromRawFilePath dir] debug ["watching", fromOsPath dir]
type Handler = FilePath -> Assistant () type Handler t = t -> Assistant ()
{- Runs an action handler. {- Runs an action handler.
- -
- Exceptions are ignored, otherwise a whole thread could be crashed. - Exceptions are ignored, otherwise a whole thread could be crashed.
-} -}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus = runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -} {- Called when there's an error with inotify. -}
onErr :: Handler onErr :: Handler String
onErr = giveup onErr = giveup
{- Called when a new branch ref is written, or a branch ref is modified. {- Called when a new branch ref is written, or a branch ref is modified.
@ -66,9 +65,9 @@ onErr = giveup
- ok; it ensures that any changes pushed since the last time the assistant - ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in. - ran are merged in.
-} -}
onChange :: Handler onChange :: Handler OsPath
onChange file onChange file
| ".lock" `isSuffixOf` file = noop | literalOsPath ".lock" `OS.isSuffixOf` file = noop
| isAnnexBranch file = do | isAnnexBranch file = do
branchChanged branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
@ -112,7 +111,7 @@ onChange file
- to the second branch, which should be merged into it? -} - to the second branch, which should be merged into it? -}
isRelatedTo :: Git.Ref -> Git.Ref -> Bool isRelatedTo :: Git.Ref -> Git.Ref -> Bool
isRelatedTo x y isRelatedTo x y
| basex /= takeDirectory basex ++ "/" ++ basey = False | basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False
| "/synced/" `isInfixOf` Git.fromRef x = True | "/synced/" `isInfixOf` Git.fromRef x = True
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True | "refs/remotes/" `isPrefixOf` Git.fromRef x = True
| otherwise = False | otherwise = False
@ -120,12 +119,12 @@ isRelatedTo x y
basex = Git.fromRef $ Git.Ref.base x basex = Git.fromRef $ Git.Ref.base x
basey = Git.fromRef $ Git.Ref.base y basey = Git.fromRef $ Git.Ref.base y
isAnnexBranch :: FilePath -> Bool isAnnexBranch :: OsPath -> Bool
isAnnexBranch f = n `isSuffixOf` f isAnnexBranch f = n `isSuffixOf` fromOsPath f
where where
n = '/' : Git.fromRef Annex.Branch.name n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref fileToBranch :: OsPath -> Git.Ref
fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" </> toOsPath base
where where
base = Prelude.last $ split "/refs/" f base = Prelude.last $ split "/refs/" (fromOsPath f)

10
Assistant/Threads/MountWatcher.hs
View file

@ -138,12 +138,12 @@ pollingThread urlrenderer = go =<< liftIO currentMountPoints
handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
handleMounts urlrenderer wasmounted nowmounted = handleMounts urlrenderer wasmounted nowmounted =
mapM_ (handleMount urlrenderer . mnt_dir) $ mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $
S.toList $ newMountPoints wasmounted nowmounted S.toList $ newMountPoints wasmounted nowmounted
handleMount :: UrlRenderer -> FilePath -> Assistant () handleMount :: UrlRenderer -> OsPath -> Assistant ()
handleMount urlrenderer dir = do handleMount urlrenderer dir = do
debug ["detected mount of", dir] debug ["detected mount of", fromOsPath dir]
rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo) rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
=<< remotesUnder dir =<< remotesUnder dir
mapM_ (fsckNudge urlrenderer . Just) rs mapM_ (fsckNudge urlrenderer . Just) rs
@ -157,7 +157,7 @@ handleMount urlrenderer dir = do
- at startup time, or may have changed (it could even be a different - at startup time, or may have changed (it could even be a different
- repository at the same remote location..) - repository at the same remote location..)
-} -}
remotesUnder :: FilePath -> Assistant [Remote] remotesUnder :: OsPath -> Assistant [Remote]
remotesUnder dir = do remotesUnder dir = do
repotop <- liftAnnex $ fromRepo Git.repoPath repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList rs <- liftAnnex remoteList
@ -169,7 +169,7 @@ remotesUnder dir = do
return $ mapMaybe snd $ filter fst pairs return $ mapMaybe snd $ filter fst pairs
where where
checkremote repotop r = case Remote.localpath r of checkremote repotop r = case Remote.localpath r of
Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) -> Just p | dirContains dir (absPathFrom repotop p) ->
(,) <$> pure True <*> updateRemote r (,) <$> pure True <*> updateRemote r
_ -> return (False, Just r) _ -> return (False, Just r)

2
Assistant/Threads/PairListener.hs
View file

@ -121,7 +121,7 @@ pairReqReceived False urlrenderer msg = do
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do pairAckReceived True (Just pip) msg cache = do
stopSending pip stopSending pip
repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir liftIO $ setupAuthorizedKeys msg repodir
finishedLocalPairing msg (inProgressSshKeyPair pip) finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg startSending pip PairDone $ multicastPairMsg

2
Assistant/Threads/RemoteControl.hs
View file

@ -28,7 +28,7 @@ import qualified Data.Set as S
remoteControlThread :: NamedThread remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do remoteControlThread = namedThread "RemoteControl" $ do
program <- liftIO programPath program <- liftIO $ fromOsPath <$> programPath
(cmd, params) <- liftIO $ toBatchCommand (cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon", Param "--foreground"]) (program, [Param "remotedaemon", Param "--foreground"])
let p = proc cmd (toCommand params) let p = proc cmd (toCommand params)

26
Assistant/Threads/SanityChecker.hs
View file

@ -68,7 +68,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
ifM (not <$> liftAnnex (inRepo checkIndexFast)) ifM (not <$> liftAnnex (inRepo checkIndexFast))
( do ( do
debug ["corrupt index file found at startup; removing and restaging"] debug ["corrupt index file found at startup; removing and restaging"]
liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile liftAnnex $ inRepo $ removeWhenExistsWith removeFile . indexFile
{- Normally the startup scan avoids re-staging files, {- Normally the startup scan avoids re-staging files,
- but with the index deleted, everything needs to be - but with the index deleted, everything needs to be
- restaged. -} - restaged. -}
@ -82,7 +82,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
- will be automatically regenerated. -} - will be automatically regenerated. -}
unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
debug ["corrupt annex/index file found at startup; removing"] debug ["corrupt annex/index file found at startup; removing"]
liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex liftAnnex $ liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexIndex
{- Fix up ssh remotes set up by past versions of the assistant. -} {- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes liftIO $ fixUpSshRemotes
@ -154,13 +154,13 @@ dailyCheck urlrenderer = do
batchmaker <- liftIO getBatchCommandMaker batchmaker <- liftIO getBatchCommandMaker
-- Find old unstaged symlinks, and add them to git. -- Find old unstaged symlinks, and add them to git.
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False [literalOsPath "."] g
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
forM_ unstaged $ \file -> do forM_ unstaged $ \file -> do
ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file
case ms of case ms of
Just s | toonew (statusChangeTime s) now -> noop Just s | toonew (statusChangeTime s) now -> noop
| isSymbolicLink s -> addsymlink (fromRawFilePath file) ms | isSymbolicLink s -> addsymlink file ms
_ -> noop _ -> noop
liftIO $ void cleanup liftIO $ void cleanup
@ -182,7 +182,7 @@ dailyCheck urlrenderer = do
{- Run git-annex unused once per day. This is run as a separate {- Run git-annex unused once per day. This is run as a separate
- process to stay out of the annex monad and so it can run as a - process to stay out of the annex monad and so it can run as a
- batch job. -} - batch job. -}
program <- liftIO programPath program <- fromOsPath <$> liftIO programPath
let (program', params') = batchmaker (program, [Param "unused"]) let (program', params') = batchmaker (program, [Param "unused"])
void $ liftIO $ boolSystem program' params' void $ liftIO $ boolSystem program' params'
{- Invalidate unused keys cache, and queue transfers of all unused {- Invalidate unused keys cache, and queue transfers of all unused
@ -202,7 +202,7 @@ dailyCheck urlrenderer = do
void $ addAlert $ sanityCheckFixAlert msg void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s Watcher.runHandler Watcher.onAddSymlink file s
insanity $ "found unstaged symlink: " ++ file insanity $ "found unstaged symlink: " ++ fromOsPath file
hourlyCheck :: Assistant () hourlyCheck :: Assistant ()
hourlyCheck = do hourlyCheck = do
@ -222,14 +222,14 @@ hourlyCheck = do
-} -}
checkLogSize :: Int -> Assistant () checkLogSize :: Int -> Assistant ()
checkLogSize n = do checkLogSize n = do
f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs f logs <- liftIO $ listLogs (fromOsPath f)
totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs
when (totalsize > 2 * oneMegabyte) $ do when (totalsize > 2 * oneMegabyte) $ do
debug ["Rotated logs due to size:", show totalsize] debug ["Rotated logs due to size:", show totalsize]
liftIO $ openLog f >>= handleToFd >>= redirLog liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog
when (n < maxLogs + 1) $ do when (n < maxLogs + 1) $ do
df <- liftIO $ getDiskFree $ takeDirectory f df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f
case df of case df of
Just free Just free
| free < fromIntegral totalsize -> | free < fromIntegral totalsize ->
@ -270,5 +270,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
checkRepoExists :: Assistant () checkRepoExists :: Assistant ()
checkRepoExists = do checkRepoExists = do
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $ liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
terminateSelf terminateSelf

22
Assistant/Threads/TransferWatcher.hs
View file

@ -38,26 +38,26 @@ transferWatcherThread = namedThread "TransferWatcher" $ do
, modifyHook = modifyhook , modifyHook = modifyhook
, errHook = errhook , errHook = errhook
} }
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching for transfers"] debug ["watching for transfers"]
type Handler = FilePath -> Assistant () type Handler t = t -> Assistant ()
{- Runs an action handler. {- Runs an action handler.
- -
- Exceptions are ignored, otherwise a whole thread could be crashed. - Exceptions are ignored, otherwise a whole thread could be crashed.
-} -}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus = runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -} {- Called when there's an error with inotify. -}
onErr :: Handler onErr :: Handler String
onErr = giveup onErr = giveup
{- Called when a new transfer information file is written. -} {- Called when a new transfer information file is written. -}
onAdd :: Handler onAdd :: Handler OsPath
onAdd file = case parseTransferFile (toRawFilePath file) of onAdd file = case parseTransferFile file of
Nothing -> noop Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t) Just t -> go t =<< liftAnnex (checkTransfer t)
where where
@ -72,10 +72,10 @@ onAdd file = case parseTransferFile (toRawFilePath file) of
- -
- The only thing that should change in the transfer info is the - The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -} - bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler onModify :: Handler OsPath
onModify file = case parseTransferFile (toRawFilePath file) of onModify file = case parseTransferFile file of
Nothing -> noop Nothing -> noop
Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file)) Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where where
go _ Nothing = noop go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $ go t (Just newinfo) = alterTransferInfo t $
@ -87,8 +87,8 @@ watchesTransferSize :: Bool
watchesTransferSize = modifyTracked watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -} {- Called when a transfer information file is removed. -}
onDel :: Handler onDel :: Handler OsPath
onDel file = case parseTransferFile (toRawFilePath file) of onDel file = case parseTransferFile file of
Nothing -> noop Nothing -> noop
Just t -> do Just t -> do
debug [ "transfer finishing:", show t] debug [ "transfer finishing:", show t]

4
Assistant/Threads/UpgradeWatcher.hs
View file

@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
, modifyHook = changed , modifyHook = changed
, delDirHook = changed , delDirHook = changed
} }
let dir = fromRawFilePath (parentDir (toRawFilePath flagfile)) let dir = parentDir flagfile
let depth = length (splitPath dir) + 1 let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
@ -57,7 +57,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
void $ swapMVar mvar Started void $ swapMVar mvar Started
return r return r
changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant () changedFile :: UrlRenderer -> MVar WatcherState -> OsPath -> OsPath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar flagfile file _status changedFile urlrenderer mvar flagfile file _status
| flagfile /= file = noop | flagfile /= file = noop
| otherwise = do | otherwise = do

106
Assistant/Threads/Watcher.hs
View file

@ -42,6 +42,7 @@ import Git.FilePath
import Config.GitConfig import Config.GitConfig
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Logs.Location import Logs.Location
import qualified Utility.OsString as OS
import qualified Database.Keys import qualified Database.Keys
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import qualified Utility.Lsof as Lsof import qualified Utility.Lsof as Lsof
@ -94,16 +95,16 @@ runWatcher = do
delhook <- hook onDel delhook <- hook onDel
addsymlinkhook <- hook onAddSymlink addsymlinkhook <- hook onAddSymlink
deldirhook <- hook onDelDir deldirhook <- hook onDelDir
errhook <- hook onErr errhook <- asIO2 onErr
let hooks = mkWatchHooks let hooks = mkWatchHooks
{ addHook = addhook { addHook = addhook
, delHook = delhook , delHook = delhook
, addSymlinkHook = addsymlinkhook , addSymlinkHook = addsymlinkhook
, delDirHook = deldirhook , delDirHook = deldirhook
, errHook = errhook , errHook = Just errhook
} }
scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
h <- liftIO $ watchDir "." ignored scanevents hooks startup h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup
debug [ "watching", "."] debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it, {- Let the DirWatcher thread run until signalled to pause it,
@ -138,9 +139,8 @@ startupScan scanner = do
top <- liftAnnex $ fromRepo Git.repoPath top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top] (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top]
forM_ fs $ \f -> do forM_ fs $ \f -> do
let f' = fromRawFilePath f liftAnnex $ onDel' f
liftAnnex $ onDel' f' maybe noop recordChange =<< madeChange f RmChange
maybe noop recordChange =<< madeChange f' RmChange
void $ liftIO cleanup void $ liftIO cleanup
liftAnnex $ showAction "started" liftAnnex $ showAction "started"
@ -157,30 +157,31 @@ startupScan scanner = do
{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking {- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
- at the entire .git directory. Does not include .gitignores. -} - at the entire .git directory. Does not include .gitignores. -}
ignored :: FilePath -> Bool ignored :: OsPath -> Bool
ignored = ig . takeFileName ignored = ig . takeFileName
where where
ig ".git" = True ig f
ig ".gitignore" = True | f == literalOsPath ".git" = True
ig ".gitattributes" = True | f == literalOsPath ".gitignore" = True
| f == literalOsPath ".gitattributes" = True
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
ig ".DS_Store" = True | f == literlosPath ".DS_Store" = True
#endif #endif
ig _ = False | otherwise = False
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file)) unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
( noChange ( noChange
, a , a
) )
type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change) type Handler = OsPath -> Maybe FileStatus -> Assistant (Maybe Change)
{- Runs an action handler, and if there was a change, adds it to the ChangeChan. {- Runs an action handler, and if there was a change, adds it to the ChangeChan.
- -
- Exceptions are ignored, otherwise a whole watcher thread could be crashed. - Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-} -}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler :: Handler -> OsPath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus r <- tryIO <~> handler (normalize file) filestatus
case r of case r of
@ -189,7 +190,7 @@ runHandler handler file filestatus = void $ do
Right (Just change) -> recordChange change Right (Just change) -> recordChange change
where where
normalize f normalize f
| "./" `isPrefixOf` file = drop 2 f | literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f
| otherwise = f | otherwise = f
shouldRestage :: DaemonStatus -> Bool shouldRestage :: DaemonStatus -> Bool
@ -201,34 +202,34 @@ onAddFile symlinkssupported f fs =
where where
addassociatedfile key file = addassociatedfile key file =
Database.Keys.addAssociatedFile key Database.Keys.addAssociatedFile key
=<< inRepo (toTopFilePath (toRawFilePath file)) =<< inRepo (toTopFilePath file)
samefilestatus key file status = do samefilestatus key file status = do
cache <- Database.Keys.getInodeCaches key cache <- Database.Keys.getInodeCaches key
curr <- withTSDelta $ \delta -> curr <- withTSDelta $ \delta ->
liftIO $ toInodeCache delta (toRawFilePath file) status liftIO $ toInodeCache delta file status
case (cache, curr) of case (cache, curr) of
(_, Just c) -> elemInodeCaches c cache (_, Just c) -> elemInodeCaches c cache
([], Nothing) -> return True ([], Nothing) -> return True
_ -> return False _ -> return False
contentchanged oldkey file = do contentchanged oldkey file = do
Database.Keys.removeAssociatedFile oldkey Database.Keys.removeAssociatedFile oldkey
=<< inRepo (toTopFilePath (toRawFilePath file)) =<< inRepo (toTopFilePath file)
unlessM (inAnnex oldkey) $ unlessM (inAnnex oldkey) $
logStatus NoLiveUpdate oldkey InfoMissing logStatus NoLiveUpdate oldkey InfoMissing
addlink file key = do addlink file key = do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key) madeChange file $ LinkChange (Just key)
onAddFile' onAddFile'
:: (Key -> FilePath -> Annex ()) :: (Key -> OsPath -> Annex ())
-> (Key -> FilePath -> Annex ()) -> (Key -> OsPath -> Annex ())
-> (FilePath -> Key -> Assistant (Maybe Change)) -> (OsPath -> Key -> Assistant (Maybe Change))
-> (Key -> FilePath -> FileStatus -> Annex Bool) -> (Key -> OsPath -> FileStatus -> Annex Bool)
-> Bool -> Bool
-> Handler -> Handler
onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do
v <- liftAnnex $ catKeyFile (toRawFilePath file) v <- liftAnnex $ catKeyFile file
case (v, fs) of case (v, fs) of
(Just key, Just filestatus) -> (Just key, Just filestatus) ->
ifM (liftAnnex $ samefilestatus key file filestatus) ifM (liftAnnex $ samefilestatus key file filestatus)
@ -242,13 +243,13 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
, noChange , noChange
) )
, guardSymlinkStandin (Just key) $ do , guardSymlinkStandin (Just key) $ do
debug ["changed", file] debug ["changed", fromOsPath file]
liftAnnex $ contentchanged key file liftAnnex $ contentchanged key file
pendingAddChange file pendingAddChange file
) )
_ -> unlessIgnored file $ _ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do guardSymlinkStandin Nothing $ do
debug ["add", file] debug ["add", fromOsPath file]
pendingAddChange file pendingAddChange file
where where
{- On a filesystem without symlinks, we'll get changes for regular {- On a filesystem without symlinks, we'll get changes for regular
@ -258,8 +259,7 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
guardSymlinkStandin mk a guardSymlinkStandin mk a
| symlinkssupported = a | symlinkssupported = a
| otherwise = do | otherwise = do
linktarget <- liftAnnex $ getAnnexLinkTarget $ linktarget <- liftAnnex $ getAnnexLinkTarget file
toRawFilePath file
case linktarget of case linktarget of
Nothing -> a Nothing -> a
Just lt -> do Just lt -> do
@ -275,21 +275,20 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo
-} -}
onAddSymlink :: Handler onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do onAddSymlink file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file') linktarget <- liftIO $ catchMaybeIO $
kv <- liftAnnex (lookupKey file') R.readSymbolicLink (fromOsPath file)
kv <- liftAnnex (lookupKey file)
onAddSymlink' linktarget kv file filestatus onAddSymlink' linktarget kv file filestatus
where
file' = toRawFilePath file
onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
onAddSymlink' linktarget mk file filestatus = go mk onAddSymlink' linktarget mk file filestatus = go mk
where where
go (Just key) = do go (Just key) = do
link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key)
if linktarget == Just link if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus then ensurestaged (Just link) =<< getDaemonStatus
else do else do
liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $ liftAnnex $ replaceWorkTreeFile file $
makeAnnexLink link makeAnnexLink link
addLink file link (Just key) addLink file link (Just key)
-- other symlink, not git-annex -- other symlink, not git-annex
@ -315,33 +314,32 @@ onAddSymlink' linktarget mk file filestatus = go mk
ensurestaged Nothing _ = noChange ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -} {- For speed, tries to reuse the existing blob for symlink target. -}
addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change) addLink :: OsPath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do addLink file link mk = do
debug ["add symlink", file] debug ["add symlink", fromOsPath file]
liftAnnex $ do liftAnnex $ do
v <- catObjectDetails $ Ref $ encodeBS $ ':':file v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file
case v of case v of
Just (currlink, sha, _type) Just (currlink, sha, _type)
| L.fromStrict link == currlink -> | L.fromStrict link == currlink ->
stageSymlink (toRawFilePath file) sha stageSymlink file sha
_ -> stageSymlink (toRawFilePath file) _ -> stageSymlink file =<< hashSymlink link
=<< hashSymlink link
madeChange file $ LinkChange mk madeChange file $ LinkChange mk
onDel :: Handler onDel :: Handler
onDel file _ = do onDel file _ = do
debug ["file deleted", file] debug ["file deleted", fromOsPath file]
liftAnnex $ onDel' file liftAnnex $ onDel' file
madeChange file RmChange madeChange file RmChange
onDel' :: FilePath -> Annex () onDel' :: OsPath -> Annex ()
onDel' file = do onDel' file = do
topfile <- inRepo (toTopFilePath (toRawFilePath file)) topfile <- inRepo (toTopFilePath file)
withkey $ flip Database.Keys.removeAssociatedFile topfile withkey $ flip Database.Keys.removeAssociatedFile topfile
Annex.Queue.addUpdateIndex =<< Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file)) inRepo (Git.UpdateIndex.unstageFile file)
where where
withkey a = maybe noop a =<< catKeyFile (toRawFilePath file) withkey a = maybe noop a =<< catKeyFile file
{- A directory has been deleted, or moved, so tell git to remove anything {- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time, - that was inside it from its cache. Since it could reappear at any time,
@ -351,23 +349,21 @@ onDel' file = do
- pairing up renamed files when the directory was renamed. -} - pairing up renamed files when the directory was renamed. -}
onDelDir :: Handler onDelDir :: Handler
onDelDir dir _ = do onDelDir dir _ = do
debug ["directory deleted", dir] debug ["directory deleted", fromOsPath dir]
(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir] (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir]
let fs' = map fromRawFilePath fs
liftAnnex $ mapM_ onDel' fs' liftAnnex $ mapM_ onDel' fs
-- Get the events queued up as fast as possible, so the -- Get the events queued up as fast as possible, so the
-- committer sees them all in one block. -- committer sees them all in one block.
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
recordChanges $ map (\f -> Change now f RmChange) fs' recordChanges $ map (\f -> Change now f RmChange) fs
void $ liftIO clean void $ liftIO clean
noChange noChange
{- Called when there's an error with inotify or kqueue. -} {- Called when there's an error with inotify or kqueue. -}
onErr :: Handler onErr :: String -> Maybe FileStatus -> Assistant ()
onErr msg _ = do onErr msg _ = do
liftAnnex $ warning (UnquotedString msg) liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ warningAlert "watcher" msg void $ addAlert $ warningAlert "watcher" msg
noChange

18
Assistant/Threads/WebApp.hs
View file

@ -62,7 +62,7 @@ webAppThread
-> Maybe (IO Url) -> Maybe (IO Url)
-> Maybe HostName -> Maybe HostName
-> Maybe PortNumber -> Maybe PortNumber
-> Maybe (Url -> FilePath -> IO ()) -> Maybe (Url -> OsPath -> IO ())
-> NamedThread -> NamedThread
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
listenhost' <- if isJust listenhost listenhost' <- if isJust listenhost
@ -89,15 +89,13 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
, return app , return app
) )
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do
hClose h hClose h
go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing go tlssettings addr webapp tmpfile Nothing
else do else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
go tlssettings addr webapp go tlssettings addr webapp htmlshim (Just urlfile)
(fromRawFilePath htmlshim)
(Just urlfile)
where where
-- The webapp thread does not wait for the startupSanityCheckThread -- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while -- to finish, so that the user interface remains responsive while
@ -105,8 +103,8 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
thread = namedThreadUnchecked "WebApp" thread = namedThreadUnchecked "WebApp"
getreldir getreldir
| noannex = return Nothing | noannex = return Nothing
| otherwise = Just <$> | otherwise = Just . fromOsPath <$>
(relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath)) (relHome =<< absPath =<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile maybe noop (`writeFileProtected` url) urlfile
@ -131,6 +129,8 @@ getTlsSettings = do
cert <- fromRepo gitAnnexWebCertificate cert <- fromRepo gitAnnexWebCertificate
privkey <- fromRepo gitAnnexWebPrivKey privkey <- fromRepo gitAnnexWebPrivKey
ifM (liftIO $ allM doesFileExist [cert, privkey]) ifM (liftIO $ allM doesFileExist [cert, privkey])
( return $ Just $ TLS.tlsSettings cert privkey ( return $ Just $ TLS.tlsSettings
(fromOsPath cert)
(fromOsPath privkey)
, return Nothing , return Nothing
) )

2
Assistant/TransferSlots.hs
View file

@ -174,7 +174,7 @@ genTransfer t info = case transferRemote info of
AssociatedFile Nothing -> noop AssociatedFile Nothing -> noop
AssociatedFile (Just af) -> void $ AssociatedFile (Just af) -> void $
addAlert $ makeAlertFiller True $ addAlert $ makeAlertFiller True $
transferFileAlert direction True (fromRawFilePath af) transferFileAlert direction True (fromOsPath af)
unless isdownload $ unless isdownload $
handleDrops handleDrops
("object uploaded to " ++ show remote) ("object uploaded to " ++ show remote)

8
Assistant/Types/Changes.hs
View file

@ -34,12 +34,12 @@ newChangePool = atomically newTList
data Change data Change
= Change = Change
{ changeTime :: UTCTime { changeTime :: UTCTime
, _changeFile :: FilePath , _changeFile :: OsPath
, changeInfo :: ChangeInfo , changeInfo :: ChangeInfo
} }
| PendingAddChange | PendingAddChange
{ changeTime ::UTCTime { changeTime ::UTCTime
, _changeFile :: FilePath , _changeFile :: OsPath
} }
| InProcessAddChange | InProcessAddChange
{ changeTime ::UTCTime { changeTime ::UTCTime
@ -55,10 +55,10 @@ changeInfoKey (AddKeyChange k) = Just k
changeInfoKey (LinkChange (Just k)) = Just k changeInfoKey (LinkChange (Just k)) = Just k
changeInfoKey _ = Nothing changeInfoKey _ = Nothing
changeFile :: Change -> FilePath changeFile :: Change -> OsPath
changeFile (Change _ f _) = f changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f changeFile (PendingAddChange _ f) = f
changeFile (InProcessAddChange _ ld) = fromOsPath $ keyFilename $ keySource ld changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True isPendingAddChange (PendingAddChange {}) = True

6
Assistant/Unused.hs
View file

@ -34,7 +34,7 @@ describeUnusedWhenBig = describeUnused' True
- than the remaining free disk space, or more than 1/10th the total - than the remaining free disk space, or more than 1/10th the total
- disk space being unused keys all suggest a problem. -} - disk space being unused keys all suggest a problem. -}
describeUnused' :: Bool -> Assistant (Maybe TenseText) describeUnused' :: Bool -> Assistant (Maybe TenseText)
describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog (literalOsPath "")
where where
go m = do go m = do
let num = M.size m let num = M.size m
@ -64,13 +64,13 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
sumkeysize s k = s + fromMaybe 0 (fromKey keySize k) sumkeysize s k = s + fromMaybe 0 (fromKey keySize k)
forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath forpath a = inRepo $ liftIO . a . fromOsPath . Git.repoPath
{- With a duration, expires all unused files that are older. {- With a duration, expires all unused files that are older.
- With Nothing, expires *all* unused files. -} - With Nothing, expires *all* unused files. -}
expireUnused :: Maybe Duration -> Assistant () expireUnused :: Maybe Duration -> Assistant ()
expireUnused duration = do expireUnused duration = do
m <- liftAnnex $ readUnusedLog "" m <- liftAnnex $ readUnusedLog (literalOsPath "")
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
let oldkeys = M.keys $ M.filter (tooold now) m let oldkeys = M.keys $ M.filter (tooold now) m
forM_ oldkeys $ \k -> do forM_ oldkeys $ \k -> do

126
Assistant/Upgrade.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Assistant.Upgrade where module Assistant.Upgrade where
@ -42,10 +43,10 @@ import qualified Annex.Url as Url hiding (download)
import Utility.Tuple import Utility.Tuple
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified Utility.OsString as OS
import Data.Either import Data.Either
import qualified Data.Map as M import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
{- Upgrade without interaction in the webapp. -} {- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant () unattendedUpgrade :: Assistant ()
@ -89,12 +90,12 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
hook <- asIO1 $ distributionDownloadComplete d dest cleanup hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook s) } { transferHook = M.insert k hook (transferHook s) }
maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t) maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
=<< liftAnnex (remoteFromUUID webUUID) =<< liftAnnex (remoteFromUUID webUUID)
startTransfer t startTransfer t
k = mkKey $ const $ distributionKey d k = mkKey $ const $ distributionKey d
u = distributionUrl d u = distributionUrl d
f = takeFileName u ++ " (for upgrade)" f = takeFileName (toOsPath u) <> literalOsPath " (for upgrade)"
t = Transfer t = Transfer
{ transferDirection = Download { transferDirection = Download
, transferUUID = webUUID , transferUUID = webUUID
@ -110,7 +111,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
- -
- Verifies the content of the downloaded key. - Verifies the content of the downloaded key.
-} -}
distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant () distributionDownloadComplete :: GitAnnexDistribution -> OsPath -> Assistant () -> Transfer -> Assistant ()
distributionDownloadComplete d dest cleanup t distributionDownloadComplete d dest cleanup t
| transferDirection t == Download = do | transferDirection t == Download = do
debug ["finished downloading git-annex distribution"] debug ["finished downloading git-annex distribution"]
@ -120,11 +121,11 @@ distributionDownloadComplete d dest cleanup t
where where
k = mkKey $ const $ distributionKey d k = mkKey $ const $ distributionKey d
fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Nothing -> return $ Just (fromRawFilePath f) Nothing -> return $ Just f
Just b -> case Types.Backend.verifyKeyContent b of Just b -> case Types.Backend.verifyKeyContent b of
Nothing -> return $ Just (fromRawFilePath f) Nothing -> return $ Just f
Just verifier -> ifM (verifier k f) Just verifier -> ifM (verifier k f)
( return $ Just (fromRawFilePath f) ( return $ Just f
, return Nothing , return Nothing
) )
go f = do go f = do
@ -142,7 +143,7 @@ distributionDownloadComplete d dest cleanup t
- and unpack the new distribution next to it (in a versioned directory). - and unpack the new distribution next to it (in a versioned directory).
- Then update the programFile to point to the new version. - Then update the programFile to point to the new version.
-} -}
upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant () upgradeToDistribution :: OsPath -> Assistant () -> OsPath -> Assistant ()
upgradeToDistribution newdir cleanup distributionfile = do upgradeToDistribution newdir cleanup distributionfile = do
liftIO $ createDirectoryIfMissing True newdir liftIO $ createDirectoryIfMissing True newdir
(program, deleteold) <- unpack (program, deleteold) <- unpack
@ -156,92 +157,92 @@ upgradeToDistribution newdir cleanup distributionfile = do
postUpgrade url postUpgrade url
where where
changeprogram program = liftIO $ do changeprogram program = liftIO $ do
unlessM (boolSystem program [Param "version"]) $ unlessM (boolSystem (fromOsPath program) [Param "version"]) $
giveup "New git-annex program failed to run! Not using." giveup "New git-annex program failed to run! Not using."
pf <- programFile pf <- programFile
liftIO $ writeFile pf program liftIO $ writeFile (fromOsPath pf) (fromOsPath program)
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
{- OS X uses a dmg, so mount it, and copy the contents into place. -} {- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation olddir <- oldVersionLocation
withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) (toOsPath (toRawFilePath "git-annex.upgrade")) $ \tmpdir -> do withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
void $ boolSystem "hdiutil" void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile [ Param "attach", File distributionfile
, Param "-mountpoint", File tmpdir , Param "-mountpoint", File (fromOsPath tmpdir)
] ]
void $ boolSystem "cp" void $ boolSystem "cp"
[ Param "-R" [ Param "-R"
, File $ tmpdir </> installBase </> "Contents" , File $ fromOsPath $ tmpdir </> toOsPath installBase </> literalOsPath "Contents"
, File $ newdir , File $ newdir
] ]
void $ boolSystem "hdiutil" void $ boolSystem "hdiutil"
[ Param "eject" [ Param "eject"
, File tmpdir , File (fromOsPath tmpdir)
] ]
sanitycheck newdir sanitycheck newdir
let deleteold = do let deleteold = do
deleteFromManifest $ olddir </> "Contents" </> "MacOS" deleteFromManifest $ toOsPath olddir </> literalOsPath "Contents" </> literalOsPath "MacOS"
makeorigsymlink olddir makeorigsymlink olddir
return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold) return (newdir </> literalOsPath "Contents" </> literalOsPath "MacOS" </> literalOsPath "git-annex", deleteold)
#else #else
{- Linux uses a tarball (so could other POSIX systems), so {- Linux uses a tarball (so could other POSIX systems), so
- untar it (into a temp directory) and move the directory - untar it (into a temp directory) and move the directory
- into place. -} - into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation olddir <- oldVersionLocation
withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
let tarball = tmpdir </> "tar" let tarball = tmpdir </> literalOsPath "tar"
-- Cannot rely on filename extension, and this also -- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent -- avoids problems if tar doesn't support transparent
-- decompression. -- decompression.
void $ boolSystem "sh" void $ boolSystem "sh"
[ Param "-c" [ Param "-c"
, Param $ "zcat < " ++ shellEscape distributionfile ++ , Param $ "zcat < " ++ shellEscape (fromOsPath distributionfile) ++
" > " ++ shellEscape tarball " > " ++ shellEscape (fromOsPath tarball)
] ]
tarok <- boolSystem "tar" tarok <- boolSystem "tar"
[ Param "xf" [ Param "xf"
, Param tarball , Param (fromOsPath tarball)
, Param "--directory", File tmpdir , Param "--directory", File (fromOsPath tmpdir)
] ]
unless tarok $ unless tarok $
giveup $ "failed to untar " ++ distributionfile giveup $ "failed to untar " ++ fromOsPath distributionfile
sanitycheck $ tmpdir </> installBase sanitycheck $ tmpdir </> toOsPath installBase
installby R.rename newdir (tmpdir </> installBase) installby R.rename newdir (tmpdir </> toOsPath installBase)
let deleteold = do let deleteold = do
deleteFromManifest olddir deleteFromManifest olddir
makeorigsymlink olddir makeorigsymlink olddir
return (newdir </> "git-annex", deleteold) return (newdir </> literalOsPath "git-annex", deleteold)
installby a dstdir srcdir = installby a dstdir srcdir =
mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x)) mapM_ (\x -> a (fromOsPath x) (fromOsPath (dstdir </> takeFileName x)))
=<< dirContents (toRawFilePath srcdir) =<< dirContents srcdir
#endif #endif
sanitycheck dir = sanitycheck dir =
unlessM (doesDirectoryExist dir) $ unlessM (doesDirectoryExist dir) $
giveup $ "did not find " ++ dir ++ " in " ++ distributionfile giveup $ "did not find " ++ fromOsPath dir ++ " in " ++ fromOsPath distributionfile
makeorigsymlink olddir = do makeorigsymlink olddir = do
let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase let origdir = parentDir olddir </> toOsPath installBase
removeWhenExistsWith R.removeLink (toRawFilePath origdir) removeWhenExistsWith removeFile origdir
R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir) R.createSymbolicLink (fromOsPath newdir) (fromOsPath origdir)
{- Finds where the old version was installed. -} {- Finds where the old version was installed. -}
oldVersionLocation :: IO FilePath oldVersionLocation :: IO OsPath
oldVersionLocation = readProgramFile >>= \case oldVersionLocation = readProgramFile >>= \case
Nothing -> giveup "Cannot find old distribution bundle; not upgrading." Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
Just pf -> do Just pf -> do
let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf let pdir = parentDir pf
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
let dirs = splitDirectories pdir let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -} {- It will probably be deep inside a git-annex.app directory. -}
let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of let olddir = case findIndex (literalOsPath "git-annex.app" `OS.isPrefixOf`) dirs of
Nothing -> pdir Nothing -> pdir
Just i -> joinPath (take (i + 1) dirs) Just i -> joinPath (take (i + 1) dirs)
#else #else
let olddir = pdir let olddir = pdir
#endif #endif
when (null olddir) $ when (OS.null olddir) $
giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ fromOsPath pdir ++ ")"
return olddir return olddir
{- Finds a place to install the new version. {- Finds a place to install the new version.
@ -251,15 +252,15 @@ oldVersionLocation = readProgramFile >>= \case
- -
- The directory is created. If it already exists, returns Nothing. - The directory is created. If it already exists, returns Nothing.
-} -}
newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath) newVersionLocation :: GitAnnexDistribution -> OsPath -> IO (Maybe OsPath)
newVersionLocation d olddir = newVersionLocation d olddir =
trymkdir newloc $ do trymkdir newloc $ do
home <- myHomeDir home <- myHomeDir
trymkdir (home </> s) $ trymkdir (toOsPath home </> s) $
return Nothing return Nothing
where where
s = installBase ++ "." ++ distributionVersion d s = toOsPath $ installBase ++ "." ++ distributionVersion d
topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir topdir = parentDir olddir
newloc = topdir </> s newloc = topdir </> s
trymkdir dir fallback = trymkdir dir fallback =
(createDirectory dir >> return (Just dir)) (createDirectory dir >> return (Just dir))
@ -277,24 +278,25 @@ installBase = "git-annex." ++
#endif #endif
#endif #endif
deleteFromManifest :: FilePath -> IO () deleteFromManifest :: OsPath -> IO ()
deleteFromManifest dir = do deleteFromManifest dir = do
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest) fs <- map (\f -> dir </> toOsPath f) . lines
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs <$> catchDefaultIO "" (readFile (fromOsPath manifest))
removeWhenExistsWith R.removeLink (toRawFilePath manifest) mapM_ (removeWhenExistsWith removeFile) fs
removeEmptyRecursive (toRawFilePath dir) removeWhenExistsWith removeFile manifest
removeEmptyRecursive dir
where where
manifest = dir </> "git-annex.MANIFEST" manifest = dir </> literalOsPath "git-annex.MANIFEST"
removeEmptyRecursive :: RawFilePath -> IO () removeEmptyRecursive :: OsPath -> IO ()
removeEmptyRecursive dir = do removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir mapM_ removeEmptyRecursive =<< dirContents dir
void $ tryIO $ removeDirectory (fromRawFilePath dir) void $ tryIO $ removeDirectory dir
{- This is a file that the UpgradeWatcher can watch for modifications to {- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded. - detect when git-annex has been upgraded.
-} -}
upgradeFlagFile :: IO FilePath upgradeFlagFile :: IO OsPath
upgradeFlagFile = programPath upgradeFlagFile = programPath
{- Sanity check to see if an upgrade is complete and the program is ready {- Sanity check to see if an upgrade is complete and the program is ready
@ -309,13 +311,13 @@ upgradeSanityCheck = ifM usingDistribution
program <- programPath program <- programPath
untilM (doesFileExist program <&&> nowriter program) $ untilM (doesFileExist program <&&> nowriter program) $
threadDelaySeconds (Seconds 60) threadDelaySeconds (Seconds 60)
boolSystem program [Param "version"] boolSystem (fromOsPath program) [Param "version"]
) )
where where
nowriter f = null nowriter f = null
. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
. map snd3 . map snd3
<$> Lsof.query [f] <$> Lsof.query [fromOsPath f]
usingDistribution :: IO Bool usingDistribution :: IO Bool
usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
@ -324,14 +326,14 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
downloadDistributionInfo = do downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do
let infof = tmpdir </> "info" let infof = tmpdir </> literalOsPath "info"
let sigf = infof ++ ".sig" let sigf = infof <> literalOsPath ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo) <&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf) <&&> verifyDistributionSig gpgcmd sigf)
( parseInfoFile . map decodeBS . fileLines' ( parseInfoFile . map decodeBS . fileLines'
<$> F.readFile' (toOsPath (toRawFilePath infof)) <$> F.readFile' infof
, return Nothing , return Nothing
) )
@ -360,20 +362,20 @@ upgradeSupported = False
- The gpg keyring used to verify the signature is located in - The gpg keyring used to verify the signature is located in
- trustedkeys.gpg, next to the git-annex program. - trustedkeys.gpg, next to the git-annex program.
-} -}
verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool verifyDistributionSig :: GpgCmd -> OsPath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p -> Just p | isAbsolute p ->
withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do withUmask 0o0077 $ withTmpDir (literalOsPath "git-annex-gpg.tmp") $ \gpgtmp -> do
let trustedkeys = takeDirectory p </> "trustedkeys.gpg" let trustedkeys = takeDirectory p </> literalOsPath "trustedkeys.gpg"
boolGpgCmd gpgcmd boolGpgCmd gpgcmd
[ Param "--no-default-keyring" [ Param "--no-default-keyring"
, Param "--no-auto-check-trustdb" , Param "--no-auto-check-trustdb"
, Param "--no-options" , Param "--no-options"
, Param "--homedir" , Param "--homedir"
, File gpgtmp , File (fromOsPath gpgtmp)
, Param "--keyring" , Param "--keyring"
, File trustedkeys , File (fromOsPath trustedkeys)
, Param "--verify" , Param "--verify"
, File sig , File (fromOsPath sig)
] ]
_ -> return False _ -> return False

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

@ -78,7 +78,7 @@ deleteCurrentRepository = dangerPage $ do
sanityVerifierAForm $ SanityVerifier magicphrase sanityVerifierAForm $ SanityVerifier magicphrase
case result of case result of
FormSuccess _ -> liftH $ do FormSuccess _ -> liftH $ do
dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir liftIO $ removeAutoStartFile dir
{- Disable syncing to this repository, and all {- Disable syncing to this repository, and all
@ -89,9 +89,8 @@ deleteCurrentRepository = dangerPage $ do
rs <- syncRemotes <$> getDaemonStatus rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs mapM_ (\r -> changeSyncable (Just r) False) rs
liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir) liftAnnex $ prepareRemoveAnnexDir dir
liftIO $ removeDirectoryRecursive . fromRawFilePath liftIO $ removeDirectoryRecursive =<< absPath dir
=<< absPath (toRawFilePath dir)
redirect ShutdownConfirmedR redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository") _ -> $(widgetFile "configurators/delete/currentrepository")

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

@ -121,7 +121,7 @@ setRepoConfig uuid mremote oldc newc = do
Just t Just t
| T.null t -> noop | T.null t -> noop
| otherwise -> liftAnnex $ do | otherwise -> liftAnnex $ do
let dir = takeBaseName $ T.unpack t let dir = fromOsPath $ takeBaseName $ toOsPath $ T.unpack t
m <- remoteConfigMap m <- remoteConfigMap
case M.lookup uuid m of case M.lookup uuid m of
Nothing -> noop Nothing -> noop
@ -246,8 +246,8 @@ checkAssociatedDirectory cfg (Just r) = do
case repoGroup cfg of case repoGroup cfg of
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> do Just d -> do
top <- fromRawFilePath <$> fromRepo Git.repoPath top <- fromRepo Git.repoPath
createWorkTreeDirectory (toRawFilePath (top </> d)) createWorkTreeDirectory (top </> toOsPath d)
Nothing -> noop Nothing -> noop
_ -> noop _ -> noop

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

@ -81,24 +81,24 @@ checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
checkRepositoryPath p = do checkRepositoryPath p = do
home <- myHomeDir home <- myHomeDir
let basepath = expandTilde home $ T.unpack p let basepath = expandTilde home $ T.unpack p
path <- fromRawFilePath <$> absPath (toRawFilePath basepath) path <- absPath basepath
let parent = fromRawFilePath $ parentDir (toRawFilePath path) let parent = parentDir path
problems <- catMaybes <$> mapM runcheck problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.") [ (return $ path == literalOsPath "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.") , (return $ all isSpace (fromOsPath basepath :: FilePath), "A blank path? Seems unlikely.")
, (doesFileExist path, "A file already exists with that name.") , (doesFileExist path, "A file already exists with that name.")
, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") , (return $ fromOsPath path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.") , (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
, (not <$> canWrite path, "Cannot write a repository there.") , (not <$> canWrite path, "Cannot write a repository there.")
] ]
return $ return $
case headMaybe problems of case headMaybe problems of
Nothing -> Right $ Just $ T.pack basepath Nothing -> Right $ Just $ T.pack $ fromOsPath basepath
Just prob -> Left prob Just prob -> Left prob
where where
runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing ) runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing )
expandTilde home ('~':'/':path) = home </> path expandTilde home ('~':'/':path) = toOsPath home </> toOsPath path
expandTilde _ path = path expandTilde _ path = toOsPath path
{- On first run, if run in the home directory, default to putting it in {- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
@ -110,12 +110,12 @@ checkRepositoryPath p = do
- the user probably wants to put it there. Unless that directory - the user probably wants to put it there. Unless that directory
- contains a git-annex file, in which case the user has probably - contains a git-annex file, in which case the user has probably
- browsed to a directory with git-annex and run it from there. -} - browsed to a directory with git-annex and run it from there. -}
defaultRepositoryPath :: Bool -> IO FilePath defaultRepositoryPath :: Bool -> IO OsPath
defaultRepositoryPath firstrun = do defaultRepositoryPath firstrun = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
home <- myHomeDir home <- myHomeDir
currdir <- liftIO getCurrentDirectory currdir <- liftIO getCurrentDirectory
if home == currdir && firstrun if toOsPath home == currdir && firstrun
then inhome then inhome
else ifM (legit currdir <&&> canWrite currdir) else ifM (legit currdir <&&> canWrite currdir)
( return currdir ( return currdir
@ -130,29 +130,29 @@ defaultRepositoryPath firstrun = do
where where
inhome = ifM osAndroid inhome = ifM osAndroid
( do ( do
home <- myHomeDir home <- toOsPath <$> myHomeDir
let storageshared = home </> "storage" </> "shared" let storageshared = home </> literalOsPath "storage" </> literalOsPath "shared"
ifM (doesDirectoryExist storageshared) ifM (doesDirectoryExist storageshared)
( relHome $ storageshared </> gitAnnexAssistantDefaultDir ( relHome $ storageshared </> gitAnnexAssistantDefaultDir
, return $ "~" </> gitAnnexAssistantDefaultDir , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
) )
, do , do
desktop <- userDesktopDir desktop <- toOsPath <$> userDesktopDir
ifM (doesDirectoryExist desktop <&&> canWrite desktop) ifM (doesDirectoryExist desktop <&&> canWrite desktop)
( relHome $ desktop </> gitAnnexAssistantDefaultDir ( relHome $ desktop </> gitAnnexAssistantDefaultDir
, return $ "~" </> gitAnnexAssistantDefaultDir , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
) )
) )
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
-- Avoid using eg, standalone build's git-annex.linux/ directory -- Avoid using eg, standalone build's git-annex.linux/ directory
-- when run from there. -- when run from there.
legit d = not <$> doesFileExist (d </> "git-annex") legit d = not <$> doesFileExist (d </> literalOsPath "git-annex")
#endif #endif
newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath newRepositoryForm :: OsPath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "") (pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
(Just $ T.pack $ addTrailingPathSeparator defpath) (Just $ T.pack $ fromOsPath $ addTrailingPathSeparator defpath)
let (err, errmsg) = case pathRes of let (err, errmsg) = case pathRes of
FormMissing -> (False, "") FormMissing -> (False, "")
FormFailure l -> (True, concatMap T.unpack l) FormFailure l -> (True, concatMap T.unpack l)
@ -174,17 +174,17 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
case res of case res of
FormSuccess (RepositoryPath p) -> liftH $ FormSuccess (RepositoryPath p) -> liftH $
startFullAssistant (T.unpack p) ClientGroup Nothing startFullAssistant (toOsPath $ T.unpack p) ClientGroup Nothing
_ -> $(widgetFile "configurators/newrepository/first") _ -> $(widgetFile "configurators/newrepository/first")
getAndroidCameraRepositoryR :: Handler () getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR = do getAndroidCameraRepositoryR = do
home <- liftIO myHomeDir home <- liftIO myHomeDir
let dcim = home </> "storage" </> "dcim" let dcim = toOsPath home </> literalOsPath "storage" </> literalOsPath "dcim"
startFullAssistant dcim SourceGroup $ Just addignore startFullAssistant dcim SourceGroup $ Just addignore
where where
addignore = do addignore = do
liftIO $ unlessM (doesFileExist ".gitignore") $ liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $
writeFile ".gitignore" ".thumbnails" writeFile ".gitignore" ".thumbnails"
void $ inRepo $ void $ inRepo $
Git.Command.runBool [Param "add", File ".gitignore"] Git.Command.runBool [Param "add", File ".gitignore"]
@ -195,20 +195,21 @@ getNewRepositoryR :: Handler Html
getNewRepositoryR = postNewRepositoryR getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir home <- toOsPath <$> liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
case res of case res of
FormSuccess (RepositoryPath p) -> do FormSuccess (RepositoryPath p) -> do
let path = T.unpack p let path = toOsPath (T.unpack p)
isnew <- liftIO $ makeRepo path False isnew <- liftIO $ makeRepo path False
u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup) u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
liftIO $ addAutoStartFile path liftIO $ addAutoStartFile path
liftIO $ startAssistant path liftIO $ startAssistant path
askcombine u path askcombine u (fromOsPath path)
_ -> $(widgetFile "configurators/newrepository") _ -> $(widgetFile "configurators/newrepository")
where where
askcombine newrepouuid newrepopath = do askcombine newrepouuid newrepopath = do
newrepo <- liftIO $ relHome newrepopath newrepo' <- liftIO $ relHome (toOsPath newrepopath)
let newrepo = fromOsPath newrepo' :: FilePath
mainrepo <- fromJust . relDir <$> liftH getYesod mainrepo <- fromJust . relDir <$> liftH getYesod
$(widgetFile "configurators/newrepository/combine") $(widgetFile "configurators/newrepository/combine")
@ -222,17 +223,18 @@ immediateSyncRemote r = do
getCombineRepositoryR :: FilePath -> UUID -> Handler Html getCombineRepositoryR :: FilePath -> UUID -> Handler Html
getCombineRepositoryR newrepopath newrepouuid = do getCombineRepositoryR newrepopath newrepouuid = do
liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename liftAssistant . immediateSyncRemote
=<< combineRepos (toOsPath newrepopath) remotename
redirect $ EditRepositoryR $ RepoUUID newrepouuid redirect $ EditRepositoryR $ RepoUUID newrepouuid
where where
remotename = takeFileName newrepopath remotename = fromOsPath $ takeFileName $ toOsPath newrepopath
selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
<$> pure Nothing <$> pure Nothing
<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing <*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
<*> areq textField (bfs "Use this directory on the drive:") <*> areq textField (bfs "Use this directory on the drive:")
(Just $ T.pack gitAnnexAssistantDefaultDir) (Just $ T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
where where
pairs = zip (map describe drives) (map mountPoint drives) pairs = zip (map describe drives) (map mountPoint drives)
describe drive = case diskFree drive of describe drive = case diskFree drive of
@ -246,9 +248,9 @@ selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
] ]
onlywritable = [whamlet|This list only includes drives you can write to.|] onlywritable = [whamlet|This list only includes drives you can write to.|]
removableDriveRepository :: RemovableDrive -> FilePath removableDriveRepository :: RemovableDrive -> OsPath
removableDriveRepository drive = removableDriveRepository drive =
T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive) toOsPath (T.unpack (mountPoint drive)) </> toOsPath (T.unpack (driveRepoPath drive))
{- Adding a removable drive. -} {- Adding a removable drive. -}
getAddDriveR :: Handler Html getAddDriveR :: Handler Html
@ -257,7 +259,7 @@ postAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO driveList removabledrives <- liftIO driveList
writabledrives <- liftIO $ writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives filterM (canWrite . toOsPath . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- liftH $ runFormPostNoToken $ ((res, form), enctype) <- liftH $ runFormPostNoToken $
selectDriveForm (sort writabledrives) selectDriveForm (sort writabledrives)
case res of case res of
@ -277,7 +279,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
mu <- liftIO $ probeUUID dir mu <- liftIO $ probeUUID dir
case mu of case mu of
Nothing -> maybe askcombine isknownuuid Nothing -> maybe askcombine isknownuuid
=<< liftAnnex (probeGCryptRemoteUUID dir) =<< liftAnnex (probeGCryptRemoteUUID $ fromOsPath dir)
Just driveuuid -> isknownuuid driveuuid Just driveuuid -> isknownuuid driveuuid
, newrepo , newrepo
) )
@ -317,19 +319,19 @@ getFinishAddDriveR drive = go
where where
go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
r <- liftAnnex $ addRemote $ r <- liftAnnex $ addRemote $
makeGCryptRemote remotename dir keyid makeGCryptRemote remotename (fromOsPath dir) keyid
return (Types.Remote.uuid r, r) return (Types.Remote.uuid r, r)
go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do go NoRepoKey = checkGCryptRepoEncryption (fromOsPath dir) makeunencrypted makeunencrypted $ do
mu <- liftAnnex $ probeGCryptRemoteUUID dir mu <- liftAnnex $ probeGCryptRemoteUUID (fromOsPath dir)
case mu of case mu of
Just u -> enableexistinggcryptremote u Just u -> enableexistinggcryptremote u
Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported." Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
enableexistinggcryptremote u = do enableexistinggcryptremote u = do
remotename' <- liftAnnex $ getGCryptRemoteName u dir remotename' <- liftAnnex $ getGCryptRemoteName u (fromOsPath dir)
makewith $ const $ do makewith $ const $ do
r <- liftAnnex $ addRemote $ r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
[(Proposed "gitrepo", Proposed dir)] [(Proposed "gitrepo", Proposed (fromOsPath dir))]
return (u, r) return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -} {- Making a new unencrypted repo, or combining with an existing one. -}
makeunencrypted = makewith $ \isnew -> (,) makeunencrypted = makewith $ \isnew -> (,)
@ -347,21 +349,19 @@ getFinishAddDriveR drive = go
liftAnnex $ defaultStandardGroup u TransferGroup liftAnnex $ defaultStandardGroup u TransferGroup
liftAssistant $ immediateSyncRemote r liftAssistant $ immediateSyncRemote r
redirect $ EditNewRepositoryR u redirect $ EditNewRepositoryR u
mountpoint = T.unpack (mountPoint drive) mountpoint = toOsPath $ T.unpack (mountPoint drive)
dir = removableDriveRepository drive dir = removableDriveRepository drive
remotename = takeFileName mountpoint remotename = fromOsPath $ takeFileName mountpoint
{- Each repository is made a remote of the other. {- Each repository is made a remote of the other.
- Next call syncRemote to get them in sync. -} - Next call syncRemote to get them in sync. -}
combineRepos :: FilePath -> String -> Handler Remote combineRepos :: OsPath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do combineRepos dir name = liftAnnex $ do
hostname <- fromMaybe "host" <$> liftIO getHostname hostname <- fromMaybe "host" <$> liftIO getHostname
mylocation <- fromRepo Git.repoLocation mylocation <- fromRepo Git.repoPath
mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile mypath <- liftIO $ relPathDirToFile dir mylocation
(toRawFilePath dir) liftIO $ inDir dir $ void $ makeGitRemote hostname (fromOsPath mypath)
(toRawFilePath mylocation) addRemote $ makeGitRemote name (fromOsPath dir)
liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
addRemote $ makeGitRemote name dir
getEnableDirectoryR :: UUID -> Handler Html getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
@ -396,12 +396,12 @@ genRemovableDrive :: FilePath -> IO RemovableDrive
genRemovableDrive dir = RemovableDrive genRemovableDrive dir = RemovableDrive
<$> getDiskFree dir <$> getDiskFree dir
<*> pure (T.pack dir) <*> pure (T.pack dir)
<*> pure (T.pack gitAnnexAssistantDefaultDir) <*> pure (T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
{- Bootstraps from first run mode to a fully running assistant in a {- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the - repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -} - url to the new webapp. -}
startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler () startFullAssistant :: OsPath -> StandardGroup -> Maybe (Annex ())-> Handler ()
startFullAssistant path repogroup setup = do startFullAssistant path repogroup setup = do
webapp <- getYesod webapp <- getYesod
url <- liftIO $ do url <- liftIO $ do
@ -417,17 +417,17 @@ startFullAssistant path repogroup setup = do
- -
- The directory may be in the process of being created; if so - The directory may be in the process of being created; if so
- the parent directory is checked instead. -} - the parent directory is checked instead. -}
canWrite :: FilePath -> IO Bool canWrite :: OsPath -> IO Bool
canWrite dir = do canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir) tocheck <- ifM (doesDirectoryExist dir)
( return dir ( return dir
, return $ fromRawFilePath $ parentDir $ toRawFilePath dir , return $ parentDir dir
) )
catchBoolIO $ R.fileAccess (toRawFilePath tocheck) False True False catchBoolIO $ R.fileAccess (fromOsPath tocheck) False True False
{- Gets the UUID of the git repo at a location, which may not exist, or {- Gets the UUID of the git repo at a location, which may not exist, or
- not be a git-annex repo. -} - not be a git-annex repo. -}
probeUUID :: FilePath -> IO (Maybe UUID) probeUUID :: OsPath -> IO (Maybe UUID)
probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
u <- getUUID u <- getUUID
return $ if u == NoUUID then Nothing else Just u return $ if u == NoUUID then Nothing else Just u

4
Assistant/WebApp/Configurators/Pairing.hs
View file

@ -72,7 +72,7 @@ getPrepareWormholePairR pairingwith = do
enableTor :: Handler () enableTor :: Handler ()
enableTor = do enableTor = do
gitannex <- liftIO programPath gitannex <- fromOsPath <$> liftIO programPath
(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing (transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing
if ok if ok
-- Reload remotedameon so it's serving the tor hidden -- Reload remotedameon so it's serving the tor hidden
@ -173,7 +173,7 @@ getFinishLocalPairR = postFinishLocalPairR
postFinishLocalPairR :: PairMsg -> Handler Html postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo repodir <- liftH $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
where where

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

@ -23,7 +23,6 @@ import Types.Distribution
import Assistant.Upgrade import Assistant.Upgrade
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm data PrefsForm = PrefsForm
{ diskReserve :: Text { diskReserve :: Text
@ -89,7 +88,7 @@ storePrefs p = do
unsetConfig (annexConfig "numcopies") -- deprecated unsetConfig (annexConfig "numcopies") -- deprecated
setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
here <- fromRawFilePath <$> fromRepo Git.repoPath here <- fromRepo Git.repoPath
liftIO $ if autoStart p liftIO $ if autoStart p
then addAutoStartFile here then addAutoStartFile here
else removeAutoStartFile here else removeAutoStartFile here
@ -110,5 +109,4 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do
inAutoStartFile :: Annex Bool inAutoStartFile :: Annex Bool
inAutoStartFile = do inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath here <- liftIO . absPath =<< fromRepo Git.repoPath
any (`P.equalFilePath` here) . map toRawFilePath any (`equalFilePath` here) <$> liftIO readAutoStartFile
<$> liftIO readAutoStartFile

16
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -76,7 +76,7 @@ mkSshData s = SshData
, sshDirectory = fromMaybe "" $ inputDirectory s , sshDirectory = fromMaybe "" $ inputDirectory s
, sshRepoName = genSshRepoName , sshRepoName = genSshRepoName
(T.unpack $ fromJust $ inputHostname s) (T.unpack $ fromJust $ inputHostname s)
(maybe "" T.unpack $ inputDirectory s) (toOsPath (maybe "" T.unpack $ inputDirectory s))
, sshPort = inputPort s , sshPort = inputPort s
, needsPubKey = False , needsPubKey = False
, sshCapabilities = [] -- untested , sshCapabilities = [] -- untested
@ -101,7 +101,7 @@ sshInputAForm hostnamefield d = normalize <$> gen
<*> aopt check_username (bfs "User name") (Just $ inputUsername d) <*> aopt check_username (bfs "User name") (Just $ inputUsername d)
<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d) <*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d)
<*> aopt passwordField (bfs "Password") Nothing <*> aopt passwordField (bfs "Password") Nothing
<*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory d) <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack $ fromOsPath gitAnnexAssistantDefaultDir) $ inputDirectory d)
<*> areq intField (bfs "Port") (Just $ inputPort d) <*> areq intField (bfs "Port") (Just $ inputPort d)
authmethods :: [(Text, AuthMethod)] authmethods :: [(Text, AuthMethod)]
@ -389,13 +389,13 @@ sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinpu
v <- getCachedCred login v <- getCachedCred login
liftIO $ case v of liftIO $ case v of
Nothing -> go [passwordprompts 0] Nothing Nothing -> go [passwordprompts 0] Nothing
Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do
hClose h hClose h
writeFileProtected (fromOsPath passfile) pass writeFileProtected passfile pass
environ <- getEnvironment environ <- getEnvironment
let environ' = addEntries let environ' = addEntries
[ ("SSH_ASKPASS", program) [ ("SSH_ASKPASS", fromOsPath program)
, (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile) , (sshAskPassEnv, fromOsPath passfile)
, ("DISPLAY", ":0") , ("DISPLAY", ":0")
] environ ] environ
go [passwordprompts 1] (Just environ') go [passwordprompts 1] (Just environ')
@ -531,7 +531,7 @@ prepSsh' needsinit origsshdata sshdata keypair a
] ]
, if needsinit then Just (wrapCommand "git annex init") else Nothing , if needsinit then Just (wrapCommand "git annex init") else Nothing
, if needsPubKey origsshdata , if needsPubKey origsshdata
then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) (toOsPath remotedir) . sshPubKey <$> keypair
else Nothing else Nothing
] ]
rsynconly = onlyCapability origsshdata RsyncCapable rsynconly = onlyCapability origsshdata RsyncCapable
@ -602,7 +602,7 @@ postAddRsyncNetR = do
|] |]
go sshinput = do go sshinput = do
let reponame = genSshRepoName "rsync.net" let reponame = genSshRepoName "rsync.net"
(maybe "" T.unpack $ inputDirectory sshinput) (toOsPath (maybe "" T.unpack $ inputDirectory sshinput))
prepRsyncNet sshinput reponame $ \sshdata -> inpage $ prepRsyncNet sshinput reponame $ \sshdata -> inpage $
checkExistingGCrypt sshdata $ do checkExistingGCrypt sshdata $ do

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

@ -51,7 +51,7 @@ postConfigUnusedR = page "Unused files" (Just Configuration) $ do
redirect ConfigurationR redirect ConfigurationR
_ -> do _ -> do
munuseddesc <- liftAssistant describeUnused munuseddesc <- liftAssistant describeUnused
ts <- liftAnnex $ dateUnusedLog "" ts <- liftAnnex $ dateUnusedLog (literalOsPath "")
mlastchecked <- case ts of mlastchecked <- case ts of
Nothing -> pure Nothing Nothing -> pure Nothing
Just t -> Just <$> liftIO (durationSince t) Just t -> Just <$> liftIO (durationSince t)

2
Assistant/WebApp/Control.hs
View file

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

4
Assistant/WebApp/DashBoard.hs
View file

@ -45,7 +45,7 @@ transfersDisplay = do
transferPaused info || isNothing (startedTime info) transferPaused info || isNothing (startedTime info)
desc transfer info = case associatedFile info of desc transfer info = case associatedFile info of
AssociatedFile Nothing -> serializeKey $ transferKey transfer AssociatedFile Nothing -> serializeKey $ transferKey transfer
AssociatedFile (Just af) -> fromRawFilePath af AssociatedFile (Just af) -> fromOsPath af
{- Simplifies a list of transfers, avoiding display of redundant {- Simplifies a list of transfers, avoiding display of redundant
- equivalent transfers. -} - equivalent transfers. -}
@ -118,7 +118,7 @@ getFileBrowserR = whenM openFileBrowser redirectBack
- blocking the response to the browser on it. -} - blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool openFileBrowser :: Handler Bool
openFileBrowser = do openFileBrowser = do
path <- fromRawFilePath path <- fromOsPath
<$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath)) <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath))
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
let cmd = "open" let cmd = "open"

6
Assistant/WebApp/Documentation.hs
View file

@ -16,10 +16,10 @@ import BuildFlags
{- The full license info may be included in a file on disk that can {- The full license info may be included in a file on disk that can
- be read in and displayed. -} - be read in and displayed. -}
licenseFile :: IO (Maybe FilePath) licenseFile :: IO (Maybe OsPath)
licenseFile = do licenseFile = do
base <- standaloneAppBase base <- standaloneAppBase
return $ (</> "LICENSE") <$> base return $ (</> literalOsPath "LICENSE") <$> base
getAboutR :: Handler Html getAboutR :: Handler Html
getAboutR = page "About git-annex" (Just About) $ do getAboutR = page "About git-annex" (Just About) $ do
@ -34,7 +34,7 @@ getLicenseR = do
Just f -> customPage (Just About) $ do Just f -> customPage (Just About) $ do
-- no sidebar, just pages of legalese.. -- no sidebar, just pages of legalese..
setTitle "License" setTitle "License"
license <- liftIO $ readFile f license <- liftIO $ readFile (fromOsPath f)
$(widgetFile "documentation/license") $(widgetFile "documentation/license")
getRepoGroupR :: Handler Html getRepoGroupR :: Handler Html

14
Assistant/WebApp/OtherRepos.hs
View file

@ -15,7 +15,6 @@ import Assistant.WebApp.Page
import Config.Files.AutoStart import Config.Files.AutoStart
import Utility.Yesod import Utility.Yesod
import Assistant.Restart import Assistant.Restart
import qualified Utility.RawFilePath as R
getRepositorySwitcherR :: Handler Html getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do getRepositorySwitcherR = page "Switch repository" Nothing $ do
@ -25,15 +24,16 @@ getRepositorySwitcherR = page "Switch repository" Nothing $ do
listOtherRepos :: IO [(String, String)] listOtherRepos :: IO [(String, String)]
listOtherRepos = do listOtherRepos = do
dirs <- readAutoStartFile dirs <- readAutoStartFile
pwd <- R.getCurrentDirectory pwd <- getCurrentDirectory
gooddirs <- filterM isrepo $ gooddirs <- filterM isrepo $
filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs filter (\d -> not $ d `dirContains` pwd) dirs
names <- mapM relHome gooddirs names <- mapM relHome gooddirs
return $ sort $ zip names gooddirs return $ sort $ zip (map fromOsPath names) (map fromOsPath gooddirs)
where where
isrepo d = doesDirectoryExist (d </> ".git") isrepo d = doesDirectoryExist (d </> literalOsPath ".git")
getSwitchToRepositoryR :: FilePath -> Handler Html getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do getSwitchToRepositoryR repo = do
liftIO $ addAutoStartFile repo -- make this the new default repo let repo' = toOsPath repo
redirect =<< liftIO (newAssistantUrl repo) liftIO $ addAutoStartFile repo' -- make this the new default repo
redirect =<< liftIO (newAssistantUrl repo')

10
Command/Assistant.hs
View file

@ -79,11 +79,11 @@ autoStart o = do
dirs <- liftIO readAutoStartFile dirs <- liftIO readAutoStartFile
when (null dirs) $ do when (null dirs) $ do
f <- autoStartFile f <- autoStartFile
giveup $ "Nothing listed in " ++ f giveup $ "Nothing listed in " ++ fromOsPath f
program <- programPath program <- fromOsPath <$> programPath
haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice" haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice"
pids <- forM dirs $ \d -> do pids <- forM dirs $ \d -> do
putStrLn $ "git-annex autostart in " ++ d putStrLn $ "git-annex autostart in " ++ fromOsPath d
mpid <- catchMaybeIO $ go haveionice program d mpid <- catchMaybeIO $ go haveionice program d
if foregroundDaemonOption (daemonOptions o) if foregroundDaemonOption (daemonOptions o)
then return mpid then return mpid
@ -128,9 +128,9 @@ autoStart o = do
autoStop :: IO () autoStop :: IO ()
autoStop = do autoStop = do
dirs <- liftIO readAutoStartFile dirs <- liftIO readAutoStartFile
program <- programPath program <- fromOsPath <$> programPath
forM_ dirs $ \d -> do forM_ dirs $ \d -> do
putStrLn $ "git-annex autostop in " ++ d putStrLn $ "git-annex autostop in " ++ fromOsPath d
tryIO (setCurrentDirectory d) >>= \case tryIO (setCurrentDirectory d) >>= \case
Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"]) Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"])
( putStrLn "ok" ( putStrLn "ok"

37
Command/WebApp.hs
View file

@ -86,15 +86,15 @@ start' allowauto o = do
listenPort' <- if isJust (listenPort o) listenPort' <- if isJust (listenPort o)
then pure (listenPort o) then pure (listenPort o)
else annexPort <$> Annex.getGitConfig else annexPort <$> Annex.getGitConfig
ifM (checkpid <&&> checkshim (fromRawFilePath f)) ifM (checkpid <&&> checkshim f)
( if isJust (listenAddress o) || isJust (listenPort o) ( if isJust (listenAddress o) || isJust (listenPort o)
then giveup "The assistant is already running, so --listen and --port cannot be used." then giveup "The assistant is already running, so --listen and --port cannot be used."
else do else do
url <- liftIO . readFile . fromRawFilePath url <- liftIO . readFile . fromOsPath
=<< fromRepo gitAnnexUrlFile =<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress' liftIO $ if isJust listenAddress'
then putStrLn url then putStrLn url
else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing else liftIO $ openBrowser browser f url Nothing Nothing
, do , do
startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $ startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $
\origout origerr url htmlshim -> \origout origerr url htmlshim ->
@ -104,11 +104,11 @@ start' allowauto o = do
) )
checkpid = do checkpid = do
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile) liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f checkshim f = liftIO $ doesFileExist f
notinitialized = do notinitialized = do
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex" liftIO $ cannotStartIn (Git.repoPath g) "repository has not been initialized by git-annex"
liftIO $ firstRun o liftIO $ firstRun o
{- If HOME is a git repo, even if it's initialized for git-annex, {- If HOME is a git repo, even if it's initialized for git-annex,
@ -117,7 +117,7 @@ notHome :: Annex Bool
notHome = do notHome = do
g <- Annex.gitRepo g <- Annex.gitRepo
d <- liftIO $ absPath (Git.repoPath g) d <- liftIO $ absPath (Git.repoPath g)
h <- liftIO $ absPath . toRawFilePath =<< myHomeDir h <- liftIO $ absPath . toOsPath =<< myHomeDir
return (d /= h) return (d /= h)
{- When run without a repo, start the first available listed repository in {- When run without a repo, start the first available listed repository in
@ -136,14 +136,15 @@ startNoRepo o = go =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
go ds go ds
Right state -> void $ Annex.eval state $ do Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $ whenM (fromRepo Git.repoIsLocalBare) $
giveup $ d ++ " is a bare git repository, cannot run the webapp in it" giveup $ fromOsPath d ++ " is a bare git repository, cannot run the webapp in it"
r <- callCommandAction $ r <- callCommandAction $
start' False o start' False o
quiesce False quiesce False
return r return r
cannotStartIn :: FilePath -> String -> IO () cannotStartIn :: OsPath -> String -> IO ()
cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason cannotStartIn d reason = warningIO $
"unable to start webapp in repository " ++ fromOsPath d ++ ": " ++ reason
{- Run the webapp without a repository, which prompts the user, makes one, {- Run the webapp without a repository, which prompts the user, makes one,
- changes to it, starts the regular assistant, and redirects the - changes to it, starts the regular assistant, and redirects the
@ -203,12 +204,12 @@ firstRun o = do
(Just $ sendurlback v) (Just $ sendurlback v)
sendurlback v _origout _origerr url _htmlshim = putMVar v url sendurlback v _origout _origerr url _htmlshim = putMVar v url
openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do openBrowser mcmd htmlshim realurl outh errh = do
htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim) htmlshim' <- absPath htmlshim
openBrowser' mcmd htmlshim' realurl outh errh openBrowser' mcmd htmlshim' realurl outh errh
openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser' :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser' mcmd htmlshim realurl outh errh = openBrowser' mcmd htmlshim realurl outh errh =
ifM osAndroid ifM osAndroid
{- Android does not support file:// urls well, but neither {- Android does not support file:// urls well, but neither
@ -220,7 +221,7 @@ openBrowser' mcmd htmlshim realurl outh errh =
where where
runbrowser url = do runbrowser url = do
let p = case mcmd of let p = case mcmd of
Just c -> proc c [url] Just c -> proc (fromOsPath c) [url]
Nothing -> Nothing ->
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
browserProc url browserProc url
@ -228,8 +229,8 @@ openBrowser' mcmd htmlshim realurl outh errh =
{- Windows hack to avoid using the full path, {- Windows hack to avoid using the full path,
- which might contain spaces that cause problems - which might contain spaces that cause problems
- for browserProc. -} - for browserProc. -}
(browserProc (takeFileName htmlshim)) (browserProc (fromOsPath (takeFileName htmlshim)))
{ cwd = Just (takeDirectory htmlshim) } { cwd = Just (fromOsPath (takeDirectory htmlshim)) }
#endif #endif
hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
hFlush stdout hFlush stdout
@ -245,8 +246,8 @@ openBrowser' mcmd htmlshim realurl outh errh =
hPutStrLn (fromMaybe stderr errh) "failed to start web browser" hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
{- web.browser is a generic git config setting for a web browser program -} {- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath webBrowser :: Git.Repo -> Maybe OsPath
webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser" webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser"
fileUrl :: FilePath -> String fileUrl :: OsPath -> String
fileUrl file = "file://" ++ file fileUrl file = "file://" ++ fromOsPath file

6
Utility/WebApp.hs
View file

@ -185,11 +185,9 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params =
{- Creates a html shim file that's used to redirect into the webapp, {- Creates a html shim file that's used to redirect into the webapp,
- to avoid exposing the secret token when launching the web browser. -} - to avoid exposing the secret token when launching the web browser. -}
writeHtmlShim :: String -> String -> FilePath -> IO () writeHtmlShim :: String -> String -> OsPath -> IO ()
writeHtmlShim title url file = writeHtmlShim title url file =
viaTmp (writeFileProtected) viaTmp (writeFileProtected) file (genHtmlShim title url)
(toOsPath $ toRawFilePath file)
(genHtmlShim title url)
genHtmlShim :: String -> String -> String genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines genHtmlShim title url = unlines