Bring back tests

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 =

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

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

test/Handler/HomeSpec.hs

@@ -1,26 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Handler.HomeSpec (spec) where
 
 import TestImport
 
 spec :: Spec
 spec = withApp $ do
+
+    describe "Homepage" $ do
         it "loads the index and checks it looks right" $ do
           get HomeR
           statusIs 200
-        htmlAllContain "h1" "Welcome to Yesod"
+          htmlAnyContain "h1" "Welcome to Gonito.net!"
-
-        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"
-
-        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,
@@ -29,4 +20,4 @@ spec = withApp $ do
           get HomeR
           statusIs 200
           users <- runDB $ selectList ([] :: [Filter User]) []
-        assertEqual "user table empty" 0 $ length users
+          assertEq "user table empty" 0 $ length users

test/TestImport.hs

@@ -1,18 +1,23 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 module TestImport
     ( module TestImport
     , module X
     ) where
 
-import Application           (makeFoundation)
+import Application           (makeFoundation, makeLogWare)
-import ClassyPrelude         as X
+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