yesod-auth-hashdb 1.5 → 1.5.1
raw patch · 7 files changed
+440/−23 lines, 7 filesdep +classy-preludedep +containersdep +http-conduitdep ~bytestringdep ~hspecdep ~text
Dependencies added: classy-prelude, containers, http-conduit, http-types, monad-logger, network-uri, persistent-sqlite, resourcet, wai-extra, yesod, yesod-test
Dependency ranges changed: bytestring, hspec, text, yesod-auth, yesod-core
Files
- ChangeLog.md +4/−0
- Yesod/Auth/HashDB.hs +32/−22
- test/IntegrationTest.hs +74/−0
- test/TestSite.hs +135/−0
- test/TestTools.hs +142/−0
- test/integration.hs +25/−0
- yesod-auth-hashdb.cabal +28/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.5.1++* Include CSRF token in default form+ ## 1.5 This release can break both old code and old database entries. For details
Yesod/Auth/HashDB.hs view
@@ -131,6 +131,11 @@ import Yesod.Form import Yesod.Persist +#if !MIN_VERSION_yesod_core(1,4,14)+defaultCsrfParamName :: Text+defaultCsrfParamName = "_token"+#endif+ -- | Default strength used for passwords (see "Crypto.PasswordStore" for -- details). defaultStrength :: Int@@ -345,30 +350,35 @@ defaultForm :: Yesod app => Route app -> WidgetT app IO ()-defaultForm loginRoute = toWidget [hamlet|-$newline never- <div id="header">+defaultForm loginRoute = do+ request <- getRequest+ let mtok = reqToken request+ toWidget [hamlet|+ $newline never+ <div id="header"> <h1>Login - <div id="login">+ <div id="login"> <form method="post" action="@{loginRoute}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login">+ $maybe tok <- mtok+ <input type=hidden name=#{defaultCsrfParamName} value=#{tok}>+ <table>+ <tr>+ <th>Username:+ <td>+ <input id="x" name="username" autofocus="" required>+ <tr>+ <th>Password:+ <td>+ <input type="password" name="password" required>+ <tr>+ <td> + <td>+ <input type="submit" value="Login"> - <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }+ <script>+ if (!("autofocus" in document.createElement("input"))) {+ document.getElementById("x").focus();+ } -|]+ |]
+ test/IntegrationTest.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module IntegrationTest (+ withApp,+ integrationSpec+) where++import ClassyPrelude+import Test.Hspec (Spec, SpecWith, before,+ describe, context, it)+import qualified Yesod.Test as YT++import TestSite (App, Route(..), Handler, runDB)+import TestTools++#if MIN_VERSION_yesod_test(1,5,0)+type MyTestApp = YT.TestApp App+withApp :: App -> SpecWith (YT.TestApp App) -> Spec+withApp app = before $ return (app, id)+#else+type MyTestApp = App+withApp :: App -> SpecWith App -> Spec+withApp app = before $ return app+#endif++integrationSpec :: SpecWith MyTestApp+integrationSpec = do+ describe "The home page" $ do+ it "can be accessed" $ do+ YT.get HomeR+ YT.statusIs 200++ describe "The protected page" $ do+ it "requires login" $ do+ needsLogin GET ("/prot" :: Text)+ it "looks right after login by a valid user" $ do+ _ <- doLogin "paul" "MyPassword"+ YT.get ProtectedR+ YT.statusIs 200+ YT.bodyContains "OK, you are logged in so you are allowed to see this!"+ it "can't be accessed after login then logout" $ do+ _ <- doLogin "paul" "MyPassword"+ YT.get $ AuthR LogoutR+ -- That `get` will get the form from Yesod.Core.Handler.redirectToPost+ -- which will not be submitted automatically without javascript+ YT.bodyContains "please click on the button below to be redirected"+ -- so we do the redirection ourselves:+ YT.request $ do+ YT.setMethod "POST"+ YT.setUrl $ AuthR LogoutR+#if MIN_VERSION_yesod_core(1,4,19)+ -- yesod-core-1.4.19 added the CSRF token to the redirectToPost form+ YT.addToken+#elif MIN_VERSION_yesod_core(1,4,14) && MIN_VERSION_yesod_test(1,4,4)+ -- Otherwise we still use CSRF middleware (see TestSite.hs) from+ -- yesod-core 1.4.14 onwards as long as we can get the token+ -- from the cookie, which was implemented in yesod-test-1.4.4+ YT.addTokenFromCookie+#endif+ YT.get HomeR+ YT.statusIs 200+ YT.bodyContains "Your current auth ID: Nothing"+ YT.get ProtectedR+ YT.statusIs 303++ describe "Login" $ do+ it "fails when incorrect password given" $ do+ loc <- doLoginPart1 "paul" "WrongPassword"+ checkFailedLogin loc+ it "fails when unknown user name given" $ do+ loc <- doLoginPart1 "paul" "WrongPassword"+ checkFailedLogin loc
+ test/TestSite.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module TestSite (+ User(..),+ migrateAll,+ App(..),+ Route(..),+ Handler,+ runDB+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Typeable (Typeable)+#endif+import Data.Text+import Database.Persist.Sqlite+import Network.HTTP.Client.Conduit (Manager)+import Yesod+import Yesod.Auth+import Yesod.Auth.HashDB (HashDBUser(..), authHashDB)+import Yesod.Auth.Message (AuthMessage (InvalidLogin))+#if MIN_VERSION_yesod_core(1,4,14)+import Yesod.Core (defaultCsrfMiddleware,+ defaultYesodMiddleware)+#endif+++-- Trivial example site needing authentication+--+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+User+ name Text+ password Text Maybe+ UniqueUser name+ deriving Show+#if __GLASGOW_HASKELL__ < 710+ deriving Typeable+#endif+|]++instance HashDBUser User where+ userPasswordHash = userPassword+ setPasswordHash h u = u { userPassword = Just h }++data App = App+ { appHttpManager :: Manager+ , appDBConnection :: SqlBackend+ }++mkYesod "App" [parseRoutes|+/ HomeR GET+/prot ProtectedR GET+/auth AuthR Auth getAuth+|]++instance Yesod App where+ approot = ApprootStatic "http://localhost:3000"++ authRoute _ = Just $ AuthR LoginR++ isAuthorized ProtectedR _ = do+ mu <- maybeAuthId+ return $ case mu of+ Nothing -> AuthenticationRequired+ Just _ -> Authorized+ -- Other pages (HomeR and AuthR _) do not require login+ isAuthorized _ _ = return Authorized++#if MIN_VERSION_yesod_core(1,4,19) || (MIN_VERSION_yesod_core(1,4,14) && MIN_VERSION_yesod_test(1,4,4))+ -- CSRF middleware requires yesod-core-1.4.14, but only include it if tests+ -- can get at the token (see IntegrationTest.hs for additional comment).+ yesodMiddleware = defaultCsrfMiddleware . defaultYesodMiddleware+#endif++instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend+ runDB action = do+ master <- getYesod+ runSqlConn action $ appDBConnection master++instance YesodAuth App where+ type AuthId App = UserId++ loginDest _ = HomeR+ logoutDest _ = HomeR++ authenticate creds = runDB $ do+ x <- getBy $ UniqueUser $ credsIdent creds+ case x of+ Just (Entity uid _) -> return $ Authenticated uid+ Nothing -> return $ UserError InvalidLogin++ authPlugins _ = [ authHashDB (Just . UniqueUser) ]++ authHttpManager = appHttpManager++instance YesodAuthPersist App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++getHomeR :: Handler Html+getHomeR = do+ mauth <- maybeAuth+ let mname = userName . entityVal <$> mauth+ defaultLayout+ [whamlet|+ <p>Your current auth ID: #{show mname}+ $maybe _ <- mname+ <p>+ <a href=@{AuthR LogoutR}>Logout+ $nothing+ <p>+ <a href=@{AuthR LoginR}>Go to the login page+ <p><a href=@{ProtectedR}>Go to protected page+ |]++-- This page requires a valid login+getProtectedR :: Handler Html+getProtectedR = defaultLayout+ [whamlet|+ <p>OK, you are logged in so you are allowed to see this!+ <p><a href=@{HomeR}>Go to home page+ |]
+ test/TestTools.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+module TestTools (+ assertFailure,+ urlPath,+ needsLogin,+ doLogin,+ doLoginPart1,+ doLoginPart2,+ checkFailedLogin,+ StdMethod(..)+) where++import TestSite (App(..))+import ClassyPrelude+import Yesod.Core (RedirectUrl)+import Yesod.Test+import qualified Data.ByteString.Char8 as BC+import Network.URI (URI(uriPath), parseURI)+import Network.HTTP.Types (StdMethod(..), renderStdMethod, Status(..))+import Network.Wai.Test (SResponse(..))++-- Adjust as necessary to the url prefix in the Testing configuration+testRoot :: ByteString+testRoot = "http://localhost:3000"++-- Adjust as necessary for the path part of the url for a page to force login+forceLogin :: ByteString+forceLogin = "/prot"++-- Adjust as necessary for the expected path part of the URL after login+afterLogin :: ByteString+afterLogin = "/prot"++-- Force failure by swearing that black is white, and pigs can fly...+assertFailure :: String -> YesodExample App ()+assertFailure msg = assertEqual msg True False++-- Convert an absolute URL (eg extracted from responses) to just the path+-- for use in test requests.+urlPath :: Text -> Text+urlPath = pack . maybe "" uriPath . parseURI . unpack++-- Internal use only - actual urls are ascii, so exact encoding is irrelevant+urlPathB :: ByteString -> Text+urlPathB = urlPath . decodeUtf8++-- Stages in login process, used below+firstRedirect :: RedirectUrl App url =>+ StdMethod -> url -> YesodExample App (Maybe ByteString)+firstRedirect method url = do+ request $ do+ setMethod $ renderStdMethod method+ setUrl url+ extractLocation -- We should get redirected to the login page++assertLoginPage :: ByteString -> YesodExample App ()+assertLoginPage loc = do+ assertEqual "correct login redirection location"+ (testRoot ++ "/auth/login") loc+ get $ urlPathB loc+ statusIs 200+ bodyContains "Login"++submitLogin :: Text -> Text -> YesodExample App (Maybe ByteString)+submitLogin user pass = do+ -- Ideally we would extract this url from the login form on the current page+ request $ do+ setMethod "POST"+ setUrl $ urlPathB $ testRoot ++ "/auth/page/hashdb/login"+ addPostParam "username" user+ addPostParam "password" pass+ addToken+ extractLocation -- Successful login should redirect to the home page++extractLocation :: YesodExample App (Maybe ByteString)+extractLocation = do+ withResponse ( \ SResponse { simpleStatus = s, simpleHeaders = h } -> do+ let code = statusCode s+ assertEqual ("Expected a 302 or 303 redirection status "+ ++ "but received " ++ show code)+ (code `oelem` [302,303])+ True+ return $ lookup "Location" h+ )++-- Check that accessing the url with the given method requires login, and+-- that it redirects us to what looks like the login page. Note that this is+-- *not* an ajax request, whatever the method, so the redirection *should*+-- result in the HTML login page.+--+needsLogin :: RedirectUrl App url => StdMethod -> url -> YesodExample App ()+needsLogin method url = do+ mbloc <- firstRedirect method url+ maybe (assertFailure "Should have location header") assertLoginPage mbloc++-- Do a login (using hashdb auth). This just attempts to go to the home+-- url, and follows through the login process. It should probably be the+-- first thing in each "it" spec.+--+-- To allow testing of the login process itself, doLogin is split into two+-- parts.+--+doLogin :: Text -> Text -> YesodExample App (Maybe ByteString)+doLogin user pass = do+ redir <- doLoginPart1 user pass+ doLoginPart2 redir++doLoginPart1 :: Text -> Text -> YesodExample App (Maybe ByteString)+doLoginPart1 user pass = do+ mbloc <- firstRedirect GET $ urlPathB $ testRoot ++ forceLogin+ maybe (assertFailure "Should have location header") assertLoginPage mbloc+ submitLogin user pass++doLoginPart2 :: Maybe ByteString -> YesodExample App (Maybe ByteString)+doLoginPart2 mbloc2 = do+ maybe (assertFailure "Should have second location header")+ (assertEqual "Check after-login redirection" $ testRoot ++ afterLogin)+ mbloc2+ -- Now get the home page to obtain the sessAuth value+ get ("/" :: Text)+ statusIs 200+ resp <- getResponse+ let sessAuth = (fmap simpleBody resp) >>= findSessAuth+ return sessAuth+ where+ findSessAuth body =+ let stmt = snd $ BC.breakSubstring "var sessAuth =" $ toStrict body+ parts = BC.split '"' stmt+ in case parts of+ (_:sa:_) -> Just sa+ _ -> Nothing++-- Use this instead of doLoginPart2 if the login is expected to fail+--+checkFailedLogin :: Maybe ByteString -> YesodExample App ()+checkFailedLogin mbloc2 = do+ maybe (assertFailure "Should have second location header")+ assertLoginPage+ mbloc2+ bodyContains "Invalid username/password combination"
+ test/integration.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.Trans.Resource (runResourceT)+import Control.Monad.Logger (runStderrLoggingT)+import Database.Persist.Sqlite+import Network.HTTP.Client.Conduit (newManager)+import Test.Hspec (hspec)+import Yesod+import Yesod.Auth.HashDB (setPassword)++import IntegrationTest+import TestSite++main :: IO ()+main = runStderrLoggingT $ withSqliteConn ":memory:" $ \conn -> liftIO $ do+ runResourceT $ flip runSqlConn conn $ do+ runMigration migrateAll+ validUser <- setPassword "MyPassword" $ User "paul" Nothing+ insert_ validUser+ mgr <- newManager+ -- To try this as a server, replace the `hspec` line below with this one,+ -- and remove the import of IntegrationTest above.+ -- warp 3000 $ App mgr conn+ hspec $ withApp (App mgr conn) integrationSpec
yesod-auth-hashdb.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-hashdb-version: 1.5+version: 1.5.1 license: MIT license-file: LICENSE author: Patrick Brisbin, later changes Paul Rouse@@ -54,6 +54,33 @@ , yesod-auth-hashdb , hspec , text++test-suite integration+ type: exitcode-stdio-1.0+ main-is: integration.hs+ hs-source-dirs: test+ ghc-options: -Wall+ other-modules: IntegrationTest+ , TestSite+ , TestTools+ build-depends: base >= 4 && < 5+ , bytestring+ , classy-prelude+ , containers+ , hspec >= 2.0.0+ , http-conduit+ , http-types+ , monad-logger+ , network-uri+ , persistent-sqlite+ , resourcet+ , text+ , wai-extra+ , yesod+ , yesod-auth+ , yesod-auth-hashdb+ , yesod-core+ , yesod-test >= 1.4.3 source-repository head type: git