git-annex/Assistant/Threads/WebApp.hs

138 lines
4.2 KiB
Haskell
Raw Normal View History

{- git-annex assistant webapp thread
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
2013-06-05 01:02:09 +00:00
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
2014-10-09 21:07:35 +00:00
{-# LANGUAGE ViewPatterns, OverloadedStrings #-}
2013-06-05 01:02:09 +00:00
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.Threads.WebApp where
import Assistant.Common
2012-07-31 05:11:32 +00:00
import Assistant.WebApp
import Assistant.WebApp.Types
2012-07-31 05:11:32 +00:00
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.RepoList
2012-07-31 05:11:32 +00:00
import Assistant.WebApp.Configurators
2012-08-31 19:17:12 +00:00
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
2012-11-24 20:30:15 +00:00
import Assistant.WebApp.Configurators.AWS
import Assistant.WebApp.Configurators.IA
2012-11-17 19:30:11 +00:00
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
2012-10-29 23:07:10 +00:00
import Assistant.Types.ThreadedMonad
import Utility.WebApp
import Utility.AuthToken
2013-05-12 23:19:28 +00:00
import Utility.Tmp
import Utility.FileMode
import Git
import qualified Annex
import Yesod
import Network.Socket (SockAddr, HostName)
2012-07-31 05:11:32 +00:00
import Data.Text (pack, unpack)
import qualified Network.Wai.Handler.WarpTLS as TLS
import Network.Wai.Middleware.RequestLogger
2012-07-31 05:11:32 +00:00
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
type Url = String
webAppThread
:: AssistantData
-> UrlRenderer
-> Bool
2013-11-17 18:58:35 +00:00
-> 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
2013-05-02 20:47:42 +00:00
#ifdef __ANDROID__
when (isJust listenhost') $
2013-05-02 20:47:42 +00:00
-- See Utility.WebApp
giveup "Sorry, --listen is not currently supported on Android"
2013-05-02 20:47:42 +00:00
#endif
webapp <- WebApp
<$> pure assistantdata
<*> genAuthToken 128
<*> getreldir
<*> pure staticRoutes
<*> pure postfirstrun
2013-11-17 18:58:35 +00:00
<*> 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)
2012-10-29 18:30:10 +00:00
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"
2012-10-29 18:30:10 +00:00
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
2012-10-29 18:30:10 +00:00
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 []
2012-10-29 18:30:10 +00:00
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
)