From 9d6b59d0e21e5917d098a84b7b1654bd8d07efb3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 26 Jul 2012 04:50:09 -0400 Subject: [PATCH] use the secret token for authentication, and add to all dynamic urls --- Assistant/Threads/WebApp.hs | 25 +++++++++++-- Utility/WebApp.hs | 73 +++++++++++++++++++++++++++++-------- templates/htmlshim.hamlet | 2 +- 3 files changed, 80 insertions(+), 20 deletions(-) diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 06909fd531..50add37354 100644 --- a/Assistant/Threads/WebApp.hs +++ b/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

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) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index cded83229e..fb82c20507 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -1,30 +1,37 @@ -{- WAI webapp +{- Yesod webapp - - Copyright 2012 Joey Hess - - 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 diff --git a/templates/htmlshim.hamlet b/templates/htmlshim.hamlet index c10042c999..073b69c1bd 100644 --- a/templates/htmlshim.hamlet +++ b/templates/htmlshim.hamlet @@ -4,4 +4,4 @@ $doctype 5

- Starting webapp... + Starting webapp...