38d691a10f
Running git-annex linux builds in termux seems to work well enough that the only reason to keep the Android app would be to support Android 4-5, which the old Android app supported, and which I don't know if the termux method works on (although I see no reason why it would not). According to [1], Android 4-5 remains on around 29% of devices, down from 51% one year ago. [1] https://www.statista.com/statistics/271774/share-of-android-platforms-on-mobile-devices-with-android-os/ This is a rather large commit, but mostly very straightfoward removal of android ifdefs and patches and associated cruft. Also, removed support for building with very old ghc < 8.0.1, and with yesod < 1.4.3, and without concurrent-output, which were only being used by the cross build. Some documentation specific to the Android app (screenshots etc) needs to be updated still. This commit was sponsored by Brett Eisenberg on Patreon.
131 lines
4 KiB
Haskell
131 lines
4 KiB
Haskell
{- git-annex assistant webapp thread
|
|
-
|
|
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
|
|
{-# LANGUAGE ViewPatterns, OverloadedStrings #-}
|
|
{-# 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.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.WebApp.Pairing
|
|
import Assistant.Types.ThreadedMonad
|
|
import Utility.WebApp
|
|
import Utility.AuthToken
|
|
import Utility.Tmp
|
|
import Utility.FileMode
|
|
import Git
|
|
import qualified Annex
|
|
|
|
import Yesod
|
|
import Network.Socket (SockAddr, HostName)
|
|
import Data.Text (pack, unpack)
|
|
import qualified Network.Wai.Handler.WarpTLS as TLS
|
|
import Network.Wai.Middleware.RequestLogger
|
|
|
|
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
|
|
|
type Url = String
|
|
|
|
webAppThread
|
|
:: AssistantData
|
|
-> UrlRenderer
|
|
-> Bool
|
|
-> Maybe String
|
|
-> Maybe (IO Url)
|
|
-> Maybe HostName
|
|
-> Maybe (Url -> FilePath -> IO ())
|
|
-> NamedThread
|
|
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do
|
|
listenhost' <- if isJust listenhost
|
|
then pure listenhost
|
|
else getAnnex $ annexListen <$> Annex.getGitConfig
|
|
tlssettings <- getAnnex getTlsSettings
|
|
webapp <- WebApp
|
|
<$> pure assistantdata
|
|
<*> genAuthToken 128
|
|
<*> getreldir
|
|
<*> pure staticRoutes
|
|
<*> pure postfirstrun
|
|
<*> pure cannotrun
|
|
<*> pure noannex
|
|
<*> pure listenhost'
|
|
<*> newWormholePairingState
|
|
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
|
|
app <- toWaiAppPlain webapp
|
|
app' <- ifM debugEnabled
|
|
( return $ logStdout app
|
|
, return app
|
|
)
|
|
runWebApp tlssettings listenhost' app' $ \addr -> if noannex
|
|
then withTmpFile "webapp.html" $ \tmpfile h -> do
|
|
hClose h
|
|
go tlssettings addr webapp tmpfile Nothing
|
|
else do
|
|
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
|
|
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
|
|
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
|
|
-- that's going on.
|
|
thread = namedThreadUnchecked "WebApp"
|
|
getreldir
|
|
| noannex = return Nothing
|
|
| otherwise = Just <$>
|
|
(relHome =<< absPath
|
|
=<< getAnnex' (fromRepo repoPath))
|
|
go tlssettings addr webapp htmlshim urlfile = do
|
|
let url = myUrl tlssettings webapp addr
|
|
maybe noop (`writeFileProtected` url) urlfile
|
|
writeHtmlShim "Starting webapp..." url htmlshim
|
|
maybe noop (\a -> a url htmlshim) onstartup
|
|
|
|
getAnnex a
|
|
| noannex = pure Nothing
|
|
| otherwise = getAnnex' a
|
|
getAnnex' = runThreadState (threadState assistantdata)
|
|
|
|
myUrl :: Maybe TLS.TLSSettings -> WebApp -> SockAddr -> Url
|
|
myUrl tlssettings webapp addr = unpack $ yesodRender webapp urlbase DashboardR []
|
|
where
|
|
urlbase = pack $ proto ++ "://" ++ show addr
|
|
proto
|
|
| isJust tlssettings = "https"
|
|
| otherwise = "http"
|
|
|
|
getTlsSettings :: Annex (Maybe TLS.TLSSettings)
|
|
getTlsSettings = do
|
|
cert <- fromRepo gitAnnexWebCertificate
|
|
privkey <- fromRepo gitAnnexWebPrivKey
|
|
ifM (liftIO $ allM doesFileExist [cert, privkey])
|
|
( return $ Just $ TLS.tlsSettings cert privkey
|
|
, return Nothing
|
|
)
|