fradrive/test/ModelSpec.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

module ModelSpec where

import TestImport

import Settings (getTimeLocale', VerpMode(..))

import Model.TypesSpec ()
import MailSpec ()

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 Data.CryptoID.Poly
import qualified Data.CryptoID.Class.ImplicitNamespace as Implicit
import qualified Data.CryptoID.Class as Explicit
import Data.Binary.SerializationLength

import Control.Monad.Catch.Pure (Catch, runCatch)

import System.IO.Unsafe (unsafePerformIO)

import Data.Universe


instance Arbitrary EmailAddress where
    arbitrary = do
      local  <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
      domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (isEmail (CBS.pack "example"))
      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 Course where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Sheet where
  arbitrary = Sheet
    <$> arbitrary
    <*> (CI.mk . pack . getPrintableString <$> arbitrary)
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> pure Nothing
    <*> arbitrary
    <*> arbitrary
    <*> pure Nothing
    <*> pure Nothing

instance Arbitrary Tutorial where
  arbitrary = Tutorial
    <$> (CI.mk . pack . getPrintableString <$> arbitrary)
    <*> arbitrary
    <*> (CI.mk . pack . getPrintableString <$> arbitrary)
    <*> (fmap getPositive <$> arbitrary)
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
  shrink = genericShrink

instance Arbitrary User where
  arbitrary = do
    userIdent <- CI.mk . pack <$> oneof
      [ getPrintableString <$> arbitrary
      , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
      ]
    userAuthentication <- arbitrary
    userLastAuthentication <- arbitrary
    userTokensIssuedAfter <- arbitrary
    userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
    userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
    userDisplayEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary

    names <- listOf1 $ pack . getPrintableString <$> arbitrary
    userDisplayName <- unwords <$> sublistOf names
    userSurname <- unwords <$> sublistOf names
    userFirstName <- unwords <$> sublistOf names
    userTitle <- fmap (pack . getPrintableString) <$> arbitrary
    userSex <- arbitrary
    userBirthday <- arbitrary

    userMaxFavourites <- getNonNegative <$> arbitrary
    userMaxFavouriteTerms <- 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
    userWarningDays <- arbitrary
    userLanguages <- arbitrary
    userNotificationSettings <- arbitrary
    userCsvOptions <- arbitrary
    userShowSex <- arbitrary
    userMobile                <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
    userTelephone             <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
    userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
    userCompanyDepartment <- arbitrary
    userPinPassword <- arbitrary
    userPostAddress <- arbitrary -- TODO: not a good address
    userPostLastUpdate <- arbitrary
    userPrefersPostal <- arbitrary
    userExamOfficeGetSynced <- arbitrary
    userExamOfficeGetLabels <- arbitrary

    userCreated <- arbitrary
    userLastLdapSynchronisation <- arbitrary
    userLdapPrimaryKey <- oneof
      [ pure Nothing
      , fmap Just $ pack <$> oneof
        [ getPrintableString <$> arbitrary
        , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
        ]
      ]

    return User{..}
  shrink = genericShrink

instance Arbitrary ExamModePredicate where
  arbitrary = elements universeF

instance Arbitrary p => Arbitrary (PredLiteral p) where
  arbitrary = elements [PLVariable, PLNegated] <*> arbitrary

instance (Arbitrary p, Ord p) => Arbitrary (PredDNF p) where
  arbitrary = PredDNF . Set.fromList . mapMaybe (fromNullable . Set.fromList) <$> arbitrary
  shrink = fmap (PredDNF . Set.fromList . mapMaybe (fromNullable . Set.fromList)) . shrink . map otoList . otoList . dnfTerms

deriving newtype instance Arbitrary ExamModeDNF

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
    schoolExamMinimumRegisterBeforeStart <- arbitrary
    schoolExamMinimumRegisterDuration <- arbitrary
    schoolExamRequireModeForRegistration <- arbitrary
    schoolExamDiscouragedModes <- arbitrary
    schoolExamCloseMode <- arbitrary
    schoolSheetAuthorshipStatementMode <- arbitrary
    let schoolSheetAuthorshipStatementDefinition = Nothing
    schoolSheetAuthorshipStatementAllowOther <- arbitrary
    schoolSheetExamAuthorshipStatementMode <- arbitrary
    let schoolSheetExamAuthorshipStatementDefinition = Nothing
    schoolSheetExamAuthorshipStatementAllowOther <- arbitrary
    return School{..}

instance Arbitrary Term where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance {-# OVERLAPS #-} (HasCryptoID ns ct pt (ReaderT CryptoIDKey Catch), Arbitrary pt, ns ~ Implicit.CryptoIDNamespace ct pt) => Arbitrary (pt, CryptoID ns ct) where
  arbitrary = arbitrary <&> \pt -> (pt, either (error . show) id . runCatch $ runReaderT (Implicit.encrypt pt) tmpKey)
    where
      tmpKey = unsafePerformIO genKey

instance HasFixedSerializationLength () where
  type SerializationLength () = 0

instance HasCryptoID ns ct () (ReaderT CryptoIDKey Catch) => Arbitrary (CryptoID ns ct) where
  arbitrary = return . either (error . show) id . runCatch $ runReaderT (Explicit.encrypt ()) tmpKey
    where
      tmpKey = unsafePerformIO genKey

instance CoArbitrary ct => CoArbitrary (CryptoID ns ct)
instance Function ct => Function (CryptoID ns ct)

instance Arbitrary VerpMode where
  arbitrary = genericArbitrary
  shrink = genericShrink


spec :: Spec
spec = do
  parallel $ do
    lawsCheckHspec (Proxy @User)
      [ eqLaws, jsonLaws ]
    lawsCheckHspec (Proxy @School)
      [ eqLaws ]
    lawsCheckHspec (Proxy @Term)
      [ eqLaws, jsonLaws ]
    lawsCheckHspec (Proxy @VerpMode)
      [ eqLaws, showReadLaws, jsonLaws ]