Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

ChangeLog.md

@@ -4,6 +4,8 @@
 
     Liste zugewiesener Abgaben lassen sich nun filtern
     
+    Bugfix: Wenn zwischen Anzeige und Empfang eines Tabellen-Formulars Zeilen verschwinden wird nun eine sinnvolle Fehlermeldung angezeigt
+
   * Version 30.11.2018
 
     Bugfix: Übungsblätter im "bestehen nach Punkten"-Modus werden wieder korrekt gespeichert

config/settings.yml

@@ -66,7 +66,8 @@ ldap:
   pass:    "_env:LDAPPASS:"
   baseDN:  "_env:LDAPBASE:"
   scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout: "_env:LDAPSEARCHTIME:5"
+  timeout: "_env:LDAPTIMEOUT:5"
+  search-timeout: "_env:LDAPSEARCHTIME:5"
   pool:
     stripes: "_env:LDAPSTRIPES:1"
     timeout: "_env:LDAPTIMEOUT:20"

haddock.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+
+exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

messages/uniworx/de.msg

@@ -605,3 +605,5 @@ AuthTagWrite: Zugriff ist i.A. schreibend
 DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
 DeleteConfirmation: Bestätigung
 DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
+
+DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde

models/courses

@@ -19,6 +19,7 @@ Course
     materialFree     Bool
     TermSchoolCourseShort  term school shorthand
     TermSchoolCourseName   term school name
+    deriving Generic
 CourseEdit
     user         UserId
     time         UTCTime

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

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

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

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

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

package.yaml

@@ -113,6 +113,7 @@ dependencies:
   - pkcs7
   - memcached-binary
   - directory-tree
+  - lifted-base
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -231,6 +232,9 @@ tests:
       - http-types
     ghc-options:
       - -fno-warn-orphans
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
   hlint:
     main: Hlint.hs
     other-modules: []

src/Application.hs

@@ -157,7 +157,7 @@ makeFoundation appSettings@AppSettings{..} = do
 
     flip runLoggingT logFunc $ do
       $logDebugS "InstanceID" $ UUID.toText appInstanceID
-      -- $logDebugS "Configuration" $ tshow appSettings
+      -- logDebugS "Configuration" $ tshow appSettings
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
@@ -168,7 +168,7 @@ makeFoundation appSettings@AppSettings{..} = do
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
+      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
     
       -- Perform database migration using our application's logging settings.
       migrateAll `runSqlPool` sqlPool

src/Auth/LDAP.hs

@@ -44,7 +44,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
       , Ldap.size 2
-      , Ldap.time ldapTimeout
+      , Ldap.time ldapSearchTimeout
       , Ldap.derefAliases Ldap.DerefAlways
       ]
   
@@ -88,7 +88,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
             findUser conf ldap campusIdent [userPrincipalName]
           case ldapResult of
             Left err
-              | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
+              | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
                 -> do
                   $logDebugS "LDAP" "Invalid credentials"
                   loginErrorMessageI LoginR Msg.InvalidLogin
@@ -110,7 +110,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
       $(widgetFile "widgets/campus-login-form")
 
-data CampusUserException = CampusUserLdapError Ldap.LdapError
+data CampusUserException = CampusUserLdapError LdapPoolError
                          | CampusUserHostNotResolved String
                          | CampusUserLineTooLong
                          | CampusUserHostCannotConnect String [IOException]
@@ -129,7 +129,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
           userSearchSettings = mconcat
             [ Ldap.scope Ldap.BaseObject
             , Ldap.size 2
-            , Ldap.time ldapTimeout
+            , Ldap.time ldapSearchTimeout
             , Ldap.derefAliases Ldap.DerefAlways
             ]
       Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []

src/CryptoID/TH.hs

@@ -6,14 +6,11 @@ import Language.Haskell.TH
 
 import Data.CryptoID.Class.ImplicitNamespace
 import Data.UUID.Types (UUID)
-import Data.Binary (Binary(..))
 import Data.Binary.SerializationLength
 
 import Data.CaseInsensitive (CI)
 import System.FilePath (FilePath)
 
-import Database.Persist.Sql (toSqlKey, fromSqlKey)
-
 
 decCryptoIDs :: [Name] -> DecsQ
 decCryptoIDs = fmap concat . mapM decCryptoID
@@ -21,9 +18,6 @@ decCryptoIDs = fmap concat . mapM decCryptoID
     decCryptoID :: Name -> DecsQ
     decCryptoID n@(conT -> t) = do
       instances <- [d|
-          instance Binary $(t) where
-            get = $(varE 'toSqlKey) <$> get
-            put = put . $(varE 'fromSqlKey)
           instance HasFixedSerializationLength $(t) where
             type SerializationLength $(t) = SerializationLength Int64
 

src/Data/CaseInsensitive/Instances.hs

@@ -24,6 +24,8 @@ import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJ
 
 import qualified Database.Esqueleto as E
 
+import Web.HttpApiData
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -75,3 +77,20 @@ instance RenderMessage site a => RenderMessage site (CI a) where
 
 instance Lift t => Lift (CI t) where
   lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
+
+
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+  fromPathPiece = fmap CI.mk . fromPathPiece
+  toPathPiece = toPathPiece . CI.original
+
+instance ToHttpApiData (CI Text) where
+  toUrlPiece = toUrlPiece . CI.original
+  toEncodedUrlPiece = toEncodedUrlPiece . CI.original
+
+instance FromHttpApiData (CI Text) where
+  parseUrlPiece = fmap CI.mk . parseUrlPiece
+
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+  fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+

src/Database/Esqueleto/Instances.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Esqueleto.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import qualified Database.Esqueleto as E
+
+import Data.Binary (Binary)
+import qualified Data.Binary as B
+
+
+instance ToJSON a => ToJSON (E.Value a) where
+  toJSON = toJSON . E.unValue
+
+instance FromJSON a => FromJSON (E.Value a) where
+  parseJSON = fmap E.Value . parseJSON
+
+
+instance Binary a => Binary (E.Value a) where
+  put = B.put . E.unValue
+  get = E.Value <$> B.get
+  putList = B.putList . map E.unValue

src/Database/Persist/Sql/Instances.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Sql.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Data.Binary (Binary)
+import qualified Data.Binary as B
+
+import Database.Persist.Sql
+
+
+instance Binary (BackendKey SqlWriteBackend) where
+  put = B.put . unSqlWriteBackendKey
+  putList = B.putList . map unSqlWriteBackendKey
+  get = SqlWriteBackendKey <$> B.get
+instance Binary (BackendKey SqlReadBackend) where
+  put = B.put . unSqlReadBackendKey
+  putList = B.putList . map unSqlReadBackendKey
+  get = SqlReadBackendKey <$> B.get
+instance Binary (BackendKey SqlBackend) where
+  put = B.put . unSqlBackendKey
+  putList = B.putList . map unSqlBackendKey
+  get = SqlBackendKey <$> B.get
+  
+
+instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where
+  put = B.put . fromSqlKey
+  putList = B.putList . map fromSqlKey
+  get = toSqlKey <$> B.get

src/Foundation.hs

@@ -1236,14 +1236,19 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = do
           now <- liftIO getCurrentTime
-          [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet) -> do
+          sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
-            E.where_ $  sheet E.^. SheetActiveTo   E.>.  E.val now
+            E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
                  E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
                  E.&&. course E.^. CourseTerm      E.==. E.val tid
                  E.&&. course E.^. CourseSchool    E.==. E.val ssh
                  E.&&. course E.^. CourseShorthand E.==. E.val csh
-          return ok
+            E.orderBy [E.asc $ sheet E.^. SheetActiveFrom]
+            E.limit 1
+            return $ sheet E.^. SheetName
+          case sheets of
+            (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
+            _ -> return False
       }
   , MenuItem
       { menuItemType = PageActionPrime
@@ -1260,7 +1265,7 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
       , menuItemModal = False
       , menuItemAccessCallback' = do --TODO always show for lecturer
-          let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
+          let sheetRouteAccess shn = (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
           muid <- maybeAuthId
           (sheets,lecturer) <- runDB $ do
             cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh

src/Handler/Corrections.hs

@@ -50,8 +50,6 @@ import Data.List (genericLength)
 import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
 import Control.Monad.Trans.Reader (mapReaderT)
 
-import Control.Monad.Trans.RWS (RWST)
-
 import Control.Monad.Trans.State (State, runState)
 import qualified Control.Monad.State.Class as State
 
@@ -132,7 +130,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
                 return $ CSubmissionR tid ssh csh shn cid SubShowR
           in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
 
-colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
+colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData)))
 colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
 
 colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@@ -178,23 +176,23 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_
       cell [whamlet|#{review _PseudonymText pseudo}|]
   in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
-colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
+colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
 colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
+  (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
 
-colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
+colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
 colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
       NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
-      _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
+      _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
-colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
+colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
 colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
 
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
@@ -861,7 +859,7 @@ postCorrectionsGradeR = do
         , colCommentField
         ] -- Continue here
       psValidator = def
-        & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
+        & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
       dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
         cID <- encrypt subId

src/Handler/Home.hs

@@ -80,7 +80,7 @@ homeAnonymous = do
   -- let features = $(widgetFile "featureList")
   -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout
-    -- $(widgetFile "dsgvDisclaimer")
+    -- (widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
 
 homeUser :: Key User -> Handler Html
@@ -181,7 +181,7 @@ homeUser uid = do
   defaultLayout $
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")
-    -- $(widgetFile "dsgvDisclaimer")
+    -- (widgetFile "dsgvDisclaimer")
 
 
 getVersionR :: Handler TypedContent

src/Handler/Sheet.hs

@@ -644,7 +644,7 @@ defaultLoads shid = do
     toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
+correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
 correctorForm shid = do
   cListIdent <- newFormIdent
   let

src/Handler/Submission.hs

@@ -115,7 +115,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           E.where_ $ submissionUser E.^. SubmissionUserUser   E.==. E.val uid
                E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
           return $ submission E.^. SubmissionId
-        -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
+        -- logDebugS "Submission.DUPLICATENEW" (tshow submissions)
         case submissions of
           []    -> do
             -- fetch buddies from previous submission in this course

src/Handler/SystemMessage.hs

@@ -175,7 +175,7 @@ postMessageListR = do
         { dbrOutput = (smE, smT)
         , ..
         }
-    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
+    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
   (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtRowKey = (E.^. SystemMessageId)

src/Handler/Utils/Form.hs

@@ -532,6 +532,10 @@ fsm = bfs -- TODO: get rid of Bootstrap
 fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
 
+fsUniq :: (Text -> Text) -> Text -> FieldSettings site
+fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
+
+
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site
                           , PersistQueryRead backend

src/Handler/Utils/Submission.hs

@@ -64,9 +64,9 @@ instance Exception AssignSubmissionException
 -- | Assigns all submissions according to sheet corrector loads
 assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
                   -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-                  -> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
+                  -> YesodDB UniWorX ( Set SubmissionId
-                                     , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
+                                     , Set SubmissionId
-                                     )
+                                     ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
 assignSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []

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
@@ -67,6 +69,8 @@ import Data.Ratio ((%))
 
 import Control.Lens
 
+import Data.List (elemIndex)
+
 import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
 import Data.Aeson.Text
 import Data.Aeson.TH (deriveJSON)
@@ -75,6 +79,14 @@ import qualified Data.Text as Text
 
 import Data.Proxy (Proxy(..))
 
+import qualified Data.Binary as B
+import qualified Data.ByteArray as BA (convert)
+import Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.Hash.Algorithms (SHAKE256)
+
+import qualified Data.ByteString.Base64.URL as Base64 (encode)
+import qualified Data.ByteString.Lazy as LBS
+
 
 $(sqlInTuples [2..16])
 
@@ -82,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
@@ -104,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
@@ -245,10 +257,12 @@ piIsUnset PaginationInput{..} = and
   , isNothing piPage
   ]
 
-data DBRow r = DBRow
+type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
-  { dbrOutput :: r
+data DBRow r = forall k'. DBTableKey k' => DBRow
+  { dbrKey :: k'
+  , dbrOutput :: r
   , dbrIndex, dbrCount :: Int64
-  } deriving (Show, Read, Eq, Ord)
+  }
 
 makeLenses_ ''DBRow
 
@@ -259,7 +273,7 @@ instance Foldable DBRow where
   foldMap f DBRow{..} = f dbrOutput
 
 instance Traversable DBRow where
-  traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
+  traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
 
 newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
 
@@ -316,11 +330,12 @@ data DBStyle = DBStyle
   { dbsEmptyStyle :: DBEmptyStyle
   , dbsEmptyMessage :: UniWorXMessage
   , dbsAttrs :: [(Text, Text)]
-  , dbsFilterLayout :: Widget -- ^ Filter UI
+  , dbsFilterLayout :: Widget
                     -> Enctype
-                    -> Text -- ^ Filter action (target uri)
+                    -> Text
-                    -> Widget -- ^ Table
                     -> Widget
+                    -> Widget
+    -- ^ Filter UI, Filter Encoding, Filter action, table
   }
 
 instance Default DBStyle where
@@ -345,7 +360,7 @@ defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(wid
 
 data DBTable m x = forall a r r' h i t k k'.
   ( ToSortable h, Functor h
-  , E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
+  , E.SqlSelect a r, SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
@@ -376,6 +391,9 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) =>
   dbHandler  :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
   runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
 
+  dbInvalidateResult :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
+  dbInvalidateResult _ _ _ = return
+
 cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
 cellAttrs = dbCell . _1
 
@@ -466,6 +484,12 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
   runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
 
+  dbInvalidateResult _ _ reason result = do
+    reasonTxt <- getMessageRender <*> pure reason
+    return $ case result of
+      (FormFailure errs, wdgt) -> (FormFailure $ reasonTxt : errs, wdgt)
+      (_, wdgt)                -> (FormFailure $ pure reasonTxt  , wdgt)
+
 instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   def = DBParamsForm
     { dbParamsFormMethod     = POST
@@ -585,19 +609,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
 
   let
-    (errs, PaginationSettings{..}) = case piResult of
+    ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
-      FormSuccess pi
-        | not (piIsUnset pi)
-          -> runPSValidator dbtable $ Just pi
-      FormFailure errs'
-          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
-      _   -> runPSValidator dbtable Nothing
-    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
@@ -623,8 +642,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         = succ (psPage * l)
         | otherwise
         = 1
+      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..] rows'
+  (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
 
   getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
   let
@@ -638,13 +662,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , setParam (wIdent "pagination") Nothing
       ]
 
-  if
-    | Just pKeys <- previousKeys
-    , pKeys /= currentKeys
-      -> redirectWith preconditionFailed412 $ tblLink id
-    | otherwise
-      -> return ()
-
   let
     rowCount
       | (E.Value n, _, _):_ <- rows' = n
@@ -690,7 +707,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
     uiLayout table = dbsFilterLayout filterWdgt filterEnc rawAction $(widgetFile "table/layout")
 
-  bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
+    dbInvalidateResult' = foldr (<=<) return . catMaybes $
+      [ do
+          pKeys <- previousKeys
+          guard $ pKeys /= currentKeys
+          return . dbInvalidateResult (Proxy @m) (Proxy @x) . DBTIRowsMissing $ length previousKeys - length currentKeys
+      ]
+
+  dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
   where
     tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
@@ -801,25 +825,34 @@ listCell xs mkCell = review dbCell . ([], ) $ do
     \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
   return $(widgetFile "table/cell/list")
 
-newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
+newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
 
-instance Ord i => Monoid (DBFormResult r i a) where
+instance Functor (DBFormResult i a) where
+  f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
+
+instance Ord i => Monoid (DBFormResult i a r) where
   mempty = DBFormResult Map.empty
   (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
 
-getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
+getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
 
 formCell :: forall res r i a. (Ord i, Monoid res)
-         => Lens' res (DBFormResult r i a)
+         => Lens' res (DBFormResult i a (DBRow r))
-         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
+         -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-         -> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
+         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
-formCell resLens genIndex genForm input = FormCell
+formCell resLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
   { formCellAttrs    = []
   , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
       i <- genIndex input
-      (edit, w) <- genForm input i
+      hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
+      let
+        mkUnique :: PathPiece p => p -> Text
+        mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
+          where
+            rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
+      (edit, w) <- genForm input mkUnique 
       return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
   }
 
@@ -831,10 +864,12 @@ dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
 dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
-         => Lens' res (DBFormResult r i a)
+         => Lens' res (DBFormResult i a (DBRow r))
          -> Setter' a Bool
-         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
+         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
-dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do
+dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
-  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
+  where
-  return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
+    genForm _ mkUnique = do
+      (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
+      return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])

src/Handler/Utils/Table/Pagination/Types.hs

@@ -8,6 +8,7 @@ module Handler.Utils.Table.Pagination.Types
   , SortableP(..)
   , SqlIn(..)
   , sqlInTuples
+  , DBTableInvalid(..)
   ) where
 
 import Import hiding (singleton)
@@ -28,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)
 
 
@@ -96,3 +97,11 @@ sqlInTuple arity = do
         ) []
       ]
     ]
+
+
+data DBTableInvalid = DBTIRowsMissing Int
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception DBTableInvalid
+
+embedRenderMessage ''UniWorX ''DBTableInvalid id

src/Import/NoFoundation.hs

@@ -46,6 +46,8 @@ import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.Instances  as Import ()
 
+import Data.Binary            as Import (Binary)
+
 import Control.Monad.Morph    as Import (MFunctor(..))
 
 import Control.Monad.Trans.Resource as Import (ReleaseKey)
@@ -55,6 +57,9 @@ import Yesod.Core.Instances as Import ()
 
 import Ldap.Client.Pool as Import
 
+import Database.Esqueleto.Instances as Import ()
+import Database.Persist.Sql.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -274,7 +274,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
       runDB $ delete jId
     handleCmd JobCtlDetermineCrontab = do
       newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
-      -- $logDebugS logIdent $ tshow newCTab
+      -- logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
         lift . void . flip swapTMVar newCTab =<< asks jobCrontab
 

src/Ldap/Client/Pool.hs

@@ -3,6 +3,7 @@
 module Ldap.Client.Pool
   ( LdapPool
   , LdapExecutor, Ldap, LdapError
+  , LdapPoolError(..)
   , withLdap
   , createLdapPool
   ) where
@@ -19,17 +20,24 @@ import Data.Time.Clock (NominalDiffTime)
 
 import Data.Dynamic
 
+import System.Timeout.Lifted
+
 
 type LdapPool = Pool LdapExecutor
 data LdapExecutor = LdapExecutor
-  { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+  { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
   , ldapDestroy :: TMVar ()
   }
 
 instance Exception LdapError
 
+data LdapPoolError = LdapPoolTimeout | LdapError LdapError
+  deriving (Eq, Show, Generic, Typeable)
 
-withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
+instance Exception LdapPoolError
+
+
+withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapPoolError a)
 withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
 
 
@@ -37,10 +45,11 @@ createLdapPool :: ( MonadLoggerIO m, MonadIO m )
                => Ldap.Host
                -> Ldap.PortNumber
                -> Int -- ^ Stripes
-               -> NominalDiffTime -- ^ Timeout
+               -> NominalDiffTime -- ^ Connection Timeout
+               -> NominalDiffTime -- ^ Action Timeout
                -> Int -- ^ Limit
                -> m LdapPool
-createLdapPool host port stripes timeout limit = do
+createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) limit = do
   logFunc <- askLoggerIO
   
   let
@@ -50,16 +59,17 @@ createLdapPool host port stripes timeout limit = do
       ldapAct <- newEmptyTMVarIO
 
       let
-        ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+        ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
         ldapExec act = do
           ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
           atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
           either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
           `catches`
-          [ Handler $ return . Left . Ldap.ParseError
+          [ Handler $ return . Left . LdapError . Ldap.ParseError
-          , Handler $ return . Left . Ldap.ResponseError
+          , Handler $ return . Left . LdapError . Ldap.ResponseError
-          , Handler $ return . Left . Ldap.IOError
+          , Handler $ return . Left . LdapError . Ldap.IOError
-          , Handler $ return . Left . Ldap.DisconnectError
+          , Handler $ return . Left . LdapError . Ldap.DisconnectError
+          , Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
           ]
 
         go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
@@ -71,7 +81,7 @@ createLdapPool host port stripes timeout limit = do
             Nothing -> $logDebugS "LdapExecutor" "Terminating"
             Just (act, returnRes) -> do
               $logDebugS "LdapExecutor" "Executing"
-              res <- try . liftIO $ act ldap
+              res <- try . withTimeout . liftIO $ act ldap
               didReturn <- atomically $ tryPutTMVar returnRes res
               unless didReturn $
                 $logErrorS "LdapExecutor" "Could not return result"
@@ -81,20 +91,25 @@ createLdapPool host port stripes timeout limit = do
                 ]
               go Nothing ldap
 
-      setup <- newEmptyTMVarIO
+      withTimeout $ do
-      void . fork . flip runLoggingT logFunc $ do
+        setup <- newEmptyTMVarIO
-        $logDebugS "LdapExecutor" "Starting"
-        res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
-        case res of
-          Left exc -> do
-            $logWarnS "LdapExecutor" $ tshow exc
-            atomically . void . tryPutTMVar setup $ Just exc
-          Right res' -> return res'
 
-      maybe (return ()) throwM =<< atomically (takeTMVar setup)
+        void . fork . flip runLoggingT logFunc $ do
+          $logDebugS "LdapExecutor" "Starting"
+          res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
+          case res of
+            Left exc -> do
+              $logWarnS "LdapExecutor" $ tshow exc
+              atomically . void . tryPutTMVar setup $ Just exc
+            Right res' -> return res'
+
+        maybe (return ()) throwM =<< atomically (takeTMVar setup)
 
       return LdapExecutor{..}
 
     delExecutor :: LdapExecutor -> IO ()
     delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
-  liftIO $ createPool mkExecutor delExecutor stripes timeout limit
+  liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
+  where
+    withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
+    withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

src/Mail.hs

@@ -249,7 +249,7 @@ defMailT ls (MailT mailC) = do
   fromAddress <- defaultFromAddress
   (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
   mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
-  -- $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
+  -- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
   ret <$ case smtpData of
     MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
     MailSmtpData{ smtpRecipients }

src/Model.hs

@@ -22,6 +22,8 @@ import Data.CaseInsensitive.Instances ()
 import Utils.Message (MessageClass)
 import Settings.Cluster (ClusterSettingsKey)
 
+import Data.Binary (Binary)
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
@@ -33,5 +35,9 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 deriving instance Eq (Unique Course)
 deriving instance Eq (Unique Sheet)
 
+-- Primary keys mentioned in dbtable row-keys must be Binary
+-- Automatically generated (i.e. numeric) ids are already taken care of
+deriving instance Binary (Key Term)
+
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Types.hs

@@ -77,37 +77,17 @@ import Data.Data (Data)
 import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
-import qualified Database.Esqueleto as E
+import Data.Binary (Binary)
+
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
   toPathPiece = pack . UUID.toString
 
-instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
-  fromPathPiece = fmap CI.mk . fromPathPiece
-  toPathPiece = toPathPiece . CI.original
-
 instance {-# OVERLAPS #-} PathMultiPiece FilePath where
   fromPathMultiPiece = Just . unpack . intercalate "/"
   toPathMultiPiece = Text.splitOn "/" . pack
 
-instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
-  fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
-  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
-
-instance ToHttpApiData (CI Text) where
-  toUrlPiece = toUrlPiece . CI.original
-  toEncodedUrlPiece = toEncodedUrlPiece . CI.original
-
-instance FromHttpApiData (CI Text) where
-  parseUrlPiece = fmap CI.mk . parseUrlPiece
-
-instance ToJSON a => ToJSON (E.Value a) where
-  toJSON = toJSON . E.unValue
-
-instance FromJSON a => FromJSON (E.Value a) where
-  parseJSON = fmap E.Value . parseJSON
-
 
 type Count  = Sum Integer
 type Points = Centi
@@ -371,6 +351,8 @@ instance Monoid Load where
 data Season = Summer | Winter
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
 
+instance Binary Season
+
 seasonToChar :: Season -> Char
 seasonToChar Summer = 'S'
 seasonToChar Winter = 'W'
@@ -390,6 +372,8 @@ data TermIdentifier = TermIdentifier
   , season :: Season
   } deriving (Show, Read, Eq, Ord, Generic, Typeable)
 
+instance Binary TermIdentifier
+
 instance Enum TermIdentifier where
   -- ^ Do not use for conversion – Enumeration only
   toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}

src/Settings.hs

@@ -165,7 +165,8 @@ data LdapConf = LdapConf
   , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
-  , ldapTimeout :: Int32
+  , ldapTimeout :: NominalDiffTime
+  , ldapSearchTimeout :: Int32
   , ldapPool :: ResourcePoolConf
   } deriving (Show)
  
@@ -253,6 +254,7 @@ instance FromJSON LdapConf where
         ldapBase <- Ldap.Dn <$> o .: "baseDN"
         ldapScope <- o .: "scope"
         ldapTimeout <- o .: "timeout"
+        ldapSearchTimeout <- o .: "search-timeout"
         ldapPool <- o .: "pool"
         return LdapConf{..}
 

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

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 ]

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 == "{}")

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
+import ModelSpec ()
-  arbitrary = do
+
-    fileTitle <- (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
+import System.FilePath
-    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
+import Data.Time
-    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
-    fileContent <- arbitrary
-    return File{..}
-  shrink = genericShrink
 
 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

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)
+  parallel $ do
-    [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
+    lawsCheckHspec (Proxy @MailSmtpData)
-  lawsCheckHspec (Proxy @MailLanguages)
+      [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
-    [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
-  lawsCheckHspec (Proxy @MailContext)
+      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
+    lawsCheckHspec (Proxy @MailContext)
-  lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
-    [ eqLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, showReadLaws, jsonLaws ]

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
@@ -127,63 +127,78 @@ instance Arbitrary Value where
       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)
+  parallel $ do
-    [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
+    lawsCheckHspec (Proxy @UUID)
-  lawsCheckHspec (Proxy @FilePath)
+      [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
-    [ pathMultiPieceLaws ]
+    lawsCheckHspec (Proxy @FilePath)
-  lawsCheckHspec (Proxy @(CI Text))
+      [ pathMultiPieceLaws ]
-    [ httpApiDataLaws ]
+    lawsCheckHspec (Proxy @(CI Text))
-  lawsCheckHspec (Proxy @SheetGrading)
+      [ httpApiDataLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetGrading)
-  lawsCheckHspec (Proxy @SheetGradeSummary)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
+    lawsCheckHspec (Proxy @SheetGradeSummary)
-  lawsCheckHspec (Proxy @SheetType)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetType)
-  lawsCheckHspec (Proxy @SheetTypeSummary)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @SheetTypeSummary)
-  lawsCheckHspec (Proxy @SheetGroup)
+      [ eqLaws, showReadLaws, commutativeMonoidLaws ]
-    [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @SheetGroup)
-  lawsCheckHspec (Proxy @SheetFileType)
+      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SheetFileType)
-  lawsCheckHspec (Proxy @SubmissionFileType)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @SubmissionFileType)
-  lawsCheckHspec (Proxy @UploadMode)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
+    lawsCheckHspec (Proxy @UploadMode)
-  lawsCheckHspec (Proxy @SheetSubmissionMode)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @SheetSubmissionMode)
-  lawsCheckHspec (Proxy @ExamStatus)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @ExamStatus)
-  lawsCheckHspec (Proxy @Load)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
-    [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
+    lawsCheckHspec (Proxy @Load)
-  lawsCheckHspec (Proxy @Season)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
-    [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
+    lawsCheckHspec (Proxy @Season)
-  lawsCheckHspec (Proxy @TermIdentifier)
+      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
-    [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @TermIdentifier)
-  lawsCheckHspec (Proxy @StudyFieldType)
+      [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @StudyFieldType)
-  lawsCheckHspec (Proxy @Theme)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Theme)
-  lawsCheckHspec (Proxy @CorrectorState)
+      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @CorrectorState)
-  lawsCheckHspec (Proxy @AuthenticationMode)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthenticationMode)
-  lawsCheckHspec (Proxy @Value)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @Value)
-  lawsCheckHspec (Proxy @NotificationTrigger)
+      [ persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @NotificationTrigger)
-  lawsCheckHspec (Proxy @NotificationSettings)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @NotificationSettings)
-  lawsCheckHspec (Proxy @MailLanguages)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    [ persistFieldLaws ]
+    lawsCheckHspec (Proxy @MailLanguages)
-  lawsCheckHspec (Proxy @Pseudonym)
+      [ persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @Pseudonym)
-  lawsCheckHspec (Proxy @AuthTag)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
-    [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
+    lawsCheckHspec (Proxy @AuthTag)
-  lawsCheckHspec (Proxy @AuthTagActive)
+      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
-    [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @AuthTagActive)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

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 ]

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

test/Utils/DateTimeSpec.hs

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