793ddecd4b
And follow-on changes. Note that relatedTemplate was changed to operate on a RawFilePath, and so when it counts the length, it is now the number of bytes, not the number of code points. This will just make it truncate shorter strings in some cases, the truncation is still unicode aware. When not building with the OsPath flag, toOsPath . fromRawFilePath and fromRawFilePath . fromOsPath do extra conversions back and forth between String and ByteString. That overhead could be avoided, but that's the non-optimised build mode, so didn't bother. Sponsored-by: unqueued
136 lines
4.3 KiB
Haskell
136 lines
4.3 KiB
Haskell
{- git-annex assistant webapp thread
|
|
-
|
|
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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, PortNumber)
|
|
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 PortNumber
|
|
-> Maybe (Url -> FilePath -> IO ())
|
|
-> NamedThread
|
|
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
|
|
listenhost' <- if isJust listenhost
|
|
then pure listenhost
|
|
else getAnnex $ annexListen <$> Annex.getGitConfig
|
|
listenport' <- if isJust listenport
|
|
then pure listenport
|
|
else getAnnex $ annexPort <$> 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 (fromMaybe False <$> (getAnnex $ Just . annexDebug <$> Annex.getGitConfig))
|
|
( return $ logStdout app
|
|
, return app
|
|
)
|
|
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
|
|
then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
|
|
hClose h
|
|
go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
|
|
else do
|
|
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
|
|
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
|
|
go tlssettings addr webapp
|
|
(fromRawFilePath 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 . fromRawFilePath =<< 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
|
|
)
|