From 7f103ec7a93425e8ea523b76284417e7f7643100 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 16 Jan 2019 23:47:21 +0100 Subject: [PATCH] Additional tests & cleanup --- models/courses | 1 + models/schools | 2 +- models/sheets | 1 + models/submissions | 2 +- models/terms | 2 +- models/users | 2 +- package.yaml | 3 + src/Handler/Utils/Table/Pagination.hs | 29 ++-- src/Handler/Utils/Table/Pagination/Types.hs | 4 +- test/Handler/CorrectionsSpec.hs | 11 ++ .../Utils/Table/Pagination/TypesSpec.hs | 22 +++ test/Handler/Utils/Table/PaginationSpec.hs | 43 ++++++ test/Handler/Utils/ZipSpec.hs | 23 +-- test/MailSpec.hs | 19 +-- test/Model/TypesSpec.hs | 131 ++++++++++-------- test/ModelSpec.hs | 107 ++++++++++++++ test/TestImport.hs | 2 +- test/Utils/DateTimeSpec.hs | 9 +- 18 files changed, 301 insertions(+), 112 deletions(-) create mode 100644 test/Handler/CorrectionsSpec.hs create mode 100644 test/Handler/Utils/Table/Pagination/TypesSpec.hs create mode 100644 test/Handler/Utils/Table/PaginationSpec.hs create mode 100644 test/ModelSpec.hs diff --git a/models/courses b/models/courses index 80b2ac5ac..96bba0195 100644 --- 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 diff --git a/models/schools b/models/schools index b253c7390..625235f2f 100644 --- 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 diff --git a/models/sheets b/models/sheets index 207f22ee0..8fd75eae1 100644 --- 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 diff --git a/models/submissions b/models/submissions index db7e543a6..ff998b845 100644 --- 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 diff --git a/models/terms b/models/terms index ba6cafd73..698a6a6d1 100644 --- 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 diff --git a/models/users b/models/users index 0cd2d682a..5ac4a6a3c 100644 --- 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 diff --git a/package.yaml b/package.yaml index 1bd402afd..fcfce4831 100644 --- 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: [] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7c25163fe..c48f8b2d9 100644 --- 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' diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index fb53015fd..44648cf21 100644 --- 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) diff --git a/test/Handler/CorrectionsSpec.hs b/test/Handler/CorrectionsSpec.hs new file mode 100644 index 000000000..a26d1c1bd --- /dev/null +++ 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 () diff --git a/test/Handler/Utils/Table/Pagination/TypesSpec.hs b/test/Handler/Utils/Table/Pagination/TypesSpec.hs new file mode 100644 index 000000000..f1f29506a --- /dev/null +++ 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 ] diff --git a/test/Handler/Utils/Table/PaginationSpec.hs b/test/Handler/Utils/Table/PaginationSpec.hs new file mode 100644 index 000000000..df8a7fd91 --- /dev/null +++ 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 == "{}") diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index 19e176840..eaa471881 100644 --- 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 diff --git a/test/MailSpec.hs b/test/MailSpec.hs index 6743f99fa..c9972548d 100644 --- 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 ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index bd192c991..bfe154a02 100644 --- 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 $ diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs new file mode 100644 index 000000000..33a54c2e3 --- /dev/null +++ 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 ] diff --git a/test/TestImport.hs b/test/TestImport.hs index 344021b64..9d84e8722 100644 --- 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 diff --git a/test/Utils/DateTimeSpec.hs b/test/Utils/DateTimeSpec.hs index e851c95e9..b2480749d 100644 --- 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 ]