diff options
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 30 | ||||
| -rw-r--r-- | Locations.hs | 9 | ||||
| -rw-r--r-- | Utility/WebApp.hs | 9 |
3 files changed, 37 insertions, 11 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index d2c2afd47..1ba0d43b0 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -45,6 +45,7 @@ import Git import Yesod import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) +import qualified Network.Wai.Handler.WarpTLS as TLS mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -80,15 +81,16 @@ webAppThread assistantdata urlrenderer noannex cannotrun listenhost postfirstrun ( return $ httpDebugLogger app , return app ) - runWebApp listenhost app' $ \addr -> if noannex + tlssettings <- runThreadState (threadState assistantdata) getTlsSettings + runWebApp tlssettings listenhost app' $ \addr -> if noannex then withTmpFile "webapp.html" $ \tmpfile h -> do hClose h - go addr webapp tmpfile Nothing + go tlssettings 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) + 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 @@ -99,13 +101,25 @@ webAppThread assistantdata urlrenderer noannex cannotrun listenhost postfirstrun | otherwise = Just <$> (relHome =<< absPath =<< runThreadState (threadState assistantdata) (fromRepo repoPath)) - go addr webapp htmlshim urlfile = do - let url = myUrl webapp addr + 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 -myUrl :: WebApp -> SockAddr -> Url -myUrl webapp addr = unpack $ yesodRender webapp urlbase DashboardR [] +myUrl :: Maybe TLS.TLSSettings -> WebApp -> SockAddr -> Url +myUrl tlssettings webapp addr = unpack $ yesodRender webapp urlbase DashboardR [] where - urlbase = pack $ "http://" ++ show addr + 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 + ) diff --git a/Locations.hs b/Locations.hs index 3739f10f5..74cace156 100644 --- a/Locations.hs +++ b/Locations.hs @@ -34,6 +34,8 @@ module Locations ( gitAnnexScheduleState, gitAnnexTransferDir, gitAnnexCredsDir, + gitAnnexWebCertificate, + gitAnnexWebPrivKey, gitAnnexFeedStateDir, gitAnnexFeedState, gitAnnexMergeDir, @@ -223,6 +225,13 @@ gitAnnexScheduleState r = gitAnnexDir r </> "schedulestate" gitAnnexCredsDir :: Git.Repo -> FilePath gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r </> "creds" +{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp + - when HTTPS is enabled -} +gitAnnexWebCertificate :: Git.Repo -> FilePath +gitAnnexWebCertificate r = gitAnnexDir r </> "certificate.pem" +gitAnnexWebPrivKey :: Git.Repo -> FilePath +gitAnnexWebPrivKey r = gitAnnexDir r </> "privkey.pem" + {- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -} gitAnnexFeedStateDir :: Git.Repo -> FilePath gitAnnexFeedStateDir r = addTrailingPathSeparator $ gitAnnexDir r </> "feedstate" diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 6318abdcf..9d0751502 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -17,6 +17,7 @@ import Utility.Hash import qualified Yesod import qualified Network.Wai as Wai import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS import Network.Wai.Logger import Control.Monad.IO.Class import Network.HTTP.Types @@ -70,10 +71,12 @@ browserProc url = proc "xdg-open" [url] - An IO action can also be run, to do something with the address, - such as start a web browser to view the webapp. -} -runWebApp :: Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO () -runWebApp h app observer = withSocketsDo $ do +runWebApp :: Maybe TLSSettings -> Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO () +runWebApp tlssettings h app observer = withSocketsDo $ do sock <- getSocket h - void $ forkIO $ runSettingsSocket webAppSettings sock app + void $ forkIO $ + (maybe runSettingsSocket (\ts -> runTLSSocket ts) tlssettings) + webAppSettings sock app sockaddr <- fixSockAddr <$> getSocketName sock observer sockaddr |