Get yesod test working

models

@@ -139,7 +139,7 @@ File
     title           FilePath
     content         ByteString Maybe -- Nothing iff this is a directory
     modified        UTCTime
-    deriving Show Eq
+    deriving Show Eq Generic
 Submission
     sheet           SheetId
     ratingPoints    Points  Maybe -- "Just" does not mean done

templates/widgets/campus-login-form.hamlet

@@ -1,2 +1,2 @@
-<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype}>
+<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype} #login--campus>
   ^{login}

templates/widgets/dummy-login-form.hamlet

@@ -1,2 +1,2 @@
-<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
+<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype} #login--dummy>
   ^{login}

templates/widgets/hash-login-form.hamlet

@@ -1,2 +1,2 @@
-<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
+<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype} #login--hash>
   ^{login}

test/Handler/ProfileSpec.hs

@@ -4,20 +4,42 @@ module Handler.ProfileSpec (spec) where
 
 import TestImport
 
+import qualified Data.CaseInsensitive as CI
+
+import Yesod.Core.Handler (toTextUrl)
+import Yesod.Core.Unsafe (fakeHandlerGetLogger)
+
 spec :: Spec
 spec = withApp $ do
+  describe "Profile page" $ do
+    it "asserts no access to my-account for anonymous users" $ do
+      get ProfileR
 
-    describe "Profile page" $ do
+      app <- getTestYesod
-        it "asserts no access to my-account for anonymous users" $ do
+      loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR)
-            get ProfileR
-            loc <- getLocation
-            assertEq "Redirect is to Login" loc 
-            either (fail . unpack) (\_ -> return ()) =<< followRedirect
-            statusIs 200
 
-        it "asserts access to my-account for authenticated users" $ do
+      assertHeader "Location" $ encodeUtf8 loginText
-            userEntity <- createUser "foo"
+  
-            authenticateAs userEntity
+      either (fail . unpack) (\_ -> return ()) =<< followRedirect
+      statusIs 200
+
+    it "asserts access to my-account for authenticated users" $ do
+      userEntity <- createUser "foo"
+      authenticateAs userEntity
+
+      get ProfileR
+      statusIs 200
+
+    it "displays basic user data" $ do
+      userEntity@(Entity _userId User{..}) <- createUser "foo"
+      authenticateAs userEntity
+
+      get ProfileDataR
+      statusIs 200
+
+      forM_ (words userDisplayName) $ \nameWord -> do
+        htmlAnyContain ".profile dd" $ unpack nameWord
+      htmlAnyContain ".profile dd" $ unpack userSurname
+      htmlAnyContain ".profile dd" . unpack $ CI.original userIdent
+      htmlAnyContain ".profile dd" . unpack $ CI.original userEmail
           
-            get ProfileR
-            statusIs 200

test/Handler/Utils/ZipSpec.hs

@@ -23,6 +23,7 @@ instance Arbitrary File where
     fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0)
     fileContent <- arbitrary
     return File{..}
+  shrink = genericShrink
 
 spec :: Spec
 spec = describe "Zip file handling" $ do
@@ -31,7 +32,7 @@ spec = describe "Zip file handling" $ do
       zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume
       forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do
         let acceptableFilenameChanges
-              = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid
+              = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid
             acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
         (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
         when (inZipRange $ fileModified file) $

test/Model/TypesSpec.hs

@@ -14,7 +14,7 @@ instance Arbitrary Season where
 instance Arbitrary TermIdentifier where
   arbitrary = do
     season <- arbitrary
-    year <- arbitrary
+    year <- arbitrary `suchThat` (\y -> abs y >= 100)
     return $ TermIdentifier{..}
   shrink = genericShrink
 
@@ -24,8 +24,9 @@ spec = do
     it "has compatible encoding/decoding to/from Text" . property $
       \term -> termFromText (termToText term) == Right term
     it "works for some examples" . mapM_ termExample $
-      [ (TermIdentifier 2017 Summer, "S2017")
+      [ (TermIdentifier 2017 Summer, "S17")
-      , (TermIdentifier 1995 Winter, "W1995")
+      , (TermIdentifier 1995 Winter, "W95")
+      , (TermIdentifier 3068 Winter, "W3068")
       ]
 
 termExample :: (TermIdentifier, Text) -> Expectation

test/TestImport.hs

@@ -75,8 +75,6 @@ wipeDB app = runDBWithApp app $ do
 -- | 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
---
--- FIXME
 authenticateAs :: Entity User -> YesodExample UniWorX ()
 authenticateAs (Entity _ User{..}) = do
   request $ do
@@ -86,7 +84,7 @@ authenticateAs (Entity _ User{..}) = do
   
   request $ do
     setMethod "POST"
-    addTokenFromCookie
+    addToken_ "#login--dummy"
     byLabelExact "Nutzer-Kennung" $ CI.original userIdent
     setUrl $ AuthR $ PluginR "dummy" []