Compile with ghc 8.6 by pushing MonadFail usage into IO

yesodweb · Oct 11, 2018 · 132abcc · 132abcc
1 parent 90423f5
commit 132abcc
Show file tree

Hide file tree

Showing 5 changed files with 18 additions and 5 deletions.
diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md
@@ -1,3 +1,7 @@
+## 1.6.0.1
+
+* Compile with GHC 8.6
+
 ## 1.6.0
 
 * Upgrade to yesod-core 1.6.0

diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -69,7 +70,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
         setSession oauthSessionName $ lookupTokenSecret tok
         redirect $ authorizeUrl oauth' tok
     dispatch "GET" [] = do
-      Just tokSec <- lookupSession oauthSessionName
+      tokSec <- lookupSession oauthSessionName >>= \case
+        Just t -> return t
+        Nothing -> liftIO $ fail "lookupSession could not find session"
       deleteSession oauthSessionName
       reqTok <-
         if oauthVersion oauth == OAuth10

diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal
@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth
-version:         1.6.0
+version:         1.6.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii

diff --git a/yesod-static/test/EmbedProductionTest.hs b/yesod-static/test/EmbedProductionTest.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 module EmbedProductionTest where
 
 -- Tests the production mode of the embedded static subsite by
@@ -108,7 +109,9 @@ embedProductionSpecs = yesodSpec (MyApp eProduction) $ do
         yit "Embedded Javascript" $ do
             get HomeR
             statusIs 200
-            [script] <- htmlQuery "script"
+            script <- htmlQuery "script" >>= \case
+                [s] -> return s
+                _ -> liftIO $ fail "Expected singleton list of script"
             let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is "
 
             get $ TL.toStrict $ TL.decodeUtf8 src

diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -482,8 +483,10 @@ postHomeR = defaultLayout
 
 postResourcesR :: Handler ()
 postResourcesR = do
-  ([("foo", t)], _) <- runRequestBody
-  sendResponseCreated $ ResourceR t
+    t <- runRequestBody >>= \case
+        ([("foo", t)], _) -> return t
+        _ -> liftIO $ fail "postResourcesR pattern match failure"
+    sendResponseCreated $ ResourceR t
 
 getResourceR :: Text -> Handler Html
 getResourceR i = defaultLayout