fradrive/test/ModelSpec.hs

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

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

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

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

import System.IO.Unsafe (unsafePerformIO)


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
  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

    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

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

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