195 lines
9.5 KiB
Haskell
195 lines
9.5 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.StudyFeatures
|
|
( UserTableStudyFeature(..)
|
|
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
|
|
, UserTableStudyFeatures(..)
|
|
, _UserTableStudyFeatures
|
|
, isRelevantStudyFeature, isRelevantStudyFeatureCached
|
|
, cacheStudyFeatureRelevance
|
|
, isCourseStudyFeature, courseUserStudyFeatures
|
|
, isExternalExamStudyFeature, externalExamUserStudyFeatures
|
|
, isTermStudyFeature
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
import Foundation.I18n
|
|
|
|
import Utils.Term
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.RFC5051 (compareUnicode)
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
data UserTableStudyFeature = UserTableStudyFeature
|
|
{ userTableField
|
|
, userTableDegree :: Text
|
|
, userTableSemester :: Int
|
|
, userTableFieldType :: StudyFieldType
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
makeLenses_ ''UserTableStudyFeature
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
} ''UserTableStudyFeature
|
|
|
|
newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature)
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving newtype ( ToJSON, FromJSON
|
|
, Semigroup, Monoid
|
|
)
|
|
makeWrapped ''UserTableStudyFeatures
|
|
|
|
_UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature]
|
|
_UserTableStudyFeatures = iso (sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped) (UserTableStudyFeatures . Set.fromList)
|
|
|
|
instance Csv.ToField UserTableStudyFeature where
|
|
toField UserTableStudyFeature{..} = encodeUtf8
|
|
[st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|]
|
|
where userTableFieldType' = renderMessage
|
|
(error "Foundation inspected during renderMessage" :: UniWorX)
|
|
[] $ ShortStudyFieldType userTableFieldType
|
|
|
|
instance Csv.ToField UserTableStudyFeatures where
|
|
toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures
|
|
|
|
userTableStudyFeatureSort :: UserTableStudyFeature
|
|
-> UserTableStudyFeature
|
|
-> Ordering
|
|
userTableStudyFeatureSort = mconcat
|
|
[ compareUnicode `on` userTableDegree
|
|
, comparing userTableSemester
|
|
, comparing userTableFieldType
|
|
, compareUnicode `on` userTableField
|
|
]
|
|
|
|
|
|
isRelevantStudyFeature :: PersistEntity record
|
|
=> E.SqlExpr (E.Value UTCTime)
|
|
-> EntityField record TermId
|
|
-> E.SqlExpr (Entity record)
|
|
-> E.SqlExpr (Entity StudyFeatures)
|
|
-> E.SqlExpr (E.Value Bool)
|
|
isRelevantStudyFeature now termField record studyFeatures
|
|
= ( ( overlap studyFeatures E.>. E.val 0
|
|
E.||. ( E.just (studyFeatures E.^. StudyFeaturesLastObserved) E.==. studyFeatures E.^. StudyFeaturesFirstObserved
|
|
E.&&. termStart E.<=. E.day (studyFeatures E.^. StudyFeaturesLastObserved)
|
|
E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.<=. termEnd
|
|
)
|
|
)
|
|
E.&&. E.not_ (E.exists betterOverlap)
|
|
)
|
|
E.||. ( termIsActiveE now E.nothing (record E.^. termField)
|
|
E.&&. E.not_ (E.exists anyOverlap)
|
|
E.&&. studyFeatures E.^. StudyFeaturesValid
|
|
)
|
|
where termEnd = E.subSelectForeign record termField (E.^. TermEnd)
|
|
termStart = E.subSelectForeign record termField (E.^. TermStart)
|
|
|
|
overlap :: E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Int)
|
|
overlap studyFeatures'
|
|
= E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd
|
|
`E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved)
|
|
|
|
anyOverlap = E.from $ \studyFeatures' -> do
|
|
E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
|
|
E.where_ $ overlap studyFeatures' E.>. E.val 0
|
|
|
|
betterOverlap = E.from $ \studyFeatures' -> do
|
|
E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
|
|
E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.&&. studyFeatures' E.^. StudyFeaturesField E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.&&. studyFeatures' E.^. StudyFeaturesSuperField `E.maybeEq` studyFeatures E.^. StudyFeaturesSuperField
|
|
E.&&. studyFeatures' E.^. StudyFeaturesType E.==. studyFeatures E.^. StudyFeaturesType
|
|
E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1
|
|
E.&&. overlap studyFeatures' E.>. overlap studyFeatures
|
|
|
|
isRelevantStudyFeatureCached :: PersistEntity record
|
|
=> EntityField record TermId
|
|
-> E.SqlExpr (Entity record)
|
|
-> E.SqlExpr (Entity StudyFeatures)
|
|
-> E.SqlExpr (E.Value Bool)
|
|
isRelevantStudyFeatureCached termField record studyFeatures
|
|
= E.exists . E.from $ \relevantStudyFeatures ->
|
|
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField
|
|
E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId
|
|
|
|
cacheStudyFeatureRelevance :: MonadResource m
|
|
=> (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool))
|
|
-> SqlPersistT m ()
|
|
cacheStudyFeatureRelevance fFilter = do
|
|
now <- liftIO getCurrentTime
|
|
|
|
E.insertSelectWithConflict UniqueRelevantStudyFeatures
|
|
( E.from $ \(studyFeatures `E.InnerJoin` term) -> do
|
|
E.on E.true
|
|
E.where_ $ fFilter studyFeatures
|
|
E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures
|
|
return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
|
|
)
|
|
( \_current _excluded -> [] )
|
|
|
|
let getStudyFeatures = E.selectSource . E.from $ \studyFeatures -> do
|
|
E.where_ $ fFilter studyFeatures
|
|
E.where_ . E.isNothing $ studyFeatures E.^. StudyFeaturesRelevanceCached
|
|
return $ studyFeatures E.^. StudyFeaturesId
|
|
migrateStudyFeatures genUUID lift' (E.Value sfId) = do
|
|
uuid <- genUUID
|
|
lift' $ update sfId [ StudyFeaturesRelevanceCached =. Just uuid ]
|
|
in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift')
|
|
|
|
isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isCourseStudyFeature = isRelevantStudyFeatureCached CourseTerm
|
|
|
|
courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures
|
|
courseUserStudyFeatures cId uid = do
|
|
feats <- E.select . E.from $ \(course `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.on $ isCourseStudyFeature course studyFeatures
|
|
E.where_ $ course E.^. CourseId E.==. E.val cId
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, studyFeatures)
|
|
return . UserTableStudyFeatures . Set.fromList . flip map feats $
|
|
\(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
|
|
{ userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, userTableSemester = studyFeaturesSemester
|
|
, userTableFieldType = studyFeaturesType
|
|
}
|
|
|
|
isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isExternalExamStudyFeature = isRelevantStudyFeatureCached ExternalExamTerm
|
|
|
|
externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures
|
|
externalExamUserStudyFeatures eeId uid = do
|
|
feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.on $ isExternalExamStudyFeature externalExam studyFeatures
|
|
E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, studyFeatures)
|
|
return . UserTableStudyFeatures . Set.fromList . flip map feats $
|
|
\(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
|
|
{ userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, userTableSemester = studyFeaturesSemester
|
|
, userTableFieldType = studyFeaturesType
|
|
}
|
|
|
|
isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isTermStudyFeature = isRelevantStudyFeatureCached TermId
|