Merge branch 'master' of github.com:yesodweb/yesod

Conflicts:
	yesod-core/ChangeLog.md
	yesod-core/yesod-core.cabal

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-2.17
+resolver: lts-3.7
 packages:
   - ./yesod-core
   - ./yesod-static
@@ -13,6 +13,3 @@ packages:
   - ./yesod
   - ./yesod-eventsource
   - ./yesod-websockets
-extra-deps:
-  - wai-app-static-3.1.0
-  - nonce-1.0.2

yesod-auth/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.8
+
+* GoogleEmail2: proper error message when permission denied
+
 ## 1.4.7
 
 * add a runHttpRequest function for handling HTTP errors

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -50,14 +50,17 @@ module Yesod.Auth.GoogleEmail2
 import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
                                            AuthRoute, Creds (Creds),
                                            Route (PluginR), YesodAuth,
-                                           runHttpRequest, setCredsRedirect)
+                                           runHttpRequest, setCredsRedirect,
+                                           logoutDest)
 import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core               (HandlerSite, HandlerT, MonadHandler,
                                            TypedContent, getRouteToParent,
                                            getUrlRender, invalidArgs,
                                            lift, liftIO, lookupGetParam,
                                            lookupSession, notFound, redirect,
-                                           setSession, whamlet, (.:))
+                                           setSession, whamlet, (.:),
+                                           setMessage, getYesod, authRoute,
+                                           toHtml)
 
 
 import           Blaze.ByteString.Builder (fromByteString, toByteString)
@@ -187,7 +190,18 @@ authPlugin storeToken clientID clientSecret =
         mcode <- lookupGetParam "code"
         code <-
             case mcode of
-                Nothing -> invalidArgs ["Missing code paramter"]
+                Nothing -> do
+                    merr <- lookupGetParam "error"
+                    case merr of
+                        Nothing -> invalidArgs ["Missing code paramter"]
+                        Just err -> do
+                            master <- lift getYesod
+                            let msg =
+                                    case err of
+                                        "access_denied" -> "Access denied"
+                                        _ -> "Unknown error occurred: " `T.append` err
+                            setMessage $ toHtml msg
+                            lift $ redirect $ logoutDest master
                 Just c -> return c
 
         render <- getUrlRender

yesod-auth/openid.hs

@@ -27,7 +27,7 @@ getRootR = getAfterLoginR
 getAfterLoginR :: Handler RepHtml
 getAfterLoginR = do
     mauth <- maybeAuthId
-    defaultLayout $ addHamlet [hamlet|
+    defaultLayout [whamlet|
 <p>Auth: #{show mauth}
 $maybe _ <- mauth
     <p>
@@ -38,21 +38,22 @@ $nothing
 |]
 
 instance Yesod BID where
-    approot = ApprootStatic "http://localhost:3000"
+    approot = guessApproot
 
 instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
     getAuthId = return . Just . credsIdentClaimed
-    authPlugins _ = [authOpenId]
+    authPlugins _ = [authOpenId Claimed []]
     authHttpManager = httpManager
+    maybeAuthId = lookupSession credsKey
 
 instance RenderMessage BID FormMessage where
     renderMessage _ _ = defaultFormMessage
 
 main :: IO ()
 main = do
-    m <- newManager def
+    m <- newManager tlsManagerSettings
     toWaiApp (BID m) >>= run 3000
 

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.7
+version:         1.4.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin

yesod-core/ChangeLog.md

@@ -1,4 +1,8 @@
-## 1.4.16.1
+## 1.4.16
+
+* Add `guessApproot`
+
+## 1.4.15.1
 
 * bugfix neverExpires leaked threads
 

yesod-core/Yesod/Core.hs

@@ -71,6 +71,8 @@ module Yesod.Core
     , MonadWidget (..)
     , getRouteToParent
     , defaultLayoutSub
+      -- * Approot
+    , guessApproot
       -- * Misc
     , yesodVersion
     , yesodRender

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -56,6 +56,7 @@ import           Yesod.Core.Internal.Session
 import           Yesod.Core.Widget
 import Control.Monad.Trans.Class (lift)
 import Data.CaseInsensitive (CI)
+import qualified Network.Wai.Request
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -826,3 +827,19 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
   where
     line = show . fst . loc_start
     char = show . snd . loc_start
+
+-- | Guess the approot based on request headers. For more information, see
+-- "Network.Wai.Middleware.Approot"
+--
+-- In the case of headers being unavailable, it falls back to 'ApprootRelative'
+--
+-- Since 1.4.16
+guessApproot :: Approot site
+guessApproot = ApprootRequest $ \_master req ->
+    case W.requestHeaderHost req of
+        Nothing -> ""
+        Just host ->
+            (if Network.Wai.Request.appearsSecure req
+                then "https://"
+                else "http://")
+            `T.append` TE.decodeUtf8With TEE.lenientDecode host

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.15.1
+version:         1.4.16
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -25,7 +25,7 @@ library
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
                    , wai                   >= 3.0
-                   , wai-extra             >= 3.0.5
+                   , wai-extra             >= 3.0.7
                    , bytestring            >= 0.9.1.4
                    , text                  >= 0.7
                    , template-haskell