From ef6e892680bf0593a1360d0ddbacfa8c6d75fb5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Thu, 20 Sep 2018 13:02:07 +0200 Subject: [PATCH] Bring back tests --- Application.hs | 15 +++++++++++ Foundation.hs | 16 +++++++++++ gonito.cabal | 6 ++++- test/Handler/HomeSpec.hs | 39 +++++++++++---------------- test/TestImport.hs | 57 +++++++++++++++++++++++++++++++++------- 5 files changed, 99 insertions(+), 34 deletions(-) diff --git a/Application.hs b/Application.hs index 16a8946..8235969 100644 --- a/Application.hs +++ b/Application.hs @@ -5,6 +5,7 @@ module Application , appSelfContainedMain , develMain , makeFoundation + , makeLogWare -- * for DevelMain , getApplicationRepl , shutdownApp @@ -22,6 +23,7 @@ import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort) +import Network.Wai (Middleware) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -142,6 +144,19 @@ makeApplication foundation = do appPlain <- toWaiAppPlain foundation return $ logWare $ defaultMiddlewaresNoLogging appPlain +makeLogWare :: App -> IO Middleware +makeLogWare foundation = + mkRequestLogger def + { outputFormat = + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache + (if appIpFromHeader $ appSettings foundation + then FromFallback + else FromSocket) + , destination = Logger $ loggerSet $ appLogger foundation + } + -- | Warp settings for the given foundation value. warpSettings :: App -> Settings warpSettings foundation = diff --git a/Foundation.hs b/Foundation.hs index aeb4bc9..418e266 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -8,6 +8,8 @@ import Text.Hamlet (hamletFile) import Yesod.Auth.HashDB (HashDBUser(..), authHashDBWithForm) import qualified Yesod.Core.Unsafe as Unsafe import Yesod.Core.Types (Logger) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as TE import Yesod.Default.Util (addStaticContentExternal) instance HashDBUser User where @@ -49,6 +51,10 @@ mkMessage "App" "messages" "en" -- | A convenient synonym for creating forms. type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) +-- | A convenient synonym for database access functions. +type DB a = forall (m :: * -> *). + (MonadIO m) => ReaderT SqlBackend m a + isTrustedAuthorized :: (AuthEntity (HandlerSite m) ~ User, AuthId (HandlerSite m) ~ Key User, MonadHandler m, YesodAuthPersist (HandlerSite m)) => m AuthResult isTrustedAuthorized = do mauth <- maybeAuth @@ -92,6 +98,16 @@ instance Yesod App where 120 -- timeout in minutes ((appVarDir $ appSettings app) "config/client_session_key.aes") + -- Yesod Middleware allows you to run code before and after each handler function. + -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. + -- Some users may also want to add the defaultCsrfMiddleware, which: + -- a) Sets a cookie with a CSRF token in it. + -- b) Validates that incoming write requests include that token in either a header or POST parameter. + -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. + yesodMiddleware :: ToTypedContent res => Handler res -> Handler res + yesodMiddleware = defaultYesodMiddleware + defaultLayout widget = do master <- getYesod mmsg <- getMessage diff --git a/gonito.cabal b/gonito.cabal index 5e06365..19c5134 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -89,6 +89,7 @@ library , classy-prelude-conduit >= 0.10.2 , classy-prelude-yesod >= 0.10.2 , bytestring >= 0.9 && < 0.11 + , case-insensitive , text >= 0.11 && < 2.0 , persistent >= 2.0 && < 2.9 , persistent-postgresql >= 2.1.1 && < 2.9 @@ -140,6 +141,7 @@ library , extra , attoparsec , random-strings + , wai executable gonito if flag(library-only) @@ -187,8 +189,9 @@ test-suite test build-depends: base , gonito - , yesod-test >= 1.4.3 && < 1.5 + , yesod-test >= 1.6 && < 1.7 , yesod-core + , yesod-auth >= 1.6 && < 1.7 , yesod , persistent , persistent-postgresql @@ -200,3 +203,4 @@ test-suite test , classy-prelude , classy-prelude-yesod , wai-handler-fastcgi + , wai diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs index e0102f6..c975ecf 100644 --- a/test/Handler/HomeSpec.hs +++ b/test/Handler/HomeSpec.hs @@ -1,32 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Handler.HomeSpec (spec) where import TestImport spec :: Spec spec = withApp $ do - it "loads the index and checks it looks right" $ do - get HomeR - statusIs 200 - htmlAllContain "h1" "Welcome to Yesod" - request $ do - setMethod "POST" - setUrl HomeR - addToken - fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference - byLabel "What's on the file?" "Some Content" + describe "Homepage" $ do + it "loads the index and checks it looks right" $ do + get HomeR + statusIs 200 + htmlAnyContain "h1" "Welcome to Gonito.net!" - statusIs 200 - -- more debugging printBody - htmlCount ".message" 1 - htmlAllContain ".message" "Some Content" - htmlAllContain ".message" "text/plain" - - -- This is a simple example of using a database access in a test. The - -- test will succeed for a fresh scaffolded site with an empty database, - -- but will fail on an existing database with a non-empty user table. - it "leaves the user table empty" $ do - get HomeR - statusIs 200 - users <- runDB $ selectList ([] :: [Filter User]) [] - assertEqual "user table empty" 0 $ length users + -- This is a simple example of using a database access in a test. The + -- test will succeed for a fresh scaffolded site with an empty database, + -- but will fail on an existing database with a non-empty user table. + it "leaves the user table empty" $ do + get HomeR + statusIs 200 + users <- runDB $ selectList ([] :: [Filter User]) [] + assertEq "user table empty" 0 $ length users diff --git a/test/TestImport.hs b/test/TestImport.hs index a735b38..a43f863 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,18 +1,23 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module TestImport ( module TestImport , module X ) where -import Application (makeFoundation) -import ClassyPrelude as X +import Application (makeFoundation, makeLogWare) +import ClassyPrelude as X hiding (delete, deleteBy, Handler) import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) +import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) import Foundation as X import Model as X import Test.Hspec as X import Text.Shakespeare.Text (st) -import Yesod.Default.Config2 (ignoreEnv, loadAppSettings) +import Yesod.Default.Config2 (useEnv, loadYamlSettings) +import Yesod.Auth as X import Yesod.Test as X +import Yesod.Core.Unsafe (fakeHandlerGetLogger) runDB :: SqlPersistM a -> YesodExample App a runDB query = do @@ -22,16 +27,22 @@ runDB query = do runDBWithApp :: App -> SqlPersistM a -> IO a runDBWithApp app query = runSqlPersistMPool query (appConnPool app) +runHandler :: Handler a -> YesodExample App a +runHandler handler = do + app <- getTestYesod + fakeHandlerGetLogger appLogger app handler -withApp :: SpecWith App -> Spec + +withApp :: SpecWith (TestApp App) -> Spec withApp = before $ do - settings <- loadAppSettings + settings <- loadYamlSettings ["config/test-settings.yml", "config/settings.yml"] [] - ignoreEnv + useEnv foundation <- makeFoundation settings wipeDB foundation - return foundation + logWare <- liftIO $ makeLogWare foundation + return (foundation, logWare) -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each @@ -45,7 +56,7 @@ wipeDB app = runDBWithApp app $ do query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables rawExecute query [] -getTables :: MonadIO m => ReaderT SqlBackend m [Text] +getTables :: DB [Text] getTables = do tables <- rawSql [st| SELECT table_name @@ -54,3 +65,31 @@ getTables = do |] [] return $ map unSingle tables + +-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag +-- being set in test-settings.yaml, which enables dummy authentication in +-- Foundation.hs +authenticateAs :: Entity User -> YesodExample App () +authenticateAs (Entity _ u) = do + request $ do + setMethod "POST" + addPostParam "ident" $ userIdent u + setUrl $ AuthR $ PluginR "dummy" [] + +-- | Create a user. The dummy email entry helps to confirm that foreign-key +-- checking is switched off in wipeDB for those database backends which need it. +createUser :: Text -> YesodExample App (Entity User) +createUser ident = runDB $ do + user <- insertEntity User + { userIdent = ident + , userPassword = Nothing + , userName = Nothing + , userIsAdmin = False + , userLocalId = Nothing + , userIsAnonymous = False + , userAvatar = Nothing + , userVerificationKey = Nothing + , userKeyExpirationDate = Nothing + , userTriggerToken = Nothing + } + return user