7189dfd77d
* webapp: Detect when upgrades are available, and upgrade if the user
desires.
(Only when git-annex is installed using the prebuilt binaries
from git-annex upstream, not from eg Debian.)
* assistant: Detect when the git-annex binary is modified or replaced,
and either prompt the user to restart the program, or automatically
restart it.
* annex.autoupgrade configures both the above upgrade behaviors.
* Added support for quvi 0.9. Slightly suboptimal due to limitations in its
interface compared with the old version.
* Bug fix: annex.version did not get set on automatic upgrade to v5 direct
mode repo, so the upgrade was performed repeatedly, slowing commands down.
* webapp: Fix bug that broke switching between local repositories
that use the new guarded direct mode.
* Android: Fix stripping of the git-annex binary.
* Android: Make terminal app show git-annex version number.
* Android: Re-enable XMPP support.
* reinject: Allow to be used in direct mode.
* Futher improvements to git repo repair. Has now been tested in tens
of thousands of intentionally damaged repos, and successfully
repaired them all.
* Allow use of --unused in bare repository.
# imported from the archive
109 lines
3.3 KiB
Haskell
109 lines
3.3 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.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 _ ->
|
|
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
|