Additional tests & cleanup

2019-01-16 23:47:21 +01:00 · 2019-01-16 23:47:21 +01:00 · 7f103ec7a9
commit 7f103ec7a9
parent 25252e867e
18 changed files with 301 additions and 112 deletions
--- a/models/courses
+++ b/models/courses
@ -19,6 +19,7 @@ Course
    materialFree     Bool
    TermSchoolCourseShort  term school shorthand
    TermSchoolCourseName   term school name
+    deriving Generic
 CourseEdit
    user         UserId
    time         UTCTime
--- a/models/schools
+++ b/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
--- a/models/sheets
+++ b/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
--- a/models/submissions
+++ b/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
--- a/models/terms
+++ b/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
--- a/models/users
+++ b/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
--- a/package.yaml
+++ b/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: []
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/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
-      FormSuccess pi
-        | not (piIsUnset pi)
-          -> runPSValidator dbtable $ Just pi
-      FormFailure errs'
-          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
-      _   -> runPSValidator dbtable Nothing
-    paginationInput@PaginationInput{..}
+    ((errs, PaginationSettings{..}), 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
-        | Just ps <- previousKeys = sortOn (\(_, dbrKey, _) -> elemIndex dbrKey ps) rows
-        | otherwise = rows
+      reproduceSorting
+        | Just ps <- previousKeys
+        = 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'

--- a/src/Handler/Utils/Table/Pagination/Types.hs
+++ b/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)


--- a/test/Handler/CorrectionsSpec.hs
+++ b/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 ()
--- a/test/Handler/Utils/Table/Pagination/TypesSpec.hs
+++ b/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 ]
--- a/test/Handler/Utils/Table/PaginationSpec.hs
+++ b/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 == "{}")
--- a/test/Handler/Utils/ZipSpec.hs
+++ b/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
-  arbitrary = do
-    fileTitle <- (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{..}
-  shrink = genericShrink
+import ModelSpec ()
+
+import System.FilePath
+import Data.Time

 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
--- a/test/MailSpec.hs
+++ b/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)
-    [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
-  lawsCheckHspec (Proxy @MailLanguages)
-    [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
-  lawsCheckHspec (Proxy @MailContext)
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
-  lawsCheckHspec (Proxy @VerpMode)
-    [ eqLaws, showReadLaws, jsonLaws ]
+  parallel $ do
+    lawsCheckHspec (Proxy @MailSmtpData)
+      [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
+      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @MailContext)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, showReadLaws, jsonLaws ]
--- a/test/Model/TypesSpec.hs
+++ b/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
@ -126,64 +126,79 @@ instance Arbitrary Value where
      arbitrary' :: forall a. Arbitrary a => Gen a
      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)
-    [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
-  lawsCheckHspec (Proxy @FilePath)
-    [ pathMultiPieceLaws ]
-  lawsCheckHspec (Proxy @(CI Text))
-    [ httpApiDataLaws ]
-  lawsCheckHspec (Proxy @SheetGrading)
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @SheetGradeSummary)
-    [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
-  lawsCheckHspec (Proxy @SheetType)
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @SheetTypeSummary)
-    [ eqLaws, showReadLaws, commutativeMonoidLaws ]
-  lawsCheckHspec (Proxy @SheetGroup)
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @SheetFileType)
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-  lawsCheckHspec (Proxy @SubmissionFileType)
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
-  lawsCheckHspec (Proxy @UploadMode)
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-  lawsCheckHspec (Proxy @SheetSubmissionMode)
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
-  lawsCheckHspec (Proxy @ExamStatus)
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @Load)
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
-  lawsCheckHspec (Proxy @Season)
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
-  lawsCheckHspec (Proxy @TermIdentifier)
-    [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
-  lawsCheckHspec (Proxy @StudyFieldType)
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @Theme)
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @CorrectorState)
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @AuthenticationMode)
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @Value)
-    [ persistFieldLaws ]
-  lawsCheckHspec (Proxy @NotificationTrigger)
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
-  lawsCheckHspec (Proxy @NotificationSettings)
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @MailLanguages)
-    [ persistFieldLaws ]
-  lawsCheckHspec (Proxy @Pseudonym)
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
-  lawsCheckHspec (Proxy @AuthTag)
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
-  lawsCheckHspec (Proxy @AuthTagActive)
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+  parallel $ do
+    lawsCheckHspec (Proxy @UUID)
+      [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
+    lawsCheckHspec (Proxy @FilePath)
+      [ pathMultiPieceLaws ]
+    lawsCheckHspec (Proxy @(CI Text))
+      [ httpApiDataLaws ]
+    lawsCheckHspec (Proxy @SheetGrading)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetGradeSummary)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
+    lawsCheckHspec (Proxy @SheetType)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetTypeSummary)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @SheetGroup)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetFileType)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SubmissionFileType)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @UploadMode)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SheetSubmissionMode)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @ExamStatus)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Load)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @Season)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
+    lawsCheckHspec (Proxy @TermIdentifier)
+      [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @StudyFieldType)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Theme)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @CorrectorState)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthenticationMode)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Value)
+      [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @NotificationTrigger)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @NotificationSettings)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
+      [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @Pseudonym)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthTag)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @AuthTagActive)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]

  describe "TermIdentifier" $ do
    it "has compatible encoding/decoding to/from Text" . property $
--- a/test/ModelSpec.hs
+++ b/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 ]
--- a/test/TestImport.hs
+++ b/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
--- a/test/Utils/DateTimeSpec.hs
+++ b/test/Utils/DateTimeSpec.hs
@ -14,7 +14,8 @@ instance CoArbitrary SelDateTimeFormat where

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