3da0064657
Make sanity checker run git annex unused daily, and queue up transfers of unused files to any remotes that will have them. The transfer retrying code works for us here, so eg when a backup disk remote is plugged in, any transfers to it are done. Once the unused files reach a remote, they'll be removed locally as unwanted. If the setup does not cause unused files to go to a remote, they'll pile up, and the sanity checker detects this using some heuristics that are pretty good -- 1000 unused files, or 10% of disk used by unused files, or more disk wasted by unused files than is left free. Once it detects this, it pops up an alert in the webapp, with a button to take action. TODO: Webapp UI to configure this, and also the ability to launch an immediate cleanup of all unused files. This commit was sponsored by Simon Michael.
111 lines
3.4 KiB
Haskell
111 lines
3.4 KiB
Haskell
{- git-annex assistant webapp thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Assistant.Threads.WebApp where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.DashBoard
|
|
import Assistant.WebApp.SideBar
|
|
import Assistant.WebApp.Notifications
|
|
import Assistant.WebApp.RepoList
|
|
import Assistant.WebApp.Configurators
|
|
import Assistant.WebApp.Configurators.Local
|
|
import Assistant.WebApp.Configurators.Ssh
|
|
import Assistant.WebApp.Configurators.Pairing
|
|
import Assistant.WebApp.Configurators.AWS
|
|
import Assistant.WebApp.Configurators.IA
|
|
import Assistant.WebApp.Configurators.WebDAV
|
|
import Assistant.WebApp.Configurators.XMPP
|
|
import Assistant.WebApp.Configurators.Preferences
|
|
import Assistant.WebApp.Configurators.Unused
|
|
import Assistant.WebApp.Configurators.Edit
|
|
import Assistant.WebApp.Configurators.Delete
|
|
import Assistant.WebApp.Configurators.Fsck
|
|
import Assistant.WebApp.Configurators.Upgrade
|
|
import Assistant.WebApp.Documentation
|
|
import Assistant.WebApp.Control
|
|
import Assistant.WebApp.OtherRepos
|
|
import Assistant.WebApp.Repair
|
|
import Assistant.Types.ThreadedMonad
|
|
import Utility.WebApp
|
|
import Utility.Tmp
|
|
import Utility.FileMode
|
|
import Git
|
|
|
|
import Yesod
|
|
import Network.Socket (SockAddr, HostName)
|
|
import Data.Text (pack, unpack)
|
|
|
|
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
|
|
|
type Url = String
|
|
|
|
webAppThread
|
|
:: AssistantData
|
|
-> UrlRenderer
|
|
-> Bool
|
|
-> Maybe String
|
|
-> Maybe HostName
|
|
-> Maybe (IO Url)
|
|
-> Maybe (Url -> FilePath -> IO ())
|
|
-> NamedThread
|
|
webAppThread assistantdata urlrenderer noannex cannotrun listenhost postfirstrun onstartup = thread $ liftIO $ do
|
|
#ifdef __ANDROID__
|
|
when (isJust listenhost) $
|
|
-- See Utility.WebApp
|
|
error "Sorry, --listen is not currently supported on Android"
|
|
#endif
|
|
webapp <- WebApp
|
|
<$> pure assistantdata
|
|
<*> (pack <$> genRandomToken)
|
|
<*> getreldir
|
|
<*> pure staticRoutes
|
|
<*> pure postfirstrun
|
|
<*> pure cannotrun
|
|
<*> pure noannex
|
|
<*> pure listenhost
|
|
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
|
|
app <- toWaiAppPlain webapp
|
|
app' <- ifM debugEnabled
|
|
( return $ httpDebugLogger app
|
|
, return app
|
|
)
|
|
runWebApp listenhost app' $ \addr -> if noannex
|
|
then withTmpFile "webapp.html" $ \tmpfile h -> do
|
|
hClose h
|
|
go addr webapp tmpfile Nothing
|
|
else do
|
|
let st = threadState assistantdata
|
|
htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
|
|
urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
|
|
go 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
|
|
-- that's going on.
|
|
thread = namedThreadUnchecked "WebApp"
|
|
getreldir
|
|
| noannex = return Nothing
|
|
| otherwise = Just <$>
|
|
(relHome =<< absPath
|
|
=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
|
|
go addr webapp htmlshim urlfile = do
|
|
let url = myUrl webapp addr
|
|
maybe noop (`writeFileProtected` url) urlfile
|
|
writeHtmlShim "Starting webapp..." url htmlshim
|
|
maybe noop (\a -> a url htmlshim) onstartup
|
|
|
|
myUrl :: WebApp -> SockAddr -> Url
|
|
myUrl webapp addr = unpack $ yesodRender webapp urlbase DashboardR []
|
|
where
|
|
urlbase = pack $ "http://" ++ show addr
|