From a763d6dd3e62cea8ccde3091a9874994a1e92dd6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 28 Feb 2014 21:32:18 -0400
Subject: use https when .git/annex/privkey.pem and .git/annex/certificate.pem
 exist (untested)

I have not managed to generate a key that is accepted by the old version of
warp-tls I have here.
---
 Assistant/Threads/WebApp.hs | 30 ++++++++++++++++++++++--------
 1 file changed, 22 insertions(+), 8 deletions(-)

(limited to 'Assistant')

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
+		)
-- 
cgit v1.2.3