Additional tests & cleanup

models/courses

@@ -19,6 +19,7 @@ Course
     materialFree     Bool
     TermSchoolCourseShort  term school shorthand
     TermSchoolCourseName   term school name
+    deriving Generic
 CourseEdit
     user         UserId
     time         UTCTime

models/schools

@@ -4,4 +4,4 @@ School json
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
     Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
-    deriving Eq
+    deriving Eq Show Generic

models/sheets

@@ -14,6 +14,7 @@ Sheet
     submissionMode  SheetSubmissionMode default='UserSubmissions'
     autoDistribute  Bool default=false
     CourseSheet course name
+    deriving Generic
 SheetEdit
     user            UserId
     time            UTCTime

models/submissions

@@ -5,7 +5,7 @@ Submission
     ratingBy        UserId  Maybe -- assigned corrector
     ratingAssigned  UTCTime Maybe -- time assigned corrector
     ratingTime      UTCTime Maybe -- "Just" here indicates done!
-    deriving Show
+    deriving Show Generic
 SubmissionEdit
     user            UserId
     time            UTCTime

models/terms

@@ -7,4 +7,4 @@ Term json
     lectureEnd    Day
     active        Bool
     Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
-    deriving Show      -- type TermId = Key Term
+    deriving Show Eq Generic -- type TermId = Key Term

models/users

@@ -15,7 +15,7 @@ User json
     notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
-    deriving Show Eq
+    deriving Show Eq Generic
 UserAdmin
     user   UserId
     school SchoolId

package.yaml

@@ -231,6 +231,9 @@ tests:
       - http-types
     ghc-options:
       - -fno-warn-orphans
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
   hlint:
     main: Hlint.hs
     other-modules: []

src/Handler/Utils/Table/Pagination.hs

@@ -3,6 +3,7 @@
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , SortColumn(..), SortDirection(..)
+  , SortingSetting(..)
   , pattern SortAscBy, pattern SortDescBy
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
@@ -10,6 +11,7 @@ module Handler.Utils.Table.Pagination
   , DBTable(..), IsDBTable(..), DBCell(..)
   , DBParams(..)
   , cellAttrs, cellContents
+  , PagesizeLimit(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
   , defaultFilter, defaultSorting
@@ -92,7 +94,7 @@ $(sqlInTuples [2..16])
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
 data SortDirection = SortAsc | SortDesc
-  deriving (Eq, Ord, Enum, Bounded, Show, Read)
+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
 
 instance Universe SortDirection
 instance Finite SortDirection
@@ -114,7 +116,7 @@ sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
 data SortingSetting = SortingSetting
   { sortKey :: SortingKey
   , sortDir :: SortDirection
-  } deriving (Eq, Ord, Show, Read)
+  } deriving (Eq, Ord, Show, Read, Generic)
 
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
@@ -606,19 +608,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
 
   let
-    (errs, PaginationSettings{..}) = case piResult of
+    ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
-      FormSuccess pi
-        | not (piIsUnset pi)
-          -> runPSValidator dbtable $ Just pi
-      FormFailure errs'
-          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
-      _   -> runPSValidator dbtable Nothing
-    paginationInput@PaginationInput{..}
       | FormSuccess pi <- piResult
       , not $ piIsUnset pi
-      = pi
+      = (, pi) . runPSValidator dbtable $ Just pi
+      | FormFailure errs' <- piResult
+      = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
       | otherwise
-      = def
+      = (, def) $ runPSValidator dbtable Nothing
     psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
 
   mapM_ (addMessageI Warning) errs
@@ -644,9 +641,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         = succ (psPage * l)
         | otherwise
         = 1
-      reproduceSorting rows
+      reproduceSorting
-        | Just ps <- previousKeys = sortOn (\(_, dbrKey, _) -> elemIndex dbrKey ps) rows
+        | Just ps <- previousKeys
-        | otherwise = rows
+        = sortOn $ \(_, dbrKey, _) -> elemIndex dbrKey ps
+        | otherwise
+        = id
 
   (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
 

src/Handler/Utils/Table/Pagination/Types.hs

@@ -29,10 +29,10 @@ import Data.List (foldr1, foldl)
 
 
 newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
-  deriving (Show, Read)
+  deriving (Show, Read, Generic)
   deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
 newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
-  deriving (Show, Read)
+  deriving (Show, Read, Generic)
   deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
 
 

test/Handler/CorrectionsSpec.hs

@@ -0,0 +1,11 @@
+module Handler.CorrectionsSpec where
+
+import TestImport
+
+import ModelSpec ()
+
+
+spec :: Spec
+spec = withApp $ do
+  describe "CorrectionsR" $ do
+    return ()

test/Handler/Utils/Table/Pagination/TypesSpec.hs

@@ -0,0 +1,22 @@
+module Handler.Utils.Table.Pagination.TypesSpec where
+
+import TestImport
+
+import Handler.Utils.Table.Pagination.Types
+
+
+instance Arbitrary FilterKey where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary SortingKey where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+spec :: Spec
+spec = do
+  parallel $ do
+    lawsCheckHspec (Proxy @FilterKey)
+      [ eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @SortingKey)
+      [ eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws ]

test/Handler/Utils/Table/PaginationSpec.hs

@@ -0,0 +1,43 @@
+module Handler.Utils.Table.PaginationSpec where
+
+import TestImport
+
+import Handler.Utils.Table.Pagination
+import Handler.Utils.Table.Pagination.TypesSpec ()
+
+import Data.Aeson (encode)
+  
+
+instance Arbitrary SortDirection where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+  
+instance Arbitrary SortingSetting where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+  
+instance Arbitrary PaginationInput where
+  arbitrary = scale (`div` 2) genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary PagesizeLimit where
+  arbitrary = oneof
+    [ pure PagesizeAll
+    , PagesizeLimit . getNonNegative <$> arbitrary
+    ]
+  shrink = genericShrink
+
+spec :: Spec
+spec = do
+  parallel $ do
+    lawsCheckHspec (Proxy @SortDirection)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, pathPieceLaws, finiteLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @SortingSetting)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @PaginationInput)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @PagesizeLimit)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, pathPieceLaws, jsonLaws ]
+  
+  describe "PaginationInput" $ do
+    it "is unset iff it encodes to {}" . property $ \inp -> piIsUnset inp == (encode inp == "{}")

test/Handler/Utils/ZipSpec.hs

@@ -4,22 +4,15 @@ import TestImport
 
 import Handler.Utils.Zip
 
-import System.FilePath
-
 import Data.Conduit
 import qualified Data.Conduit.List as Conduit
 
 import Data.List (dropWhileEnd)
-import Data.Time
 
-instance Arbitrary File where
+import ModelSpec ()
-  arbitrary = do
+
-    fileTitle <- (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
+import System.FilePath
-    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
+import Data.Time
-    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
-    fileContent <- arbitrary
-    return File{..}
-  shrink = genericShrink
 
 spec :: Spec
 spec = describe "Zip file handling" $ do
@@ -34,11 +27,3 @@ spec = describe "Zip file handling" $ do
         (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
         (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference
         (fileContent file') `shouldBe` (fileContent file)
-
-inZipRange :: UTCTime -> Bool
-inZipRange time
-  | time > UTCTime (fromGregorian 1980 1 1) 0
-  , time < UTCTime (fromGregorian 2107 1 1) 0
-  = True
-  | otherwise
-  = False

test/MailSpec.hs

@@ -10,7 +10,7 @@ instance Arbitrary MailSmtpData where
   shrink = genericShrink
 
 instance Arbitrary MailLanguages where
-  arbitrary = MailLanguages <$> arbitrary
+  arbitrary = fmap MailLanguages $ shuffle =<< sublistOf (toList appLanguages)
   shrink = genericShrink
 
 instance Arbitrary MailContext where
@@ -23,11 +23,12 @@ instance Arbitrary VerpMode where
 
 spec :: Spec
 spec = do
-  lawsCheckHspec (Proxy @MailSmtpData)
+  parallel $ do
-    [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
+    lawsCheckHspec (Proxy @MailSmtpData)
-  lawsCheckHspec (Proxy @MailLanguages)
+      [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
-    [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
-  lawsCheckHspec (Proxy @MailContext)
+      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @MailContext)
-  lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
-    [ eqLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, showReadLaws, jsonLaws ]

test/Model/TypesSpec.hs

@@ -1,6 +1,7 @@
 module Model.TypesSpec where
 
 import TestImport
+import Settings
 
 import Control.Lens (review, preview)
 import Data.Aeson (Value)
@@ -8,6 +9,9 @@ import qualified Data.Aeson as Aeson
 
 import MailSpec ()
 
+import System.IO.Unsafe
+import Yesod.Auth.Util.PasswordStore
+
 
 instance Arbitrary Season where
   arbitrary = genericArbitrary
@@ -89,10 +93,6 @@ instance Arbitrary CorrectorState where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
-instance Arbitrary AuthenticationMode where
-  arbitrary = genericArbitrary
-  shrink = genericShrink
-
 instance Arbitrary NotificationTrigger where
   arbitrary = genericArbitrary
   shrink = genericShrink
@@ -127,63 +127,78 @@ instance Arbitrary Value where
       arbitrary' = scale (`div` 2) arbitrary
   shrink = genericShrink
 
+instance Arbitrary AuthenticationMode where
+  arbitrary = oneof
+    [ pure AuthLDAP
+    , do
+        pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
+        let
+          PWHashConf{..} = appAuthPWHash compileTimeAppSettings
+          authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
+        return $ AuthPWHash{..}
+    ]
+  
+  shrink AuthLDAP = []
+  shrink (AuthPWHash _) = [AuthLDAP]
+  
 
 spec :: Spec
 spec = do
-  lawsCheckHspec (Proxy @UUID)
+  parallel $ do
-    [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
+    lawsCheckHspec (Proxy @UUID)
-  lawsCheckHspec (Proxy @FilePath)
+      [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
-    [ pathMultiPieceLaws ]
+    lawsCheckHspec (Proxy @FilePath)
-  lawsCheckHspec (Proxy @(CI Text))
+      [ pathMultiPieceLaws ]
-    [ httpApiDataLaws ]
+    lawsCheckHspec (Proxy @(CI Text))
-  lawsCheckHspec (Proxy @SheetGrading)
+      [ httpApiDataLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetGrading)
-  lawsCheckHspec (Proxy @SheetGradeSummary)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
+    lawsCheckHspec (Proxy @SheetGradeSummary)
-  lawsCheckHspec (Proxy @SheetType)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetType)
-  lawsCheckHspec (Proxy @SheetTypeSummary)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @SheetTypeSummary)
-  lawsCheckHspec (Proxy @SheetGroup)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetGroup)
-  lawsCheckHspec (Proxy @SheetFileType)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SheetFileType)
-  lawsCheckHspec (Proxy @SubmissionFileType)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SubmissionFileType)
-  lawsCheckHspec (Proxy @UploadMode)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @UploadMode)
-  lawsCheckHspec (Proxy @SheetSubmissionMode)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @SheetSubmissionMode)
-  lawsCheckHspec (Proxy @ExamStatus)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamStatus)
-  lawsCheckHspec (Proxy @Load)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @Load)
-  lawsCheckHspec (Proxy @Season)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
+    lawsCheckHspec (Proxy @Season)
-  lawsCheckHspec (Proxy @TermIdentifier)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
-    [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @TermIdentifier)
-  lawsCheckHspec (Proxy @StudyFieldType)
+      [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @StudyFieldType)
-  lawsCheckHspec (Proxy @Theme)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Theme)
-  lawsCheckHspec (Proxy @CorrectorState)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @CorrectorState)
-  lawsCheckHspec (Proxy @AuthenticationMode)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthenticationMode)
-  lawsCheckHspec (Proxy @Value)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @Value)
-  lawsCheckHspec (Proxy @NotificationTrigger)
+      [ persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @NotificationTrigger)
-  lawsCheckHspec (Proxy @NotificationSettings)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @NotificationSettings)
-  lawsCheckHspec (Proxy @MailLanguages)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
-  lawsCheckHspec (Proxy @Pseudonym)
+      [ persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Pseudonym)
-  lawsCheckHspec (Proxy @AuthTag)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @AuthTag)
-  lawsCheckHspec (Proxy @AuthTagActive)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthTagActive)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

test/ModelSpec.hs

@@ -0,0 +1,107 @@
+module ModelSpec where
+
+import TestImport
+
+import Model.TypesSpec ()
+
+import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Char8 as CBS
+
+import Text.Email.Validate (emailAddress, EmailAddress)
+import qualified Text.Email.Validate as Email (isValid, toByteString)
+
+import qualified Data.Set as Set
+
+import Handler.Utils.DateTime
+
+import qualified Data.Text as Text
+import qualified Data.Char as Char
+
+import Utils
+
+import System.FilePath
+import Data.Time
+
+instance Arbitrary EmailAddress where
+    arbitrary = do
+      local <- suchThat arbitrary (\l -> isEmail l (CBS.pack "example.com"))
+      domain <- suchThat arbitrary (\d -> isEmail (CBS.pack "example") d)
+      let (Just result) = emailAddress (makeEmailLike local domain)
+      pure result
+
+      where
+        isEmail l d = Email.isValid (makeEmailLike l d)
+        makeEmailLike l d = CBS.concat [l, CBS.singleton '@', d]
+
+instance Arbitrary User where
+  arbitrary = do
+    userIdent <- CI.mk . pack <$> oneof
+      [ getPrintableString <$> arbitrary
+      , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
+      ]
+    userAuthentication <- arbitrary
+    userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
+    userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
+
+    names <- listOf1 $ pack . getPrintableString <$> arbitrary
+    userDisplayName <- unwords <$> sublistOf names
+    userSurname <- unwords <$> sublistOf names
+
+    userMaxFavourites <- getNonNegative <$> arbitrary
+    userTheme <- arbitrary
+
+    let genDateTimeFormat sel = do
+          timeLocale <- elements . map getTimeLocale' . pure $ toList appLanguages
+          elements . Set.toList $ validDateTimeFormats timeLocale sel
+    userDateTimeFormat <- genDateTimeFormat SelFormatDateTime
+    userDateFormat <- genDateTimeFormat SelFormatDate
+    userTimeFormat <- genDateTimeFormat SelFormatTime
+
+    userDownloadFiles <- arbitrary
+    userMailLanguages <- arbitrary
+    userNotificationSettings <- arbitrary
+    
+    return User{..}
+  shrink = genericShrink
+
+instance Arbitrary File where
+  arbitrary = do
+    fileTitle <- scale (`div` 2) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
+    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
+    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
+    fileContent <- arbitrary
+    return File{..}
+    where 
+      inZipRange :: UTCTime -> Bool
+      inZipRange time
+        | time > UTCTime (fromGregorian 1980 1 1) 0
+        , time < UTCTime (fromGregorian 2107 1 1) 0
+        = True
+        | otherwise
+        = False
+  shrink = genericShrink
+
+instance Arbitrary School where
+  arbitrary = do
+    names <- listOf1 $ pack . getPrintableString <$> arbitrary
+    let
+      name = Text.toTitle $ unwords names
+      schoolShorthand = CI.mk $ Text.filter Char.isUpper name
+      schoolName = CI.mk name
+    return School{..}
+
+instance Arbitrary Term where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+spec :: Spec
+spec = do
+  parallel $ do
+    lawsCheckHspec (Proxy @User)
+      [ eqLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @File)
+      [ eqLaws ]
+    lawsCheckHspec (Proxy @School)
+      [ eqLaws ]
+    lawsCheckHspec (Proxy @Term)
+      [ eqLaws, jsonLaws ]

test/TestImport.hs

@@ -122,7 +122,7 @@ createUser adjUser = do
   runDB . insertEntity $ adjUser User{..}
 
 lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec
-lawsCheckHspec p = describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))
+lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))
   where
     checkHspec (Laws className properties) = describe className $
       forM_ properties $ \(name, prop) -> it name $ property prop

test/Utils/DateTimeSpec.hs

@@ -14,7 +14,8 @@ instance CoArbitrary SelDateTimeFormat where
 
 spec :: Spec
 spec = do
-  lawsCheckHspec (Proxy @DateTimeFormat)
+  parallel $ do
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @DateTimeFormat)
-  lawsCheckHspec (Proxy @SelDateTimeFormat)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, hashableLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @SelDateTimeFormat)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]