Commits

Anonymous committed a26c8bb

Add basic testing framework

Comments (0)

Files changed (6)

 syntax:glob
 dist/
 .*.swp
+client_session_key.aes
+test.db3

tests/BasicTests.hs

+{-# LANGUAGE OverloadedStrings #-}
+module BasicTests (basicSpecs) where
+
+import Yesod.Test
+import Database.Persist.Sqlite
+
+basicSpecs :: SpecsConn Connection
+basicSpecs =
+    describe "Some basic tests" $
+        it "home page is not logged in" $ do
+            get_ "/"
+            statusIs 200
+            bodyContains "Please visit the <a href=\"/auth/login\">Login page"

tests/Foundation.hs

+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-}
+
+module Foundation where
+
+import Data.Text (Text)
+import Data.ByteString (ByteString)
+import Database.Persist.Sqlite
+import Data.IORef
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.Account
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+User
+    username Text
+    UniqueUsername username
+    password ByteString
+    emailAddress Text
+    verified Bool
+    verifyKey Text
+    resetPasswordKey Text
+    deriving Show
+|]
+
+instance PersistUserCredentials User where
+    userUsernameF = UserUsername
+    userPasswordHashF = UserPassword
+    userEmailF = UserEmailAddress
+    userEmailVerifiedF = UserVerified
+    userEmailVerifyKeyF = UserVerifyKey
+    userResetPwdKeyF = UserResetPasswordKey
+    uniqueUsername = UniqueUsername
+
+    userCreate name email key pwd = User name pwd email False key ""
+
+data MyApp = MyApp { connPool :: ConnectionPool
+                   , lastVerifyEmailR :: IORef (Username, Text, Text) -- ^ (username, email, verify url)
+                   , lastNewPwdEmailR :: IORef (Username, Text, Text) -- ^ (username, email, verify url)
+                   }
+
+lastVerifyEmail :: GHandler s MyApp (Username, Text, Text)
+lastVerifyEmail = do
+    app <- getYesod
+    liftIO $ readIORef $ lastVerifyEmailR app
+
+lastNewPwdEmail :: GHandler s MyApp (Username, Text, Text)
+lastNewPwdEmail = do
+    app <- getYesod
+    liftIO $ readIORef $ lastNewPwdEmailR app
+
+mkYesod "MyApp" [parseRoutes|
+/ HomeR GET
+/auth AuthR Auth getAuth
+|]
+
+instance Yesod MyApp
+
+instance RenderMessage MyApp FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+instance YesodPersist MyApp where
+    type YesodPersistBackend MyApp = SqlPersist
+    runDB action = do
+        app <- getYesod
+        runSqlPool action $ connPool app
+
+instance YesodAuth MyApp where
+    type AuthId MyApp = Username
+    getAuthId = return . Just . credsIdent
+    loginDest _ = HomeR
+    logoutDest _ = HomeR
+    authPlugins _ = [accountPlugin]
+    authHttpManager _ = error "No manager needed"
+    onLogin = return ()
+
+instance AccountSendEmail MyApp where
+    sendVerifyEmail name email url = do
+        app <- getYesod
+        liftIO $ writeIORef (lastVerifyEmailR app) (name, email, url)
+
+    sendNewPasswordEmail name email url = do
+        app <- getYesod
+        liftIO $ writeIORef (lastNewPwdEmailR app) (name, email, url)
+
+instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where
+    runAccountDB = runAccountPersistDB
+
+getHomeR :: Handler RepHtml
+getHomeR = do
+    maid <- maybeAuthId
+    case maid of
+        Nothing -> defaultLayout $ [whamlet|
+<p>Please visit the <a href="@{AuthR LoginR}">Login page</a>
+|]
+        Just u -> defaultLayout $ [whamlet|
+<p>You are logged in as #{u}
+<p><a href="@{AuthR LogoutR}">Logout</a>
+|]

tests/HomeTest.hs

+{-# LANGUAGE OverloadedStrings #-}
+module HomeTest
+    ( homeSpecs
+    ) where
+
+import TestImport
+
+homeSpecs :: Specs
+homeSpecs =
+  describe "These are some example tests" $
+    it "loads the index and checks it looks right" $ do
+      get_ "/"
+      statusIs 200
+      htmlAllContain "h1" "Hello"
+
+      post "/" $ do
+        addNonce
+        fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference
+        byLabel "What's on the file?" "Some Content"
+
+      statusIs 200
+      htmlCount ".message" 1
+      htmlAllContain ".message" "Some Content"
+      htmlAllContain ".message" "text/plain"
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Yesod
+import Foundation
+import Yesod.Test
+import Data.IORef
+import Database.Persist.Sqlite
+import Control.Monad.Logger (runStderrLoggingT)
+
+import BasicTests
+
+main :: IO ()
+main = do
+    verify <- newIORef ("", "", "")
+    newPwd <- newIORef ("", "", "")
+
+    withSqlitePool "test.db3" 10 $ \pool -> do
+        runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool
+        let myapp = MyApp pool verify newPwd
+        app <- toWaiAppPlain myapp
+        runTests app pool basicSpecs

yesod-auth-account.cabal

                  , yesod-form        >= 1.2        && < 1.3
                  , yesod-persistent  >= 1.1
 
+test-suite test
+    type:              exitcode-stdio-1.0
+    main-is:           main.hs
+    hs-source-dirs:    tests
+    ghc-options:       -Wall
+
+    build-depends: base
+                 , bytestring
+                 , monad-logger >= 0.3
+                 , persistent-sqlite
+                 , text
+                 , yesod
+                 , yesod-test
+                 , yesod-auth
+                 , yesod-auth-account