fradrive/test/ModelSpec.hs

{-# 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 System.FilePath
import Data.Time

import Data.CryptoID.Poly
import qualified Data.CryptoID.Class.ImplicitNamespace as Implicit

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

import System.IO.Unsafe (unsafePerformIO)

import Data.Conduit
import qualified Data.Conduit.Combinators as C

import Data.Ratio ((%))

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) (\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 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
    <*> return Nothing
    <*> arbitrary
  shrink = genericShrink

instance Arbitrary Tutorial where
  arbitrary = Tutorial
    <$> (CI.mk . pack . getPrintableString <$> arbitrary)
    <*> arbitrary
    <*> (CI.mk . pack . getPrintableString <$> arbitrary)
    <*> (fmap getPositive <$> arbitrary)
    <*> (assertM' (not . null) . pack . getPrintableString <$> arbitrary)
    <*> arbitrary
    <*> (fmap (CI.mk . pack . getPrintableString) <$> 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

    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

    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 (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where
  arbitrary = C.sourceLazy <$> arbitrary

scaleRatio :: Rational -> Int -> Int
scaleRatio r = ceiling . (* r) . fromIntegral

instance Monad m => Arbitrary (File m) where
  arbitrary = do
    fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
    fileContent <- oneof
      [ pure Nothing
      , Just <$> scale (scaleRatio $ 7 % 8) 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

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
    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 Arbitrary VerpMode where
  arbitrary = genericArbitrary
  shrink = genericShrink


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