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

yesod-test/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-test
 
+## 1.6.7
+
+Add `addBasicAuthHeader` function [#1632](https://github.com/yesodweb/yesod/pull/1632)
+
 ## 1.6.6.2
 
 addPostParam will now URL-encode keys and values to prevent corruption

yesod-test/Yesod/Test.hs

@@ -66,6 +66,7 @@ module Yesod.Test
     , getLocation
     , request
     , addRequestHeader
+    , addBasicAuthHeader
     , setMethod
     , addPostParam
     , addGetParam
@@ -156,6 +157,7 @@ import qualified Network.Socket.Internal as Sock
 #endif
 
 import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 import Network.Wai
 import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
 import Control.Monad.Trans.Reader (ReaderT (..))
@@ -189,6 +191,7 @@ type HasCallStack = (?callStack :: CallStack)
 import GHC.Exts (Constraint)
 type HasCallStack = (() :: Constraint)
 #endif
+import Data.ByteArray.Encoding (convertToBase, Base(..))
 
 {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
 {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
@@ -1144,6 +1147,21 @@ addRequestHeader header = modifySIO $ \rbd -> rbd
     { rbdHeaders = header : rbdHeaders rbd
     }
 
+-- | Adds a header for <https://en.wikipedia.org/wiki/Basic_access_authentication HTTP Basic Authentication> to the request
+--
+-- ==== __Examples__
+--
+-- > request $ do
+-- >   addBasicAuthHeader "Aladdin" "OpenSesame"
+--
+-- @since 1.6.7
+addBasicAuthHeader :: CI ByteString -- ^ Username
+                   -> CI ByteString -- ^ Password
+                   -> RequestBuilder site ()
+addBasicAuthHeader username password =
+  let credentials = convertToBase Base64 $ CI.original $ username <> ":" <> password
+  in addRequestHeader ("Authorization", "Basic " <> credentials)
+
 -- | The general interface for performing requests. 'request' takes a 'RequestBuilder',
 -- constructs a request, and executes it.
 --

yesod-test/test/main.hs

@@ -38,7 +38,7 @@ import Data.Either (isLeft, isRight)
 import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
 import qualified Text.HTML.DOM as HD
-import Network.HTTP.Types.Status (status301, status303, status422, unsupportedMediaType415)
+import Network.HTTP.Types.Status (status301, status303, status403, status422, unsupportedMediaType415)
 import UnliftIO.Exception (tryAny, SomeException, try)
 import qualified Web.Cookie as Cookie
 import Data.Maybe (isNothing)
@@ -444,6 +444,21 @@ main = hspec $ do
             loc <- getLocation
             liftIO $ assertBool "expected a Left when not a redirect" $ isLeft loc
 
+    describe "Basic Authentication" $ yesodSpec app $ do
+        yit "rejects no header" $ do
+            get ("checkBasicAuth" :: Text)
+            statusIs 403
+        yit "rejects incorrect header" $ do
+            request $ do
+                setUrl ("checkBasicAuth" :: Text)
+                addBasicAuthHeader "Aladdin" "foo"
+            statusIs 403
+        yit "accepts correct header" $ do
+            request $ do
+                setUrl ("checkBasicAuth" :: Text)
+                addBasicAuthHeader "Aladdin" "OpenSesame"
+            statusIs 200
+
 instance RenderMessage LiteApp FormMessage where
     renderMessage _ _ = defaultFormMessage
 
@@ -530,6 +545,14 @@ app = liteApp $ do
         if actual == expected
             then return ()
             else sendResponseStatus unsupportedMediaType415 ()
+    onStatic "checkBasicAuth" $ dispatchTo $ do
+        headers <- requestHeaders <$> waiRequest
+        let authHeader = lookup "Authorization" headers
+
+        -- Copied from the Wikipedia Aladdin:OpenSesame example
+        if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l"
+            then return ()
+            else sendResponseStatus status403 ()
 
 cookieApp :: LiteApp
 cookieApp = liteApp $ do

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.6.2
+version:            1.6.7
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -28,6 +28,7 @@ library
                    , html-conduit              >= 0.1
                    , http-types                >= 0.7
                    , network                   >= 2.2
+                   , memory
                    , pretty-show               >= 1.6
                    , semigroups
                    , text