diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 94874e5d42..77b761b6de 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -556,12 +556,10 @@ gitAnnexCredsDir r = addTrailingPathSeparator $ {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp - when HTTPS is enabled -} -gitAnnexWebCertificate :: Git.Repo -> FilePath -gitAnnexWebCertificate r = fromOsPath $ - gitAnnexDir r literalOsPath "certificate.pem" -gitAnnexWebPrivKey :: Git.Repo -> FilePath -gitAnnexWebPrivKey r = fromOsPath $ - gitAnnexDir r literalOsPath "privkey.pem" +gitAnnexWebCertificate :: Git.Repo -> OsPath +gitAnnexWebCertificate r = gitAnnexDir r literalOsPath "certificate.pem" +gitAnnexWebPrivKey :: Git.Repo -> OsPath +gitAnnexWebPrivKey r = gitAnnexDir r literalOsPath "privkey.pem" {- .git/annex/feeds/ is used to record per-key (url) state by importfeed -} gitAnnexFeedStateDir :: Git.Repo -> OsPath @@ -686,8 +684,8 @@ gitAnnexRemotesDir r = addTrailingPathSeparator $ {- This is the base directory name used by the assistant when making - repositories, by default. -} -gitAnnexAssistantDefaultDir :: FilePath -gitAnnexAssistantDefaultDir = "annex" +gitAnnexAssistantDefaultDir :: OsPath +gitAnnexAssistantDefaultDir = literalOsPath "annex" gitAnnexSimDir :: Git.Repo -> OsPath gitAnnexSimDir r = addTrailingPathSeparator $ diff --git a/Annex/Path.hs b/Annex/Path.hs index f607c81351..802ab9c043 100644 --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -53,7 +53,7 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR" else pure "git-annex" p <- if isAbsolute (toOsPath exe) then return exe - else fromMaybe exe <$> readProgramFile + else maybe exe fromOsPath <$> readProgramFile maybe cannotFindProgram return =<< searchPath p reqgitannex name @@ -62,10 +62,10 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR" isgitannex = flip M.notMember otherMulticallCommands {- Returns the path for git-annex that is recorded in the programFile. -} -readProgramFile :: IO (Maybe FilePath) +readProgramFile :: IO (Maybe OsPath) readProgramFile = catchDefaultIO Nothing $ do programfile <- programFile - headMaybe . lines <$> readFile (fromOsPath programfile) + fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile) cannotFindProgram :: IO a cannotFindProgram = do diff --git a/Assistant.hs b/Assistant.hs index 2e50a79ff1..41553c6949 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -62,40 +62,39 @@ import qualified Utility.Debug as Debug import Network.Socket (HostName, PortNumber) stopDaemon :: Annex () -stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath - =<< fromRepo gitAnnexPidFile +stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile {- Starts the daemon. If the daemon is run in the foreground, once it's - running, can start the browser. - - startbrowser is passed the url and html shim file, as well as the original - 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 Annex.changeState $ \s -> s { Annex.daemon = True } enableInteractiveBranchAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) - let logfd = handleToFd =<< openLog (fromRawFilePath logfile) + let logfd = handleToFd =<< openLog (fromOsPath logfile) if foreground then do origout <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdOutput origerr <- liftIO $ catchMaybeIO $ fdToHandle =<< dup stdError - let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile)) + let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) start undaemonize $ case startbrowser of Nothing -> Nothing Just a -> Just $ a origout origerr else do - git_annex <- liftIO programPath + git_annex <- fromOsPath <$> liftIO programPath 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 -- Windows doesn't daemonize, but does redirect output to the -- 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) ifM (liftIO $ isNothing <$> getEnv flag) ( liftIO $ withNullHandle $ \nullh -> do - loghandle <- openLog (fromRawFilePath logfile) + loghandle <- openLog (fromOsPath logfile) e <- getEnvironment cmd <- programPath ps <- getArgs @@ -117,7 +116,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid exitWith exitcode - , start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $ + , start (Utility.Daemon.foreground (Just (fromOsPath pidfile))) $ case startbrowser of Nothing -> Nothing Just a -> Just $ a Nothing Nothing @@ -128,7 +127,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost listenport star checkCanWatch dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile liftIO $ daemonize $ flip runAssistant (go webappwaiter) =<< newAssistantData st dstatus diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index ead791dcc9..aba957958f 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -395,7 +395,7 @@ fileAlert msg files = (activityAlert Nothing shortfiles) maxfilesshown = 10 (!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 where diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 4a20850fa0..a1a98b2e98 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -15,14 +15,14 @@ import Data.Time.Clock import Control.Concurrent.STM {- 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) noChange :: Assistant (Maybe Change) noChange = return Nothing {- 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) {- Gets all unhandled changes. diff --git a/Assistant/Install.hs b/Assistant/Install.hs index db34000672..c1827ae541 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Assistant.Install where @@ -31,8 +32,8 @@ import Utility.Android import System.PosixCompat.Files (ownerExecuteMode) import qualified Data.ByteString.Char8 as S8 -standaloneAppBase :: IO (Maybe FilePath) -standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" +standaloneAppBase :: IO (Maybe OsPath) +standaloneAppBase = fmap toOsPath <$> getEnv "GIT_ANNEX_APP_BASE" {- The standalone app does not have an installation process. - 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 ) where - go Nothing = installFileManagerHooks "git-annex" + go Nothing = installFileManagerHooks (literalOsPath "git-annex") go (Just base) = do - let program = base "git-annex" + let program = base literalOsPath "git-annex" programfile <- programFile - createDirectoryIfMissing True $ - fromRawFilePath (parentDir (toRawFilePath programfile)) - writeFile programfile program + createDirectoryIfMissing True (parentDir programfile) + writeFile (fromOsPath programfile) (fromOsPath program) #ifdef darwin_HOST_OS autostartfile <- userAutoStart osxAutoStartLabel @@ -67,24 +67,24 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") ( do -- Integration with the Termux:Boot app. home <- myHomeDir - let bootfile = home ".termux" "boot" "git-annex" + let bootfile = toOsPath home literalOsPath ".termux" literalOsPath "boot" literalOsPath "git-annex" unlessM (doesFileExist bootfile) $ do createDirectoryIfMissing True (takeDirectory bootfile) - writeFile bootfile "git-annex assistant --autostart" + writeFile (fromOsPath bootfile) "git-annex assistant --autostart" , do menufile <- desktopMenuFilePath "git-annex" <$> userDataDir icondir <- iconDir <$> userDataDir - installMenu program menufile base icondir + installMenu (fromOsPath program) menufile base icondir autostartfile <- autoStartPath "git-annex" <$> userConfigDir - installAutoStart program autostartfile + installAutoStart (fromOsPath program) autostartfile ) #endif 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 ++ "\"" - installWrapper (toRawFilePath (sshdir "git-annex-shell")) $ + installWrapper (sshdir literalOsPath "git-annex-shell") $ [ shebang , "set -e" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" @@ -93,7 +93,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") , rungitannexshell "$@" , "fi" ] - installWrapper (toRawFilePath (sshdir "git-annex-wrapper")) $ + installWrapper (sshdir literalOsPath "git-annex-wrapper") $ [ shebang , "set -e" , runshell "\"$@\"" @@ -101,47 +101,46 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") installFileManagerHooks program -installWrapper :: RawFilePath -> [String] -> IO () +installWrapper :: OsPath -> [String] -> IO () installWrapper file content = do let content' = map encodeBS content - curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file) + curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file when (curr /= content') $ do - createDirectoryIfMissing True (fromRawFilePath (parentDir file)) - viaTmp F.writeFile' (toOsPath file) $ - linesFile' (S8.unlines content') + createDirectoryIfMissing True (parentDir file) + viaTmp F.writeFile' file $ linesFile' (S8.unlines content') modifyFileMode file $ addModes [ownerExecuteMode] -installFileManagerHooks :: FilePath -> IO () +installFileManagerHooks :: OsPath -> IO () #ifdef linux_HOST_OS installFileManagerHooks program = unlessM osAndroid $ do let actions = ["get", "drop", "undo"] -- Gnome - nautilusScriptdir <- (\d -> d "nautilus" "scripts") <$> userDataDir + nautilusScriptdir <- (\d -> d literalOsPath "nautilus" literalOsPath "scripts") <$> userDataDir createDirectoryIfMissing True nautilusScriptdir forM_ actions $ genNautilusScript nautilusScriptdir -- KDE userdata <- userDataDir - let kdeServiceMenusdir = userdata "kservices5" "ServiceMenus" + let kdeServiceMenusdir = userdata literalOsPath "kservices5" literalOsPath "ServiceMenus" createDirectoryIfMissing True kdeServiceMenusdir - writeFile (kdeServiceMenusdir "git-annex.desktop") + writeFile (fromOsPath (kdeServiceMenusdir literalOsPath "git-annex.desktop")) (kdeDesktopFile actions) where genNautilusScript scriptdir action = - installscript (toRawFilePath (scriptdir scriptname action)) $ unlines + installscript (scriptdir toOsPath (scriptname action)) $ unlines [ shebang , autoaddedcomment - , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" + , "exec " ++ fromOsPath program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" ] scriptname action = "git-annex " ++ action installscript f c = whenM (safetoinstallscript f) $ do - writeFile (fromRawFilePath f) c + writeFile (fromOsPath f) c modifyFileMode f $ addModes [ownerExecuteMode] safetoinstallscript f = catchDefaultIO True $ elem (encodeBS autoaddedcomment) . fileLines' - <$> F.readFile' (toOsPath f) + <$> F.readFile' f autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" autoaddedmsg = "Automatically added by git-annex, do not edit." @@ -167,7 +166,7 @@ installFileManagerHooks program = unlessM osAndroid $ do , "Icon=git-annex" , unwords [ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&" - , program + , fromOsPath program , command , "--notify-start --notify-finish -- \"$1\"'" , "false" -- this becomes $0 in sh, so unused diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index 47bf5488a6..b027d6a53a 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -28,7 +28,7 @@ import Config {- Makes a new git repository. Or, if a git repository already - exists, returns False. -} -makeRepo :: FilePath -> Bool -> IO Bool +makeRepo :: OsPath -> Bool -> IO Bool makeRepo path bare = ifM (probeRepoExists path) ( return False , do @@ -41,19 +41,19 @@ makeRepo path bare = ifM (probeRepoExists path) where baseparams = [Param "init", Param "--quiet"] params - | bare = baseparams ++ [Param "--bare", File path] - | otherwise = baseparams ++ [File path] + | bare = baseparams ++ [Param "--bare", File (fromOsPath path)] + | otherwise = baseparams ++ [File (fromOsPath path)] {- 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 state <- Annex.new =<< Git.Config.read - =<< Git.Construct.fromPath (toRawFilePath dir) + =<< Git.Construct.fromPath dir Annex.eval state $ a `finally` quiesce True {- 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' desc mgroup {- Initialize the master branch, so things that expect @@ -94,6 +94,6 @@ initRepo' desc mgroup = unlessM isInitialized $ do Annex.Branch.commit =<< Annex.Branch.commitMessage {- Checks if a git repo exists at a location. -} -probeRepoExists :: FilePath -> IO Bool +probeRepoExists :: OsPath -> IO Bool probeRepoExists dir = isJust <$> - catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir)) + catchDefaultIO Nothing (Git.Construct.checkForRepo dir) diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 69402e2e3d..f4468bc07c 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -22,11 +22,11 @@ import qualified Data.Text as T {- Authorized keys are set up before pairing is complete, so that the other - side can immediately begin syncing. -} -setupAuthorizedKeys :: PairMsg -> FilePath -> IO () +setupAuthorizedKeys :: PairMsg -> OsPath -> IO () setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of Left err -> giveup err Right pubkey -> do - absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir) + absdir <- absPath repodir unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $ giveup "failed setting up ssh authorized keys" @@ -66,7 +66,7 @@ pairMsgToSshData msg = do { sshHostName = T.pack hostname , sshUserName = Just (T.pack $ remoteUserName d) , sshDirectory = T.pack dir - , sshRepoName = genSshRepoName hostname dir + , sshRepoName = genSshRepoName hostname (toOsPath dir) , sshPort = 22 , needsPubKey = True , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index 4c37227c8d..c024f93e6f 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -31,11 +31,9 @@ import qualified Data.Text as T #endif import qualified Utility.Lsof as Lsof import Utility.ThreadScheduler -import qualified Utility.RawFilePath as R +import qualified Utility.OsString as OS 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 - repair. If that fails, pops up an alert. -} @@ -98,7 +96,7 @@ runRepair u mrmt destructiverepair = do thisrepopath <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath) a <- liftAnnex $ mkrepair $ - repair fsckresults (Just (fromRawFilePath thisrepopath)) + repair fsckresults (Just (fromOsPath thisrepopath)) liftIO $ catchBoolIO a repair fsckresults referencerepo = do @@ -110,7 +108,7 @@ runRepair u mrmt destructiverepair = do backgroundfsck params = liftIO $ void $ async $ do 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 - writing to it. This strongly suggests it is a stale lock file. @@ -135,26 +133,26 @@ repairStaleGitLocks r = do repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir islock f - | "gc.pid" `S.isInfixOf` f = False - | ".lock" `S.isSuffixOf` f = True - | P.takeFileName f == "MERGE_HEAD" = True + | literalOsPath "gc.pid" `OS.isInfixOf` f = False + | literalOsPath ".lock" `OS.isSuffixOf` f = True + | takeFileName f == literalOsPath "MERGE_HEAD" = True | otherwise = False -repairStaleLocks :: [RawFilePath] -> Assistant () +repairStaleLocks :: [OsPath] -> Assistant () repairStaleLocks lockfiles = go =<< getsizes where getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles 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 waitforit "to check stale git lock file" l' <- getsizes if l' == l - then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l + then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l else go l' , do waitforit "for git lock file writer" diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs index 65b6fe64aa..658d1ddf18 100644 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -18,7 +18,6 @@ import Utility.NotificationBroadcaster import Utility.Url import Utility.Url.Parse import Utility.PID -import qualified Utility.RawFilePath as R import qualified Git.Construct import qualified Git.Config import qualified Annex @@ -41,8 +40,8 @@ import Network.URI prepRestart :: Assistant () prepRestart = do liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread - liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile) - liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile) + liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexPidFile) {- To finish a restart, send a global redirect to the new url - to any web browsers that are displaying the webapp. @@ -66,21 +65,21 @@ terminateSelf = runRestart :: Assistant URLString 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 - a gitAnnexUrlFile. Waits for the assistant to be up and listening for - connections by testing the url. -} -newAssistantUrl :: FilePath -> IO URLString +newAssistantUrl :: OsPath -> IO URLString newAssistantUrl repo = do startAssistant repo geturl where geturl = do - r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo) - waiturl $ fromRawFilePath $ gitAnnexUrlFile r + r <- Git.Config.read =<< Git.Construct.fromPath repo + waiturl $ gitAnnexUrlFile r waiturl urlfile = do - v <- tryIO $ readFile urlfile + v <- tryIO $ readFile (fromOsPath urlfile) case v of Left _ -> delayed $ waiturl urlfile 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 - done. -} -startAssistant :: FilePath -> IO () +startAssistant :: OsPath -> IO () startAssistant repo = void $ forkIO $ do - program <- programPath - let p = (proc program ["assistant"]) { cwd = Just repo } + program <- fromOsPath <$> programPath + let p = (proc program ["assistant"]) { cwd = Just (fromOsPath repo) } withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 69f2462557..420e1efdab 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -20,6 +20,7 @@ import Git.Remote import Utility.SshHost import Utility.Process.Transcript import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import Data.Text (Text) import qualified Data.Text as T @@ -103,7 +104,7 @@ parseSshUrl u { sshHostName = T.pack host , sshUserName = if null user then Nothing else Just $ T.pack user , sshDirectory = T.pack dir - , sshRepoName = genSshRepoName host dir + , sshRepoName = genSshRepoName host (toOsPath dir) -- dummy values, cannot determine from url , sshPort = 22 , needsPubKey = True @@ -120,10 +121,10 @@ parseSshUrl u fromssh = mkdata . break (== '/') {- Generates a git remote name, like host_dir or host -} -genSshRepoName :: String -> FilePath -> String +genSshRepoName :: String -> OsPath -> String genSshRepoName host dir - | null dir = makeLegalName host - | otherwise = makeLegalName $ host ++ "_" ++ dir + | OS.null dir = makeLegalName host + | otherwise = makeLegalName $ host ++ "_" ++ fromOsPath dir {- The output of ssh, including both stdout and stderr. -} sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool) @@ -151,13 +152,13 @@ validateSshPubKey pubkey where (ssh, keytype) = separate (== '-') prefix -addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool +addAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO Bool addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] {- Should only be used within the same process that added the line; - 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 let keyline = authorizedKeysLine gitannexshellonly dir pubkey sshdir <- sshDir @@ -173,7 +174,7 @@ removeAuthorizedKeys gitannexshellonly dir pubkey = do - The ~/.ssh/git-annex-shell wrapper script is created if not already - present. -} -addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String +addAuthorizedKeysCommand :: Bool -> OsPath -> SshPubKey -> String addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" [ "mkdir -p ~/.ssh" , intercalate "; " @@ -204,14 +205,14 @@ addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" ] runshell var = "exec git-annex-shell -c \"" ++ var ++ "\"" -authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String +authorizedKeysLine :: Bool -> OsPath -> SshPubKey -> String authorizedKeysLine gitannexshellonly dir pubkey | gitannexshellonly = limitcommand ++ pubkey {- TODO: Locking down rsync is difficult, requiring a rather - long perl script. -} | otherwise = pubkey 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. -} genSshKeyPair :: IO SshKeyPair diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 85692767e7..6ffc9eb0e1 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -67,11 +67,10 @@ commitThread = namedThread "Committer" $ do liftAnnex $ do -- Clean up anything left behind by a previous process -- on unclean shutdown. - void $ liftIO $ tryIO $ removeDirectoryRecursive - (fromRawFilePath lockdowndir) + void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir void $ createAnnexDirectory lockdowndir waitChangeTime $ \(changes, time) -> do - readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $ + readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $ simplifyChanges changes if shouldCommit False time (length readychanges) readychanges then do @@ -276,12 +275,12 @@ commitStaged msg = do - Any pending adds that are not ready yet are put back into the ChangeChan, - 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 let (pending, inprocess) = partition isPendingAddChange incomplete let lockdownconfig = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , hardlinkFileTmpDir = Just lockdowndir , checkWritePerms = True } (postponed, toadd) <- partitionEithers @@ -307,12 +306,13 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret | otherwise = a checkpointerfile change = do - let file = toRawFilePath $ changeFile change + let file = changeFile change mk <- liftIO $ isPointerFile file case mk of Nothing -> return (Right change) Just key -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) liftAnnex $ stagePointerFile file mode =<< hashPointerFile key return $ Left $ Change (changeTime change) @@ -328,7 +328,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret else checkmatcher | otherwise = checkmatcher where - f = toRawFilePath (changeFile change) + f = changeFile change checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) ( return (Left change) , return (Right change) @@ -336,9 +336,9 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret addsmall [] = noop addsmall toadd = liftAnnex $ void $ tryIO $ - forM (map (toRawFilePath . changeFile) toadd) $ \f -> + forM (map changeFile toadd) $ \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 - 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 let cfg = LockDownConfig { lockingFile = False - , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) + , hardlinkFileTmpDir = Just lockdowndir , checkWritePerms = True } if M.null m then forM toadd (addannexed' cfg) else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta + mcache <- liftIO $ genInodeCache (changeFile c) delta case mcache of Nothing -> addannexed' cfg c Just cache -> @@ -376,19 +376,19 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret (mkey, _mcache) <- liftAnnex $ do showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput [])) 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 fastadd :: Change -> Key -> Assistant (Maybe Change) fastadd change key = do let source = keySource $ lockedDown change liftAnnex $ finishIngestUnlocked key source - done change (fromRawFilePath $ keyFilename source) key + done change (keyFilename source) key removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do mks <- forM (filter isRmChange l) $ \c -> - catKeyFile $ toRawFilePath $ changeFile c + catKeyFile $ changeFile c M.fromList . concat <$> mapM mkpairs (catMaybes mks) where 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 logStatus NoLiveUpdate key InfoPresent - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) - stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) + stagePointerFile file mode =<< hashPointerFile key showEndOk 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, - before ingesting it. -} sanitycheck keysource a = do - fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource - ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource + fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource + ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource if deviceID ks == deviceID fs && fileID ks == fileID fs then a else do -- remove the hard link when (contentLocation keysource /= keyFilename keysource) $ - void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource + void $ liftIO $ tryIO $ removeFile $ contentLocation keysource return Nothing {- 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. -} addaction [] a = a - addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $ + addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $ (,) <$> pure True <*> a @@ -440,7 +441,7 @@ handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = ret - - 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 lockdowndir lockdownconfig havelsof delayadd pending inprocess = do maybe noop (liftIO . threadDelaySeconds) delayadd @@ -451,7 +452,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do then S.fromList . map fst3 . filter openwrite <$> findopenfiles (map (keySource . lockedDown) inprocess') 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, - 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 where 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 mkinprocess (c, Just ld) = Just InProcessAddChange @@ -478,7 +480,7 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do <> " still has writers, not adding" -- remove the hard link when (contentLocation ks /= keyFilename ks) $ - void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks + void $ liftIO $ tryIO $ removeFile $ contentLocation ks canceladd _ = noop openwrite (_file, mode, _pid) @@ -498,9 +500,9 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do findopenfiles keysources = ifM crippledFileSystem ( liftIO $ do let segments = segmentXargsUnordered $ - map (fromRawFilePath . keyFilename) keysources + map (fromOsPath . keyFilename) keysources 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 @@ -521,5 +523,5 @@ checkChangeContent change@(Change { changeInfo = i }) = handleDrops "file renamed" present k af [] where f = changeFile change - af = AssociatedFile (Just (toRawFilePath f)) + af = AssociatedFile (Just f) checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index 9f1e03f8d1..97cd4af8bb 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,7 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs when (old /= new) $ do let changedconfigs = new `S.difference` old debug $ "reloading config" : - map (fromRawFilePath . fst) + map (fromOsPath . fst) (S.toList changedconfigs) reloadConfigs new {- Record a commit to get this config @@ -54,10 +54,10 @@ configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs loop new {- 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. -} -configFilesActions :: [(RawFilePath, Assistant ())] +configFilesActions :: [(OsPath, Assistant ())] configFilesActions = [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remotesChanged) @@ -91,5 +91,5 @@ getConfigs :: Assistant Configs getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files) where - files = map (fromRawFilePath . fst) configFilesActions + files = map (fromOsPath . fst) configFilesActions extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index c3dd8acfb5..9b063b5882 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -181,7 +181,7 @@ runActivity urlrenderer activity nowt = do runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant () runActivity' urlrenderer (ScheduledSelfFsck _ d) = do - program <- liftIO programPath + program <- fromOsPath <$> liftIO programPath g <- liftAnnex gitRepo fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do 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 (Just rmt) = void $ case Remote.remoteFsck rmt of Nothing -> go rmt $ do - program <- programPath + program <- fromOsPath <$> programPath void $ batchCommand program $ [ Param "fsck" -- avoid downloading files diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 7b9db70abf..a68d01a94d 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -24,8 +24,7 @@ import qualified Git import qualified Git.Branch import qualified Git.Ref import qualified Command.Sync - -import qualified System.FilePath.ByteString as P +import qualified Utility.OsString as OS {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} @@ -33,7 +32,7 @@ mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo let gitd = Git.localGitDir g - let dir = gitd P. "refs" + let dir = gitd literalOsPath "refs" liftIO $ createDirectoryUnder [gitd] dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange @@ -43,21 +42,21 @@ mergeThread = namedThread "Merger" $ do , modifyHook = changehook , errHook = errhook } - void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id - debug ["watching", fromRawFilePath dir] + void $ liftIO $ watchDir dir (const False) True hooks id + debug ["watching", fromOsPath dir] -type Handler = FilePath -> Assistant () +type Handler t = t -> Assistant () {- Runs an action handler. - - 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 = either (liftIO . print) (const noop) =<< tryIO <~> handler file {- Called when there's an error with inotify. -} -onErr :: Handler +onErr :: Handler String onErr = giveup {- 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 - ran are merged in. -} -onChange :: Handler +onChange :: Handler OsPath onChange file - | ".lock" `isSuffixOf` file = noop + | literalOsPath ".lock" `OS.isSuffixOf` file = noop | isAnnexBranch file = do branchChanged diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case @@ -112,7 +111,7 @@ onChange file - to the second branch, which should be merged into it? -} isRelatedTo :: Git.Ref -> Git.Ref -> Bool isRelatedTo x y - | basex /= takeDirectory basex ++ "/" ++ basey = False + | basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False | "/synced/" `isInfixOf` Git.fromRef x = True | "refs/remotes/" `isPrefixOf` Git.fromRef x = True | otherwise = False @@ -120,12 +119,12 @@ isRelatedTo x y basex = Git.fromRef $ Git.Ref.base x basey = Git.fromRef $ Git.Ref.base y -isAnnexBranch :: FilePath -> Bool -isAnnexBranch f = n `isSuffixOf` f +isAnnexBranch :: OsPath -> Bool +isAnnexBranch f = n `isSuffixOf` fromOsPath f where n = '/' : Git.fromRef Annex.Branch.name -fileToBranch :: FilePath -> Git.Ref -fileToBranch f = Git.Ref $ encodeBS $ "refs" base +fileToBranch :: OsPath -> Git.Ref +fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" toOsPath base where - base = Prelude.last $ split "/refs/" f + base = Prelude.last $ split "/refs/" (fromOsPath f) diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 11997fbd71..eb8e770a8c 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -138,12 +138,12 @@ pollingThread urlrenderer = go =<< liftIO currentMountPoints handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () handleMounts urlrenderer wasmounted nowmounted = - mapM_ (handleMount urlrenderer . mnt_dir) $ + mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: UrlRenderer -> FilePath -> Assistant () +handleMount :: UrlRenderer -> OsPath -> Assistant () handleMount urlrenderer dir = do - debug ["detected mount of", dir] + debug ["detected mount of", fromOsPath dir] rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo) =<< remotesUnder dir 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 - repository at the same remote location..) -} -remotesUnder :: FilePath -> Assistant [Remote] +remotesUnder :: OsPath -> Assistant [Remote] remotesUnder dir = do repotop <- liftAnnex $ fromRepo Git.repoPath rs <- liftAnnex remoteList @@ -169,7 +169,7 @@ remotesUnder dir = do return $ mapMaybe snd $ filter fst pairs where 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 _ -> return (False, Just r) diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 0199b79f84..fe39c62972 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -121,7 +121,7 @@ pairReqReceived False urlrenderer msg = do pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] pairAckReceived True (Just pip) msg cache = do stopSending pip - repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo + repodir <- repoPath <$> liftAnnex gitRepo liftIO $ setupAuthorizedKeys msg repodir finishedLocalPairing msg (inProgressSshKeyPair pip) startSending pip PairDone $ multicastPairMsg diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs index 51f5e4b9b4..bfd888955a 100644 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -28,7 +28,7 @@ import qualified Data.Set as S remoteControlThread :: NamedThread remoteControlThread = namedThread "RemoteControl" $ do - program <- liftIO programPath + program <- liftIO $ fromOsPath <$> programPath (cmd, params) <- liftIO $ toBatchCommand (program, [Param "remotedaemon", Param "--foreground"]) let p = proc cmd (toCommand params) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 563e038e78..f9ff82dadb 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -68,7 +68,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta ifM (not <$> liftAnnex (inRepo checkIndexFast)) ( do 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, - but with the index deleted, everything needs to be - restaged. -} @@ -82,7 +82,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta - will be automatically regenerated. -} unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do 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. -} liftIO $ fixUpSshRemotes @@ -154,13 +154,13 @@ dailyCheck urlrenderer = do batchmaker <- liftIO getBatchCommandMaker -- 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 forM_ unstaged $ \file -> do - ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file + ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink (fromRawFilePath file) ms + | isSymbolicLink s -> addsymlink file ms _ -> noop liftIO $ void cleanup @@ -182,7 +182,7 @@ dailyCheck urlrenderer = do {- 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 - batch job. -} - program <- liftIO programPath + program <- fromOsPath <$> liftIO programPath let (program', params') = batchmaker (program, [Param "unused"]) void $ liftIO $ boolSystem program' params' {- Invalidate unused keys cache, and queue transfers of all unused @@ -202,7 +202,7 @@ dailyCheck urlrenderer = do void $ addAlert $ sanityCheckFixAlert msg addsymlink file s = do Watcher.runHandler Watcher.onAddSymlink file s - insanity $ "found unstaged symlink: " ++ file + insanity $ "found unstaged symlink: " ++ fromOsPath file hourlyCheck :: Assistant () hourlyCheck = do @@ -222,14 +222,14 @@ hourlyCheck = do -} checkLogSize :: Int -> Assistant () checkLogSize n = do - f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs f - totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs + f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile + logs <- liftIO $ listLogs (fromOsPath f) + totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs when (totalsize > 2 * oneMegabyte) $ do debug ["Rotated logs due to size:", show totalsize] - liftIO $ openLog f >>= handleToFd >>= redirLog + liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog when (n < maxLogs + 1) $ do - df <- liftIO $ getDiskFree $ takeDirectory f + df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f case df of Just free | free < fromIntegral totalsize -> @@ -270,5 +270,5 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit checkRepoExists :: Assistant () checkRepoExists = do g <- liftAnnex gitRepo - liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $ + liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ terminateSelf diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index bff9263fb6..0b52e8121f 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -38,26 +38,26 @@ transferWatcherThread = namedThread "TransferWatcher" $ do , modifyHook = modifyhook , 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"] -type Handler = FilePath -> Assistant () +type Handler t = t -> Assistant () {- Runs an action handler. - - 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 = either (liftIO . print) (const noop) =<< tryIO <~> handler file {- Called when there's an error with inotify. -} -onErr :: Handler +onErr :: Handler String onErr = giveup {- Called when a new transfer information file is written. -} -onAdd :: Handler -onAdd file = case parseTransferFile (toRawFilePath file) of +onAdd :: Handler OsPath +onAdd file = case parseTransferFile file of Nothing -> noop Just t -> go t =<< liftAnnex (checkTransfer t) where @@ -72,10 +72,10 @@ onAdd file = case parseTransferFile (toRawFilePath file) of - - The only thing that should change in the transfer info is the - bytesComplete, so that's the only thing updated in the DaemonStatus. -} -onModify :: Handler -onModify file = case parseTransferFile (toRawFilePath file) of +onModify :: Handler OsPath +onModify file = case parseTransferFile file of Nothing -> noop - Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file)) + Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) where go _ Nothing = noop go t (Just newinfo) = alterTransferInfo t $ @@ -87,8 +87,8 @@ watchesTransferSize :: Bool watchesTransferSize = modifyTracked {- Called when a transfer information file is removed. -} -onDel :: Handler -onDel file = case parseTransferFile (toRawFilePath file) of +onDel :: Handler OsPath +onDel file = case parseTransferFile file of Nothing -> noop Just t -> do debug [ "transfer finishing:", show t] diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index 5960a70c32..b474b6d420 100644 --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -46,7 +46,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do , modifyHook = changed , delDirHook = changed } - let dir = fromRawFilePath (parentDir (toRawFilePath flagfile)) + let dir = parentDir flagfile let depth = length (splitPath dir) + 1 let nosubdirs f = length (splitPath f) == depth void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) @@ -57,7 +57,7 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do void $ swapMVar mvar Started 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 | flagfile /= file = noop | otherwise = do diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 37ac9b876e..1e38195cfe 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -42,6 +42,7 @@ import Git.FilePath import Config.GitConfig import Utility.ThreadScheduler import Logs.Location +import qualified Utility.OsString as OS import qualified Database.Keys #ifndef mingw32_HOST_OS import qualified Utility.Lsof as Lsof @@ -94,16 +95,16 @@ runWatcher = do delhook <- hook onDel addsymlinkhook <- hook onAddSymlink deldirhook <- hook onDelDir - errhook <- hook onErr + errhook <- asIO2 onErr let hooks = mkWatchHooks { addHook = addhook , delHook = delhook , addSymlinkHook = addsymlinkhook , delDirHook = deldirhook - , errHook = errhook + , errHook = Just errhook } scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig - h <- liftIO $ watchDir "." ignored scanevents hooks startup + h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup debug [ "watching", "."] {- Let the DirWatcher thread run until signalled to pause it, @@ -138,9 +139,8 @@ startupScan scanner = do top <- liftAnnex $ fromRepo Git.repoPath (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top] forM_ fs $ \f -> do - let f' = fromRawFilePath f - liftAnnex $ onDel' f' - maybe noop recordChange =<< madeChange f' RmChange + liftAnnex $ onDel' f + maybe noop recordChange =<< madeChange f RmChange void $ liftIO cleanup liftAnnex $ showAction "started" @@ -157,30 +157,31 @@ startupScan scanner = do {- Hardcoded ignores, passed to the DirWatcher so it can avoid looking - at the entire .git directory. Does not include .gitignores. -} -ignored :: FilePath -> Bool +ignored :: OsPath -> Bool ignored = ig . takeFileName where - ig ".git" = True - ig ".gitignore" = True - ig ".gitattributes" = True + ig f + | f == literalOsPath ".git" = True + | f == literalOsPath ".gitignore" = True + | f == literalOsPath ".gitattributes" = True #ifdef darwin_HOST_OS - ig ".DS_Store" = True + | f == literlosPath ".DS_Store" = True #endif - ig _ = False + | otherwise = False -unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) -unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file)) +unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change) +unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file) ( noChange , 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. - - 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 r <- tryIO <~> handler (normalize file) filestatus case r of @@ -189,7 +190,7 @@ runHandler handler file filestatus = void $ do Right (Just change) -> recordChange change where normalize f - | "./" `isPrefixOf` file = drop 2 f + | literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f | otherwise = f shouldRestage :: DaemonStatus -> Bool @@ -201,34 +202,34 @@ onAddFile symlinkssupported f fs = where addassociatedfile key file = Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath (toRawFilePath file)) + =<< inRepo (toTopFilePath file) samefilestatus key file status = do cache <- Database.Keys.getInodeCaches key curr <- withTSDelta $ \delta -> - liftIO $ toInodeCache delta (toRawFilePath file) status + liftIO $ toInodeCache delta file status case (cache, curr) of (_, Just c) -> elemInodeCaches c cache ([], Nothing) -> return True _ -> return False contentchanged oldkey file = do Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath (toRawFilePath file)) + =<< inRepo (toTopFilePath file) unlessM (inAnnex oldkey) $ logStatus NoLiveUpdate oldkey InfoMissing addlink file key = do - mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) - liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file) + liftAnnex $ stagePointerFile file mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) onAddFile' - :: (Key -> FilePath -> Annex ()) - -> (Key -> FilePath -> Annex ()) - -> (FilePath -> Key -> Assistant (Maybe Change)) - -> (Key -> FilePath -> FileStatus -> Annex Bool) + :: (Key -> OsPath -> Annex ()) + -> (Key -> OsPath -> Annex ()) + -> (OsPath -> Key -> Assistant (Maybe Change)) + -> (Key -> OsPath -> FileStatus -> Annex Bool) -> Bool -> Handler onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do - v <- liftAnnex $ catKeyFile (toRawFilePath file) + v <- liftAnnex $ catKeyFile file case (v, fs) of (Just key, Just filestatus) -> ifM (liftAnnex $ samefilestatus key file filestatus) @@ -242,13 +243,13 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo , noChange ) , guardSymlinkStandin (Just key) $ do - debug ["changed", file] + debug ["changed", fromOsPath file] liftAnnex $ contentchanged key file pendingAddChange file ) _ -> unlessIgnored file $ guardSymlinkStandin Nothing $ do - debug ["add", file] + debug ["add", fromOsPath file] pendingAddChange file where {- On a filesystem without symlinks, we'll get changes for regular @@ -258,8 +259,7 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo guardSymlinkStandin mk a | symlinkssupported = a | otherwise = do - linktarget <- liftAnnex $ getAnnexLinkTarget $ - toRawFilePath file + linktarget <- liftAnnex $ getAnnexLinkTarget file case linktarget of Nothing -> a Just lt -> do @@ -275,21 +275,20 @@ onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssuppo -} onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do - linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file') - kv <- liftAnnex (lookupKey file') + linktarget <- liftIO $ catchMaybeIO $ + R.readSymbolicLink (fromOsPath file) + kv <- liftAnnex (lookupKey file) onAddSymlink' linktarget kv file filestatus - where - file' = toRawFilePath file onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler onAddSymlink' linktarget mk file filestatus = go mk where go (Just key) = do - link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key + link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key) if linktarget == Just link then ensurestaged (Just link) =<< getDaemonStatus else do - liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $ + liftAnnex $ replaceWorkTreeFile file $ makeAnnexLink link addLink file link (Just key) -- other symlink, not git-annex @@ -315,33 +314,32 @@ onAddSymlink' linktarget mk file filestatus = go mk ensurestaged Nothing _ = noChange {- 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 - debug ["add symlink", file] + debug ["add symlink", fromOsPath file] liftAnnex $ do - v <- catObjectDetails $ Ref $ encodeBS $ ':':file + v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file case v of Just (currlink, sha, _type) | L.fromStrict link == currlink -> - stageSymlink (toRawFilePath file) sha - _ -> stageSymlink (toRawFilePath file) - =<< hashSymlink link + stageSymlink file sha + _ -> stageSymlink file =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler onDel file _ = do - debug ["file deleted", file] + debug ["file deleted", fromOsPath file] liftAnnex $ onDel' file madeChange file RmChange -onDel' :: FilePath -> Annex () +onDel' :: OsPath -> Annex () onDel' file = do - topfile <- inRepo (toTopFilePath (toRawFilePath file)) + topfile <- inRepo (toTopFilePath file) withkey $ flip Database.Keys.removeAssociatedFile topfile Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file)) + inRepo (Git.UpdateIndex.unstageFile file) 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 - 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. -} onDelDir :: Handler onDelDir dir _ = do - debug ["directory deleted", dir] - (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir] - let fs' = map fromRawFilePath fs + debug ["directory deleted", fromOsPath dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir] - liftAnnex $ mapM_ onDel' fs' + liftAnnex $ mapM_ onDel' fs -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - recordChanges $ map (\f -> Change now f RmChange) fs' + recordChanges $ map (\f -> Change now f RmChange) fs void $ liftIO clean noChange {- Called when there's an error with inotify or kqueue. -} -onErr :: Handler +onErr :: String -> Maybe FileStatus -> Assistant () onErr msg _ = do liftAnnex $ warning (UnquotedString msg) void $ addAlert $ warningAlert "watcher" msg - noChange diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index ad7cd13d47..9a65e5bf8c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -62,7 +62,7 @@ webAppThread -> Maybe (IO Url) -> Maybe HostName -> Maybe PortNumber - -> Maybe (Url -> FilePath -> IO ()) + -> Maybe (Url -> OsPath -> IO ()) -> NamedThread webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do listenhost' <- if isJust listenhost @@ -89,15 +89,13 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost , return app ) 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 - go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing + go tlssettings addr webapp tmpfile Nothing else do htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile - go tlssettings addr webapp - (fromRawFilePath htmlshim) - (Just urlfile) + go tlssettings addr webapp htmlshim (Just urlfile) where -- The webapp thread does not wait for the startupSanityCheckThread -- to finish, so that the user interface remains responsive while @@ -105,8 +103,8 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost thread = namedThreadUnchecked "WebApp" getreldir | noannex = return Nothing - | otherwise = Just <$> - (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath)) + | otherwise = Just . fromOsPath <$> + (relHome =<< absPath =<< getAnnex' (fromRepo repoPath)) go tlssettings addr webapp htmlshim urlfile = do let url = myUrl tlssettings webapp addr maybe noop (`writeFileProtected` url) urlfile @@ -131,6 +129,8 @@ getTlsSettings = do cert <- fromRepo gitAnnexWebCertificate privkey <- fromRepo gitAnnexWebPrivKey ifM (liftIO $ allM doesFileExist [cert, privkey]) - ( return $ Just $ TLS.tlsSettings cert privkey + ( return $ Just $ TLS.tlsSettings + (fromOsPath cert) + (fromOsPath privkey) , return Nothing ) diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 9f97764445..af9b06b3f0 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -174,7 +174,7 @@ genTransfer t info = case transferRemote info of AssociatedFile Nothing -> noop AssociatedFile (Just af) -> void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True (fromRawFilePath af) + transferFileAlert direction True (fromOsPath af) unless isdownload $ handleDrops ("object uploaded to " ++ show remote) diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs index 01bcbb4990..b8494ad7a7 100644 --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -34,12 +34,12 @@ newChangePool = atomically newTList data Change = Change { changeTime :: UTCTime - , _changeFile :: FilePath + , _changeFile :: OsPath , changeInfo :: ChangeInfo } | PendingAddChange { changeTime ::UTCTime - , _changeFile :: FilePath + , _changeFile :: OsPath } | InProcessAddChange { changeTime ::UTCTime @@ -55,10 +55,10 @@ changeInfoKey (AddKeyChange k) = Just k changeInfoKey (LinkChange (Just k)) = Just k changeInfoKey _ = Nothing -changeFile :: Change -> FilePath +changeFile :: Change -> OsPath changeFile (Change _ f _) = f changeFile (PendingAddChange _ f) = f -changeFile (InProcessAddChange _ ld) = fromOsPath $ keyFilename $ keySource ld +changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld isPendingAddChange :: Change -> Bool isPendingAddChange (PendingAddChange {}) = True diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index d63a00ca93..4afc0d7047 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -34,7 +34,7 @@ describeUnusedWhenBig = describeUnused' True - than the remaining free disk space, or more than 1/10th the total - disk space being unused keys all suggest a problem. -} describeUnused' :: Bool -> Assistant (Maybe TenseText) -describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" +describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog (literalOsPath "") where go m = do let num = M.size m @@ -64,13 +64,13 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" 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 Nothing, expires *all* unused files. -} expireUnused :: Maybe Duration -> Assistant () expireUnused duration = do - m <- liftAnnex $ readUnusedLog "" + m <- liftAnnex $ readUnusedLog (literalOsPath "") now <- liftIO getPOSIXTime let oldkeys = M.keys $ M.filter (tooold now) m forM_ oldkeys $ \k -> do diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 1440af10d0..df91bb976d 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Assistant.Upgrade where @@ -42,10 +43,10 @@ import qualified Annex.Url as Url hiding (download) import Utility.Tuple import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F +import qualified Utility.OsString as OS import Data.Either import qualified Data.Map as M -import qualified System.FilePath.ByteString as P {- Upgrade without interaction in the webapp. -} unattendedUpgrade :: Assistant () @@ -89,12 +90,12 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> 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) startTransfer t k = mkKey $ const $ distributionKey d u = distributionUrl d - f = takeFileName u ++ " (for upgrade)" + f = takeFileName (toOsPath u) <> literalOsPath " (for upgrade)" t = Transfer { transferDirection = Download , transferUUID = webUUID @@ -110,7 +111,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol - - Verifies the content of the downloaded key. -} -distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant () +distributionDownloadComplete :: GitAnnexDistribution -> OsPath -> Assistant () -> Transfer -> Assistant () distributionDownloadComplete d dest cleanup t | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] @@ -120,11 +121,11 @@ distributionDownloadComplete d dest cleanup t where k = mkKey $ const $ distributionKey d 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 - Nothing -> return $ Just (fromRawFilePath f) + Nothing -> return $ Just f Just verifier -> ifM (verifier k f) - ( return $ Just (fromRawFilePath f) + ( return $ Just f , return Nothing ) go f = do @@ -142,7 +143,7 @@ distributionDownloadComplete d dest cleanup t - and unpack the new distribution next to it (in a versioned directory). - 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 liftIO $ createDirectoryIfMissing True newdir (program, deleteold) <- unpack @@ -156,92 +157,92 @@ upgradeToDistribution newdir cleanup distributionfile = do postUpgrade url where 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." pf <- programFile - liftIO $ writeFile pf program + liftIO $ writeFile (fromOsPath pf) (fromOsPath program) #ifdef darwin_HOST_OS {- OS X uses a dmg, so mount it, and copy the contents into place. -} unpack = liftIO $ do 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" [ Param "attach", File distributionfile - , Param "-mountpoint", File tmpdir + , Param "-mountpoint", File (fromOsPath tmpdir) ] void $ boolSystem "cp" [ Param "-R" - , File $ tmpdir installBase "Contents" + , File $ fromOsPath $ tmpdir toOsPath installBase literalOsPath "Contents" , File $ newdir ] void $ boolSystem "hdiutil" [ Param "eject" - , File tmpdir + , File (fromOsPath tmpdir) ] sanitycheck newdir let deleteold = do - deleteFromManifest $ olddir "Contents" "MacOS" + deleteFromManifest $ toOsPath olddir literalOsPath "Contents" literalOsPath "MacOS" makeorigsymlink olddir - return (newdir "Contents" "MacOS" "git-annex", deleteold) + return (newdir literalOsPath "Contents" literalOsPath "MacOS" literalOsPath "git-annex", deleteold) #else {- Linux uses a tarball (so could other POSIX systems), so - untar it (into a temp directory) and move the directory - into place. -} unpack = liftIO $ do olddir <- oldVersionLocation - withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do - let tarball = tmpdir "tar" + withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do + let tarball = tmpdir literalOsPath "tar" -- Cannot rely on filename extension, and this also -- avoids problems if tar doesn't support transparent -- decompression. void $ boolSystem "sh" [ Param "-c" - , Param $ "zcat < " ++ shellEscape distributionfile ++ - " > " ++ shellEscape tarball + , Param $ "zcat < " ++ shellEscape (fromOsPath distributionfile) ++ + " > " ++ shellEscape (fromOsPath tarball) ] tarok <- boolSystem "tar" [ Param "xf" - , Param tarball - , Param "--directory", File tmpdir + , Param (fromOsPath tarball) + , Param "--directory", File (fromOsPath tmpdir) ] unless tarok $ - giveup $ "failed to untar " ++ distributionfile - sanitycheck $ tmpdir installBase - installby R.rename newdir (tmpdir installBase) + giveup $ "failed to untar " ++ fromOsPath distributionfile + sanitycheck $ tmpdir toOsPath installBase + installby R.rename newdir (tmpdir toOsPath installBase) let deleteold = do deleteFromManifest olddir makeorigsymlink olddir - return (newdir "git-annex", deleteold) + return (newdir literalOsPath "git-annex", deleteold) installby a dstdir srcdir = - mapM_ (\x -> a x (toRawFilePath dstdir P. P.takeFileName x)) - =<< dirContents (toRawFilePath srcdir) + mapM_ (\x -> a (fromOsPath x) (fromOsPath (dstdir takeFileName x))) + =<< dirContents srcdir #endif sanitycheck dir = unlessM (doesDirectoryExist dir) $ - giveup $ "did not find " ++ dir ++ " in " ++ distributionfile + giveup $ "did not find " ++ fromOsPath dir ++ " in " ++ fromOsPath distributionfile makeorigsymlink olddir = do - let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) installBase - removeWhenExistsWith R.removeLink (toRawFilePath origdir) - R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir) + let origdir = parentDir olddir toOsPath installBase + removeWhenExistsWith removeFile origdir + R.createSymbolicLink (fromOsPath newdir) (fromOsPath origdir) {- Finds where the old version was installed. -} -oldVersionLocation :: IO FilePath +oldVersionLocation :: IO OsPath oldVersionLocation = readProgramFile >>= \case Nothing -> giveup "Cannot find old distribution bundle; not upgrading." Just pf -> do - let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf + let pdir = parentDir pf #ifdef darwin_HOST_OS let dirs = splitDirectories pdir {- 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 Just i -> joinPath (take (i + 1) dirs) #else let olddir = pdir #endif - when (null olddir) $ - giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" + when (OS.null olddir) $ + giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ fromOsPath pdir ++ ")" return olddir {- 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. -} -newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath) +newVersionLocation :: GitAnnexDistribution -> OsPath -> IO (Maybe OsPath) newVersionLocation d olddir = trymkdir newloc $ do home <- myHomeDir - trymkdir (home s) $ + trymkdir (toOsPath home s) $ return Nothing where - s = installBase ++ "." ++ distributionVersion d - topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir + s = toOsPath $ installBase ++ "." ++ distributionVersion d + topdir = parentDir olddir newloc = topdir s trymkdir dir fallback = (createDirectory dir >> return (Just dir)) @@ -277,24 +278,25 @@ installBase = "git-annex." ++ #endif #endif -deleteFromManifest :: FilePath -> IO () +deleteFromManifest :: OsPath -> IO () deleteFromManifest dir = do - fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) - mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs - removeWhenExistsWith R.removeLink (toRawFilePath manifest) - removeEmptyRecursive (toRawFilePath dir) + fs <- map (\f -> dir toOsPath f) . lines + <$> catchDefaultIO "" (readFile (fromOsPath manifest)) + mapM_ (removeWhenExistsWith removeFile) fs + removeWhenExistsWith removeFile manifest + removeEmptyRecursive dir where - manifest = dir "git-annex.MANIFEST" + manifest = dir literalOsPath "git-annex.MANIFEST" -removeEmptyRecursive :: RawFilePath -> IO () +removeEmptyRecursive :: OsPath -> IO () removeEmptyRecursive dir = do 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 - detect when git-annex has been upgraded. -} -upgradeFlagFile :: IO FilePath +upgradeFlagFile :: IO OsPath upgradeFlagFile = programPath {- Sanity check to see if an upgrade is complete and the program is ready @@ -309,13 +311,13 @@ upgradeSanityCheck = ifM usingDistribution program <- programPath untilM (doesFileExist program <&&> nowriter program) $ threadDelaySeconds (Seconds 60) - boolSystem program [Param "version"] + boolSystem (fromOsPath program) [Param "version"] ) where nowriter f = null . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) . map snd3 - <$> Lsof.query [f] + <$> Lsof.query [fromOsPath f] usingDistribution :: IO Bool usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" @@ -324,14 +326,14 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) downloadDistributionInfo = do uo <- liftAnnex Url.getUrlOptions gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig - liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do - let infof = tmpdir "info" - let sigf = infof ++ ".sig" + liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do + let infof = tmpdir literalOsPath "info" + let sigf = infof <> literalOsPath ".sig" ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo <&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo) <&&> verifyDistributionSig gpgcmd sigf) ( parseInfoFile . map decodeBS . fileLines' - <$> F.readFile' (toOsPath (toRawFilePath infof)) + <$> F.readFile' infof , return Nothing ) @@ -360,20 +362,20 @@ upgradeSupported = False - The gpg keyring used to verify the signature is located in - trustedkeys.gpg, next to the git-annex program. -} -verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool +verifyDistributionSig :: GpgCmd -> OsPath -> IO Bool verifyDistributionSig gpgcmd sig = readProgramFile >>= \case Just p | isAbsolute p -> - withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do - let trustedkeys = takeDirectory p "trustedkeys.gpg" + withUmask 0o0077 $ withTmpDir (literalOsPath "git-annex-gpg.tmp") $ \gpgtmp -> do + let trustedkeys = takeDirectory p literalOsPath "trustedkeys.gpg" boolGpgCmd gpgcmd [ Param "--no-default-keyring" , Param "--no-auto-check-trustdb" , Param "--no-options" , Param "--homedir" - , File gpgtmp + , File (fromOsPath gpgtmp) , Param "--keyring" - , File trustedkeys + , File (fromOsPath trustedkeys) , Param "--verify" - , File sig + , File (fromOsPath sig) ] _ -> return False diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 31b5b19d14..ebc6c165b1 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -78,7 +78,7 @@ deleteCurrentRepository = dangerPage $ do sanityVerifierAForm $ SanityVerifier magicphrase case result of FormSuccess _ -> liftH $ do - dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath + dir <- liftAnnex $ fromRepo Git.repoPath liftIO $ removeAutoStartFile dir {- Disable syncing to this repository, and all @@ -89,9 +89,8 @@ deleteCurrentRepository = dangerPage $ do rs <- syncRemotes <$> getDaemonStatus mapM_ (\r -> changeSyncable (Just r) False) rs - liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir) - liftIO $ removeDirectoryRecursive . fromRawFilePath - =<< absPath (toRawFilePath dir) + liftAnnex $ prepareRemoveAnnexDir dir + liftIO $ removeDirectoryRecursive =<< absPath dir redirect ShutdownConfirmedR _ -> $(widgetFile "configurators/delete/currentrepository") diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 65da2d588e..4103f6bccb 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -121,7 +121,7 @@ setRepoConfig uuid mremote oldc newc = do Just t | T.null t -> noop | otherwise -> liftAnnex $ do - let dir = takeBaseName $ T.unpack t + let dir = fromOsPath $ takeBaseName $ toOsPath $ T.unpack t m <- remoteConfigMap case M.lookup uuid m of Nothing -> noop @@ -246,8 +246,8 @@ checkAssociatedDirectory cfg (Just r) = do case repoGroup cfg of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> do - top <- fromRawFilePath <$> fromRepo Git.repoPath - createWorkTreeDirectory (toRawFilePath (top d)) + top <- fromRepo Git.repoPath + createWorkTreeDirectory (top toOsPath d) Nothing -> noop _ -> noop diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 0b7c60a092..0d6b6f1eb3 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -81,24 +81,24 @@ checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text)) checkRepositoryPath p = do home <- myHomeDir let basepath = expandTilde home $ T.unpack p - path <- fromRawFilePath <$> absPath (toRawFilePath basepath) - let parent = fromRawFilePath $ parentDir (toRawFilePath path) + path <- absPath basepath + let parent = parentDir path problems <- catMaybes <$> mapM runcheck - [ (return $ path == "/", "Enter the full path to use for the repository.") - , (return $ all isSpace basepath, "A blank path? Seems unlikely.") + [ (return $ path == literalOsPath "/", "Enter the full path to use for the repository.") + , (return $ all isSpace (fromOsPath basepath :: FilePath), "A blank path? Seems unlikely.") , (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 <$> canWrite path, "Cannot write a repository there.") ] return $ case headMaybe problems of - Nothing -> Right $ Just $ T.pack basepath + Nothing -> Right $ Just $ T.pack $ fromOsPath basepath Just prob -> Left prob where runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing ) - expandTilde home ('~':'/':path) = home path - expandTilde _ path = path + expandTilde home ('~':'/':path) = toOsPath home toOsPath path + expandTilde _ path = toOsPath path {- On first run, if run in the home directory, default to putting it in - ~/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 - contains a git-annex file, in which case the user has probably - browsed to a directory with git-annex and run it from there. -} -defaultRepositoryPath :: Bool -> IO FilePath +defaultRepositoryPath :: Bool -> IO OsPath defaultRepositoryPath firstrun = do #ifndef mingw32_HOST_OS home <- myHomeDir currdir <- liftIO getCurrentDirectory - if home == currdir && firstrun + if toOsPath home == currdir && firstrun then inhome else ifM (legit currdir <&&> canWrite currdir) ( return currdir @@ -130,29 +130,29 @@ defaultRepositoryPath firstrun = do where inhome = ifM osAndroid ( do - home <- myHomeDir - let storageshared = home "storage" "shared" + home <- toOsPath <$> myHomeDir + let storageshared = home literalOsPath "storage" literalOsPath "shared" ifM (doesDirectoryExist storageshared) ( relHome $ storageshared gitAnnexAssistantDefaultDir - , return $ "~" gitAnnexAssistantDefaultDir + , return $ literalOsPath "~" gitAnnexAssistantDefaultDir ) , do - desktop <- userDesktopDir + desktop <- toOsPath <$> userDesktopDir ifM (doesDirectoryExist desktop <&&> canWrite desktop) ( relHome $ desktop gitAnnexAssistantDefaultDir - , return $ "~" gitAnnexAssistantDefaultDir + , return $ literalOsPath "~" gitAnnexAssistantDefaultDir ) ) #ifndef mingw32_HOST_OS -- Avoid using eg, standalone build's git-annex.linux/ directory -- when run from there. - legit d = not <$> doesFileExist (d "git-annex") + legit d = not <$> doesFileExist (d literalOsPath "git-annex") #endif -newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath +newRepositoryForm :: OsPath -> Hamlet.Html -> MkMForm RepositoryPath newRepositoryForm defpath msg = do (pathRes, pathView) <- mreq (repositoryPathField True) (bfs "") - (Just $ T.pack $ addTrailingPathSeparator defpath) + (Just $ T.pack $ fromOsPath $ addTrailingPathSeparator defpath) let (err, errmsg) = case pathRes of FormMissing -> (False, "") 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 case res of FormSuccess (RepositoryPath p) -> liftH $ - startFullAssistant (T.unpack p) ClientGroup Nothing + startFullAssistant (toOsPath $ T.unpack p) ClientGroup Nothing _ -> $(widgetFile "configurators/newrepository/first") getAndroidCameraRepositoryR :: Handler () getAndroidCameraRepositoryR = do home <- liftIO myHomeDir - let dcim = home "storage" "dcim" + let dcim = toOsPath home literalOsPath "storage" literalOsPath "dcim" startFullAssistant dcim SourceGroup $ Just addignore where addignore = do - liftIO $ unlessM (doesFileExist ".gitignore") $ + liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $ writeFile ".gitignore" ".thumbnails" void $ inRepo $ Git.Command.runBool [Param "add", File ".gitignore"] @@ -195,20 +195,21 @@ getNewRepositoryR :: Handler Html getNewRepositoryR = postNewRepositoryR postNewRepositoryR :: Handler Html postNewRepositoryR = page "Add another repository" (Just Configuration) $ do - home <- liftIO myHomeDir + home <- toOsPath <$> liftIO myHomeDir ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home case res of FormSuccess (RepositoryPath p) -> do - let path = T.unpack p + let path = toOsPath (T.unpack p) isnew <- liftIO $ makeRepo path False u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup) liftIO $ addAutoStartFile path liftIO $ startAssistant path - askcombine u path + askcombine u (fromOsPath path) _ -> $(widgetFile "configurators/newrepository") where askcombine newrepouuid newrepopath = do - newrepo <- liftIO $ relHome newrepopath + newrepo' <- liftIO $ relHome (toOsPath newrepopath) + let newrepo = fromOsPath newrepo' :: FilePath mainrepo <- fromJust . relDir <$> liftH getYesod $(widgetFile "configurators/newrepository/combine") @@ -222,17 +223,18 @@ immediateSyncRemote r = do getCombineRepositoryR :: FilePath -> UUID -> Handler Html getCombineRepositoryR newrepopath newrepouuid = do - liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename + liftAssistant . immediateSyncRemote + =<< combineRepos (toOsPath newrepopath) remotename redirect $ EditRepositoryR $ RepoUUID newrepouuid where - remotename = takeFileName newrepopath + remotename = fromOsPath $ takeFileName $ toOsPath newrepopath selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive <$> pure Nothing <*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing <*> areq textField (bfs "Use this directory on the drive:") - (Just $ T.pack gitAnnexAssistantDefaultDir) + (Just $ T.pack $ fromOsPath gitAnnexAssistantDefaultDir) where pairs = zip (map describe drives) (map mountPoint drives) 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.|] -removableDriveRepository :: RemovableDrive -> FilePath +removableDriveRepository :: RemovableDrive -> OsPath removableDriveRepository drive = - T.unpack (mountPoint drive) T.unpack (driveRepoPath drive) + toOsPath (T.unpack (mountPoint drive)) toOsPath (T.unpack (driveRepoPath drive)) {- Adding a removable drive. -} getAddDriveR :: Handler Html @@ -257,7 +259,7 @@ postAddDriveR :: Handler Html postAddDriveR = page "Add a removable drive" (Just Configuration) $ do removabledrives <- liftIO driveList writabledrives <- liftIO $ - filterM (canWrite . T.unpack . mountPoint) removabledrives + filterM (canWrite . toOsPath . T.unpack . mountPoint) removabledrives ((res, form), enctype) <- liftH $ runFormPostNoToken $ selectDriveForm (sort writabledrives) case res of @@ -277,7 +279,7 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir) mu <- liftIO $ probeUUID dir case mu of Nothing -> maybe askcombine isknownuuid - =<< liftAnnex (probeGCryptRemoteUUID dir) + =<< liftAnnex (probeGCryptRemoteUUID $ fromOsPath dir) Just driveuuid -> isknownuuid driveuuid , newrepo ) @@ -317,19 +319,19 @@ getFinishAddDriveR drive = go where go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do r <- liftAnnex $ addRemote $ - makeGCryptRemote remotename dir keyid + makeGCryptRemote remotename (fromOsPath dir) keyid return (Types.Remote.uuid r, r) - go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do - mu <- liftAnnex $ probeGCryptRemoteUUID dir + go NoRepoKey = checkGCryptRepoEncryption (fromOsPath dir) makeunencrypted makeunencrypted $ do + mu <- liftAnnex $ probeGCryptRemoteUUID (fromOsPath dir) case mu of Just u -> enableexistinggcryptremote u Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported." enableexistinggcryptremote u = do - remotename' <- liftAnnex $ getGCryptRemoteName u dir + remotename' <- liftAnnex $ getGCryptRemoteName u (fromOsPath dir) makewith $ const $ do r <- liftAnnex $ addRemote $ enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList - [(Proposed "gitrepo", Proposed dir)] + [(Proposed "gitrepo", Proposed (fromOsPath dir))] return (u, r) {- Making a new unencrypted repo, or combining with an existing one. -} makeunencrypted = makewith $ \isnew -> (,) @@ -347,21 +349,19 @@ getFinishAddDriveR drive = go liftAnnex $ defaultStandardGroup u TransferGroup liftAssistant $ immediateSyncRemote r redirect $ EditNewRepositoryR u - mountpoint = T.unpack (mountPoint drive) + mountpoint = toOsPath $ T.unpack (mountPoint drive) dir = removableDriveRepository drive - remotename = takeFileName mountpoint + remotename = fromOsPath $ takeFileName mountpoint {- Each repository is made a remote of the other. - Next call syncRemote to get them in sync. -} -combineRepos :: FilePath -> String -> Handler Remote +combineRepos :: OsPath -> String -> Handler Remote combineRepos dir name = liftAnnex $ do hostname <- fromMaybe "host" <$> liftIO getHostname - mylocation <- fromRepo Git.repoLocation - mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile - (toRawFilePath dir) - (toRawFilePath mylocation) - liftIO $ inDir dir $ void $ makeGitRemote hostname mypath - addRemote $ makeGitRemote name dir + mylocation <- fromRepo Git.repoPath + mypath <- liftIO $ relPathDirToFile dir mylocation + liftIO $ inDir dir $ void $ makeGitRemote hostname (fromOsPath mypath) + addRemote $ makeGitRemote name (fromOsPath dir) getEnableDirectoryR :: UUID -> Handler Html getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do @@ -396,12 +396,12 @@ genRemovableDrive :: FilePath -> IO RemovableDrive genRemovableDrive dir = RemovableDrive <$> getDiskFree 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 - repository, by running the postFirstRun callback, which returns the - url to the new webapp. -} -startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler () +startFullAssistant :: OsPath -> StandardGroup -> Maybe (Annex ())-> Handler () startFullAssistant path repogroup setup = do webapp <- getYesod 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 parent directory is checked instead. -} -canWrite :: FilePath -> IO Bool +canWrite :: OsPath -> IO Bool canWrite dir = do tocheck <- ifM (doesDirectoryExist 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 - not be a git-annex repo. -} -probeUUID :: FilePath -> IO (Maybe UUID) +probeUUID :: OsPath -> IO (Maybe UUID) probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do u <- getUUID return $ if u == NoUUID then Nothing else Just u diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index ceff21a3bf..a9ed6c0be1 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -72,7 +72,7 @@ getPrepareWormholePairR pairingwith = do enableTor :: Handler () enableTor = do - gitannex <- liftIO programPath + gitannex <- fromOsPath <$> liftIO programPath (transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing if ok -- Reload remotedameon so it's serving the tor hidden @@ -173,7 +173,7 @@ getFinishLocalPairR = postFinishLocalPairR postFinishLocalPairR :: PairMsg -> Handler Html #ifdef WITH_PAIRING postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do - repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo + repodir <- liftH $ repoPath <$> liftAnnex gitRepo liftIO $ setup repodir startLocalPairing PairAck (cleanup repodir) alert uuid "" secret where diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 14b3267b1c..a21da3306c 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -23,7 +23,6 @@ import Types.Distribution import Assistant.Upgrade import qualified Data.Text as T -import qualified System.FilePath.ByteString as P data PrefsForm = PrefsForm { diskReserve :: Text @@ -89,7 +88,7 @@ storePrefs p = do unsetConfig (annexConfig "numcopies") -- deprecated setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do - here <- fromRawFilePath <$> fromRepo Git.repoPath + here <- fromRepo Git.repoPath liftIO $ if autoStart p then addAutoStartFile here else removeAutoStartFile here @@ -110,5 +109,4 @@ postPreferencesR = page "Preferences" (Just Configuration) $ do inAutoStartFile :: Annex Bool inAutoStartFile = do here <- liftIO . absPath =<< fromRepo Git.repoPath - any (`P.equalFilePath` here) . map toRawFilePath - <$> liftIO readAutoStartFile + any (`equalFilePath` here) <$> liftIO readAutoStartFile diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 4edfee9fca..e56f434805 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -76,7 +76,7 @@ mkSshData s = SshData , sshDirectory = fromMaybe "" $ inputDirectory s , sshRepoName = genSshRepoName (T.unpack $ fromJust $ inputHostname s) - (maybe "" T.unpack $ inputDirectory s) + (toOsPath (maybe "" T.unpack $ inputDirectory s)) , sshPort = inputPort s , needsPubKey = False , sshCapabilities = [] -- untested @@ -101,7 +101,7 @@ sshInputAForm hostnamefield d = normalize <$> gen <*> aopt check_username (bfs "User name") (Just $ inputUsername d) <*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d) <*> 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) authmethods :: [(Text, AuthMethod)] @@ -389,13 +389,13 @@ sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinpu v <- getCachedCred login liftIO $ case v of Nothing -> go [passwordprompts 0] Nothing - Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do + Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do hClose h - writeFileProtected (fromOsPath passfile) pass + writeFileProtected passfile pass environ <- getEnvironment let environ' = addEntries - [ ("SSH_ASKPASS", program) - , (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile) + [ ("SSH_ASKPASS", fromOsPath program) + , (sshAskPassEnv, fromOsPath passfile) , ("DISPLAY", ":0") ] 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 needsPubKey origsshdata - then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair + then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) (toOsPath remotedir) . sshPubKey <$> keypair else Nothing ] rsynconly = onlyCapability origsshdata RsyncCapable @@ -602,7 +602,7 @@ postAddRsyncNetR = do |] go sshinput = do let reponame = genSshRepoName "rsync.net" - (maybe "" T.unpack $ inputDirectory sshinput) + (toOsPath (maybe "" T.unpack $ inputDirectory sshinput)) prepRsyncNet sshinput reponame $ \sshdata -> inpage $ checkExistingGCrypt sshdata $ do diff --git a/Assistant/WebApp/Configurators/Unused.hs b/Assistant/WebApp/Configurators/Unused.hs index 11f60e3127..55b1e565ae 100644 --- a/Assistant/WebApp/Configurators/Unused.hs +++ b/Assistant/WebApp/Configurators/Unused.hs @@ -51,7 +51,7 @@ postConfigUnusedR = page "Unused files" (Just Configuration) $ do redirect ConfigurationR _ -> do munuseddesc <- liftAssistant describeUnused - ts <- liftAnnex $ dateUnusedLog "" + ts <- liftAnnex $ dateUnusedLog (literalOsPath "") mlastchecked <- case ts of Nothing -> pure Nothing Just t -> Just <$> liftIO (durationSince t) diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index 5d60731bfe..0f0a76584e 100644 --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -73,6 +73,6 @@ getRestartThreadR name = do getLogR :: Handler Html getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile - logs <- liftIO $ listLogs (fromRawFilePath logfile) + logs <- liftIO $ listLogs (fromOsPath logfile) logcontent <- liftIO $ concat <$> mapM readFile logs $(widgetFile "control/log") diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 5bbcee3c92..4fbba263b0 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ transfersDisplay = do transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of AssociatedFile Nothing -> serializeKey $ transferKey transfer - AssociatedFile (Just af) -> fromRawFilePath af + AssociatedFile (Just af) -> fromOsPath af {- Simplifies a list of transfers, avoiding display of redundant - equivalent transfers. -} @@ -118,7 +118,7 @@ getFileBrowserR = whenM openFileBrowser redirectBack - blocking the response to the browser on it. -} openFileBrowser :: Handler Bool openFileBrowser = do - path <- fromRawFilePath + path <- fromOsPath <$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath)) #ifdef darwin_HOST_OS let cmd = "open" diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs index 63c4f7cb98..a6dcc03853 100644 --- a/Assistant/WebApp/Documentation.hs +++ b/Assistant/WebApp/Documentation.hs @@ -16,10 +16,10 @@ import BuildFlags {- The full license info may be included in a file on disk that can - be read in and displayed. -} -licenseFile :: IO (Maybe FilePath) +licenseFile :: IO (Maybe OsPath) licenseFile = do base <- standaloneAppBase - return $ ( "LICENSE") <$> base + return $ ( literalOsPath "LICENSE") <$> base getAboutR :: Handler Html getAboutR = page "About git-annex" (Just About) $ do @@ -34,7 +34,7 @@ getLicenseR = do Just f -> customPage (Just About) $ do -- no sidebar, just pages of legalese.. setTitle "License" - license <- liftIO $ readFile f + license <- liftIO $ readFile (fromOsPath f) $(widgetFile "documentation/license") getRepoGroupR :: Handler Html diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs index c13d93ffdc..4b45cc9541 100644 --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -15,7 +15,6 @@ import Assistant.WebApp.Page import Config.Files.AutoStart import Utility.Yesod import Assistant.Restart -import qualified Utility.RawFilePath as R getRepositorySwitcherR :: Handler Html getRepositorySwitcherR = page "Switch repository" Nothing $ do @@ -25,15 +24,16 @@ getRepositorySwitcherR = page "Switch repository" Nothing $ do listOtherRepos :: IO [(String, String)] listOtherRepos = do dirs <- readAutoStartFile - pwd <- R.getCurrentDirectory + pwd <- getCurrentDirectory gooddirs <- filterM isrepo $ - filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs + filter (\d -> not $ d `dirContains` pwd) dirs names <- mapM relHome gooddirs - return $ sort $ zip names gooddirs + return $ sort $ zip (map fromOsPath names) (map fromOsPath gooddirs) where - isrepo d = doesDirectoryExist (d ".git") + isrepo d = doesDirectoryExist (d literalOsPath ".git") getSwitchToRepositoryR :: FilePath -> Handler Html getSwitchToRepositoryR repo = do - liftIO $ addAutoStartFile repo -- make this the new default repo - redirect =<< liftIO (newAssistantUrl repo) + let repo' = toOsPath repo + liftIO $ addAutoStartFile repo' -- make this the new default repo + redirect =<< liftIO (newAssistantUrl repo') diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 444b37ca5c..159453e35a 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -79,11 +79,11 @@ autoStart o = do dirs <- liftIO readAutoStartFile when (null dirs) $ do f <- autoStartFile - giveup $ "Nothing listed in " ++ f - program <- programPath + giveup $ "Nothing listed in " ++ fromOsPath f + program <- fromOsPath <$> programPath haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice" pids <- forM dirs $ \d -> do - putStrLn $ "git-annex autostart in " ++ d + putStrLn $ "git-annex autostart in " ++ fromOsPath d mpid <- catchMaybeIO $ go haveionice program d if foregroundDaemonOption (daemonOptions o) then return mpid @@ -128,9 +128,9 @@ autoStart o = do autoStop :: IO () autoStop = do dirs <- liftIO readAutoStartFile - program <- programPath + program <- fromOsPath <$> programPath forM_ dirs $ \d -> do - putStrLn $ "git-annex autostop in " ++ d + putStrLn $ "git-annex autostop in " ++ fromOsPath d tryIO (setCurrentDirectory d) >>= \case Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"]) ( putStrLn "ok" diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 2958784eb7..02e5735d3b 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -86,15 +86,15 @@ start' allowauto o = do listenPort' <- if isJust (listenPort o) then pure (listenPort o) else annexPort <$> Annex.getGitConfig - ifM (checkpid <&&> checkshim (fromRawFilePath f)) + ifM (checkpid <&&> checkshim f) ( if isJust (listenAddress o) || isJust (listenPort o) then giveup "The assistant is already running, so --listen and --port cannot be used." else do - url <- liftIO . readFile . fromRawFilePath + url <- liftIO . readFile . fromOsPath =<< fromRepo gitAnnexUrlFile liftIO $ if isJust listenAddress' then putStrLn url - else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing + else liftIO $ openBrowser browser f url Nothing Nothing , do startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $ \origout origerr url htmlshim -> @@ -104,11 +104,11 @@ start' allowauto o = do ) checkpid = do pidfile <- fromRepo gitAnnexPidFile - liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile) + liftIO $ isJust <$> checkDaemon pidfile checkshim f = liftIO $ doesFileExist f notinitialized = do 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 {- If HOME is a git repo, even if it's initialized for git-annex, @@ -117,7 +117,7 @@ notHome :: Annex Bool notHome = do g <- Annex.gitRepo d <- liftIO $ absPath (Git.repoPath g) - h <- liftIO $ absPath . toRawFilePath =<< myHomeDir + h <- liftIO $ absPath . toOsPath =<< myHomeDir return (d /= h) {- 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 Right state -> void $ Annex.eval state $ do 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 $ start' False o quiesce False return r -cannotStartIn :: FilePath -> String -> IO () -cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason +cannotStartIn :: OsPath -> String -> IO () +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, - changes to it, starts the regular assistant, and redirects the @@ -203,12 +204,12 @@ firstRun o = do (Just $ sendurlback v) 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 - htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim) + htmlshim' <- absPath htmlshim 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 = ifM osAndroid {- Android does not support file:// urls well, but neither @@ -220,7 +221,7 @@ openBrowser' mcmd htmlshim realurl outh errh = where runbrowser url = do let p = case mcmd of - Just c -> proc c [url] + Just c -> proc (fromOsPath c) [url] Nothing -> #ifndef mingw32_HOST_OS browserProc url @@ -228,8 +229,8 @@ openBrowser' mcmd htmlshim realurl outh errh = {- Windows hack to avoid using the full path, - which might contain spaces that cause problems - for browserProc. -} - (browserProc (takeFileName htmlshim)) - { cwd = Just (takeDirectory htmlshim) } + (browserProc (fromOsPath (takeFileName htmlshim))) + { cwd = Just (fromOsPath (takeDirectory htmlshim)) } #endif hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout @@ -245,8 +246,8 @@ openBrowser' mcmd htmlshim realurl outh errh = hPutStrLn (fromMaybe stderr errh) "failed to start web browser" {- 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" -fileUrl :: FilePath -> String -fileUrl file = "file://" ++ file +fileUrl :: OsPath -> String +fileUrl file = "file://" ++ fromOsPath file diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 178a63f050..ebff84edaa 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -185,11 +185,9 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params = {- Creates a html shim file that's used to redirect into the webapp, - 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 = - viaTmp (writeFileProtected) - (toOsPath $ toRawFilePath file) - (genHtmlShim title url) + viaTmp (writeFileProtected) file (genHtmlShim title url) genHtmlShim :: String -> String -> String genHtmlShim title url = unlines