more OsPath conversion (749/749)
Builds with and without OsPath build flag. Unfortunately, the test suite fails. Sponsored-by: unqueued on Patreon
This commit is contained in:
Joey Hess
parent
20ed039d59
commit
c730d00b6e
41 changed files with 416 additions and 427 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue