use the secret token for authentication, and add to all dynamic urls

Assistant/Threads/WebApp.hs

@@ -23,10 +23,14 @@ import Yesod.Static
 import Text.Hamlet
 import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
+import Data.Text
+
+thisThread :: String
+thisThread = "WebApp"
 
 data WebApp = WebApp
 	{ daemonStatus :: DaemonStatusHandle
-	, secretToken :: String
+	, secretToken :: Text
 	, baseTitle :: String
 	, getStatic :: Static
 	}
@@ -46,6 +50,16 @@ instance Yesod WebApp where
 		webapp <- getYesod
 		hamletToRepHtml $(hamletFile $ hamletTemplate "default-layout")
 
+	{- Require an auth token be set when accessing any (non-static route) -}
+	isAuthorized _ _ = checkAuthToken secretToken
+
+	{- Add the auth token to every url generated, except static subsite
+         - urls (which can show up in Permission Denied pages). -}
+	joinPath = insertAuthToken secretToken excludeStatic
+		where
+			excludeStatic [] = True
+			excludeStatic (p:_) = p /= "static"
+
 getHomeR :: Handler RepHtml
 getHomeR = defaultLayout $ do
 	[whamlet|Hello, World<p><a href=@{ConfigR}>config|]
@@ -75,14 +89,16 @@ mkWebApp st dstatus = do
 	token <- genRandomToken 
 	return $ WebApp 
 		{ daemonStatus = dstatus
-		, secretToken = token
+		, secretToken = pack token
 		, baseTitle = reldir
 		, getStatic = $(embed "static")
 		}
 
-{- Creates a html shim file that's used to redirect into the webapp. -}
+{- Creates a html shim file that's used to redirect into the webapp,
+ - to avoid exposing the secretToken when launching the web browser. -}
 writeHtmlShim :: WebApp -> PortNumber -> Annex ()
 writeHtmlShim webapp port = do
+	liftIO $ debug thisThread ["running on port", show port]
 	htmlshim <- fromRepo gitAnnexHtmlShim
 	liftIO $ viaTmp go htmlshim $ genHtmlShim webapp port
 	where
@@ -96,4 +112,5 @@ writeHtmlShim webapp port = do
 genHtmlShim :: WebApp -> PortNumber -> String
 genHtmlShim webapp port = renderHtml $(shamletFile $ hamletTemplate "htmlshim")
 	where
-		url = "http://localhost:" ++ show port ++ "/?" ++ secretToken webapp
+		url = "http://localhost:" ++ show port ++
+			"/?auth=" ++ unpack (secretToken webapp)

Utility/WebApp.hs

@@ -1,30 +1,37 @@
-{- WAI webapp
+{- Yesod webapp
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE OverloadedStrings, CPP #-}
+{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-}
 
 module Utility.WebApp where
 
 import Common
 
-import Network.Wai
+import Yesod
+import qualified Network.Wai as Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Logger
 import Control.Monad.IO.Class
 import Network.HTTP.Types
 import System.Log.Logger
 import Data.ByteString.Lazy.UTF8
-import Data.ByteString.Lazy
-import Data.CaseInsensitive as CI
+import qualified Data.CaseInsensitive as CI
 import Network.Socket
 import Control.Exception
 import Crypto.Random
 import Data.Digest.Pure.SHA
-import Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy as L
+import Data.AssocList
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import Blaze.ByteString.Builder (Builder)
+import Data.Monoid
+import Control.Arrow ((***))
 
 localhost :: String
 localhost = "localhost"
@@ -85,26 +92,26 @@ debugEnabled = do
  - Recommend only inserting this middleware when debugging is actually
  - enabled, as it's not optimised at all.
  -}
-httpDebugLogger :: Middleware
+httpDebugLogger :: Wai.Middleware
 httpDebugLogger waiApp req = do
 	logRequest req
 	waiApp req
 
-logRequest :: MonadIO m => Request -> m ()
+logRequest :: MonadIO m => Wai.Request -> m ()
 logRequest req = do
 	liftIO $ debugM "WebApp" $ unwords
-		[ showSockAddr $ remoteHost req
-		, frombs $ requestMethod req
-		, frombs $ rawPathInfo req
-		--, show $ httpVersion req
+		[ showSockAddr $ Wai.remoteHost req
+		, frombs $ Wai.requestMethod req
+		, frombs $ Wai.rawPathInfo req
+		--, show $ Wai.httpVersion req
 		--, frombs $ lookupRequestField "referer" req
 		, frombs $ lookupRequestField "user-agent" req
 		]
 	where
-		frombs v = toString $ fromChunks [v]
+		frombs v = toString $ L.fromChunks [v]
 
-lookupRequestField :: CI Ascii -> Request -> Ascii
-lookupRequestField k req = fromMaybe "" . lookup k $ requestHeaders req
+lookupRequestField :: CI.CI Ascii -> Wai.Request -> Ascii
+lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
 
 {- Generates a 512 byte random token, suitable to be used for an
  - authentication secret. -}
@@ -115,3 +122,39 @@ genRandomToken = do
 		case genBytes 512 g of
 			Left e -> error $ "failed to generate secret token: " ++ show e
 			Right (s, _) -> showDigest $ sha512 $ L.fromChunks [s]
+
+{- A Yesod isAuthorized method, which checks the auth cgi parameter
+ - against a token extracted from the Yesod application. -}
+checkAuthToken :: forall t sub. (t -> T.Text) -> GHandler sub t AuthResult
+checkAuthToken extractToken = do
+	webapp <- getYesod
+	req <- getRequest
+	let params = reqGetParams req
+	if lookupDef "" "auth" params == extractToken webapp
+		then return Authorized
+		else return AuthenticationRequired
+
+{- A Yesod joinPath method, which adds an auth cgi parameter to every
+ - url matching a predicate, containing a token extracted from the
+ - Yesod application.
+ - 
+ - A typical predicate would exclude files under /static.
+ -}
+insertAuthToken :: forall y. (y -> T.Text)
+	-> ([T.Text] -> Bool)
+	-> y
+	-> T.Text
+	-> [T.Text]
+	-> [(T.Text, T.Text)]
+	-> Builder
+insertAuthToken extractToken predicate webapp root pathbits params =
+	fromText root `mappend` encodePath pathbits' encodedparams
+	where
+		pathbits' = if null pathbits then [T.empty] else pathbits
+		encodedparams = map (TE.encodeUtf8 *** go) params'
+		go "" = Nothing
+		go x = Just $ TE.encodeUtf8 x
+		authparam = (T.pack "auth", extractToken webapp)
+		params'
+			| predicate pathbits = authparam:params
+			| otherwise = params

templates/htmlshim.hamlet

@@ -4,4 +4,4 @@ $doctype 5
     <meta http-equiv="refresh" content="0; URL=#{url}">
   <body>
     <p>
-      <a href=#{url}">Starting webapp...
+      <a href="#{url}">Starting webapp...