- #{tshow res} - |] - - -getAdminErrMsgR, postAdminErrMsgR :: Handler Html -getAdminErrMsgR = postAdminErrMsgR -postAdminErrMsgR = do - MsgRenderer mr <- getMsgRenderer - ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $ - unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext (mr MsgErrMsgCiphertext)) Nothing - - plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value) - - let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding } - defaultLayout - [whamlet| - $maybe t <- plaintext -
- $case t
- $of String t'
- #{t'}
- $of t'
- #{encodePrettyToTextBuilder t'}
-
- ^{ctView'}
- |]
-
-
--- BEGIN - Buttons needed only for StudyTermCandidateManagement
-data ButtonAdminStudyTerms
- = BtnCandidatesInfer
- | BtnCandidatesDeleteConflicts
- | BtnCandidatesDeleteAll
- deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTerms
-instance Finite ButtonAdminStudyTerms
-
-nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
-
-instance Button UniWorX ButtonAdminStudyTerms where
- btnClasses BtnCandidatesInfer = [BCIsButton, BCPrimary]
- btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
- btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
--- END Button needed only here
-
-getAdminFeaturesR, postAdminFeaturesR :: Handler Html
-getAdminFeaturesR = postAdminFeaturesR
-postAdminFeaturesR = do
- uid <- requireAuthId
- ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
- let btnForm = wrapForm btnWdgt def
- { formAction = Just $ SomeRoute AdminFeaturesR
- , formEncoding = btnEnctype
- , formSubmit = FormNoSubmit
- }
- infConflicts <- case btnResult of
- FormSuccess BtnCandidatesInfer -> do
- (infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
- unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
- unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
- let newKeys = map (StudyTermsKey' . fst) infAccepted
- setSessionJson SessionNewStudyTerms newKeys
- if | null infAccepted
- -> addMessageI Info MsgNoCandidatesInferred
- | otherwise
- -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
- return infConflicts
- FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
- confs <- Candidates.conflicts
- incis <- Candidates.getIncidencesFor (entityKey <$> confs)
- deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
- addMessageI Success $ MsgIncidencesDeleted $ length incis
- return []
- FormSuccess BtnCandidatesDeleteAll -> runDB $ do
- deleteWhere ([] :: [Filter StudyTermCandidate])
- addMessageI Success MsgAllIncidencesDeleted
- Candidates.conflicts
- _other -> runDB Candidates.conflicts
-
- newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
- ( (degreeResult,degreeTable)
- , (studyTermsResult,studytermsTable)
- , ((), candidateTable)
- , userSchools) <- runDB $ do
- schools <- E.select . E.from $ \school -> do
- E.where_ . E.exists . E.from $ \schoolFunction ->
- E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
- E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
- E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
- return school
- (,,,)
- <$> mkDegreeTable
- <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
- (Set.fromList $ map entityKey infConflicts)
- (Set.fromList schools)
- <*> mkCandidateTable
- <*> pure schools
-
- -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
- unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
-
- let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
- degreeResult' = degreeResult <&> getDBFormResult
- (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
- , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
- ))
- updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
- formResult degreeResult' $ \res -> do
- void . runDB $ Map.traverseWithKey updateDegree res
- addMessageI Success MsgStudyDegreeChangeSuccess
-
- let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
- studyTermsResult' = studyTermsResult <&> getDBFormResult
- (\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
- , row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
- , row ^. _dbrOutput . _2
- ))
- updateStudyTerms studyTermsKey (name,short,schools) = do
- update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
- forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
- deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
- formResult studyTermsResult' $ \res -> do
- void . runDB $ Map.traverseWithKey updateStudyTerms res
- addMessageI Success MsgStudyTermsChangeSuccess
-
- siteLayoutMsg MsgAdminFeaturesHeading $ do
- setTitleI MsgAdminFeaturesHeading
- $(widgetFile "adminFeatures")
- where
- textInputCell :: Ord i
- => Lens' a (Maybe Text)
- -> Getter (DBRow r) (Maybe Text)
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
- <$> mopt textField "" (Just $ row ^. lensDefault)
- )
-
- checkboxCell :: Ord i
- => Lens' a Bool
- -> Getter (DBRow r) Bool
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
- <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
- )
-
-
- mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
- mkDegreeTable =
- let dbtIdent = "admin-studydegrees" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyDegreeKey)
- dbtProj = return
- dbtColonnade = formColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
- , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
- , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
- , dbRow
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn (E.^. StudyDegreeKey))
- , ("name" , SortColumn (E.^. StudyDegreeName))
- , ("short", SortColumn (E.^. StudyDegreeShorthand))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
- }
- psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
- & defaultSorting [SortAscBy "key"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- in dbTable psValidator DBTable{..}
-
- mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
- mkStudytermsTable newKeys badKeys schools =
- let dbtIdent = "admin-studyterms" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyTermsKey)
- dbtProj field = do
- fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
- E.where_ . E.exists . E.from $ \schoolTerms ->
- E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
- E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field ^. _dbrOutput . _entityKey)
- E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
- return $ school E.^. SchoolId
- return $ field & _dbrOutput %~ (, fieldSchools)
- dbtColonnade = formColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
- , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
- , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
- , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
- , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
- , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
- sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
- , dbRow
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn (E.^. StudyTermsKey))
- , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))) -- works only once
- -- Remember: sorting with E.in_ by StudyTermsId instead will produce esqueleto-error "unsafeSqlBinOp: non-id/composite keys not expected here"
- , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)))
- , ("name" , SortColumn (E.^. StudyTermsName))
- , ("short" , SortColumn (E.^. StudyTermsShorthand))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
- }
- psValidator = def
- -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
- & defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- in dbTable psValidator DBTable{..}
-
- mkCandidateTable =
- let dbtIdent = "admin-termcandidate" :: Text
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
- dbtSQLQuery :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyTermCandidateId)
- dbtProj = return
- dbtColonnade = dbColonnade $ mconcat
- [ dbRow
- , sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
- , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
- , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn (E.^. StudyTermCandidateKey))
- , ("name" , SortColumn (E.^. StudyTermCandidateName))
- , ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
- ]
- dbtFilter = Map.fromList
- [ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateKey))
- , ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
- , ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
- ]
- dbtFilterUI mPrev = mconcat
- -- [ prismAForm (singletonFilter "key") mPrev $ aopt intField (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
- [ prismAForm (singletonFilter "key") mPrev $ aopt textField (fslI MsgStudyTermsKey)
- , prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
- , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
- ]
- dbtParams = def
- psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- in dbTable psValidator DBTable{..}
-
diff --git a/src/Handler/Admin/ErrorMessage.hs b/src/Handler/Admin/ErrorMessage.hs
new file mode 100644
index 000000000..5de72e683
--- /dev/null
+++ b/src/Handler/Admin/ErrorMessage.hs
@@ -0,0 +1,32 @@
+module Handler.Admin.ErrorMessage
+ ( getAdminErrMsgR, postAdminErrMsgR
+ ) where
+
+import Import
+import Handler.Utils
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+
+import Control.Monad.Trans.Except
+
+
+getAdminErrMsgR, postAdminErrMsgR :: Handler Html
+getAdminErrMsgR = postAdminErrMsgR
+postAdminErrMsgR = do
+ ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
+ unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing
+
+ plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
+
+ let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding }
+ defaultLayout
+ [whamlet|
+ $maybe t <- plaintext
+
+ $case t
+ $of String t'
+ #{t'}
+ $of t'
+ #{encodePrettyToTextBuilder t'}
+
+ ^{ctView'}
+ |]
diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs
new file mode 100644
index 000000000..02c45f97a
--- /dev/null
+++ b/src/Handler/Admin/StudyFeatures.hs
@@ -0,0 +1,528 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Handler.Admin.StudyFeatures
+ ( getAdminFeaturesR, postAdminFeaturesR
+ ) where
+
+import Import
+import Handler.Utils
+
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
+
+import qualified Handler.Utils.TermCandidates as Candidates
+
+
+data ButtonAdminStudyTermsNames
+ = BtnNameCandidatesInfer
+ | BtnNameCandidatesDeleteConflicts
+ | BtnNameCandidatesDeleteAll
+ deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsNames
+instance Finite ButtonAdminStudyTermsNames
+
+nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
+
+instance Button UniWorX ButtonAdminStudyTermsNames where
+ btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary]
+ btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
+ btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger]
+
+data ButtonAdminStudyTermsParents
+ = BtnParentCandidatesInfer
+ | BtnParentCandidatesDeleteAll
+ deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsParents
+instance Finite ButtonAdminStudyTermsParents
+
+nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
+
+instance Button UniWorX ButtonAdminStudyTermsParents where
+ btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
+ btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
+
+data ButtonAdminStudyTermsStandalone
+ = BtnStandaloneCandidatesDeleteRedundant
+ | BtnStandaloneCandidatesDeleteAll
+ deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsStandalone
+instance Finite ButtonAdminStudyTermsStandalone
+
+nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id
+
+instance Button UniWorX ButtonAdminStudyTermsStandalone where
+ btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
+ btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
+
+
+getAdminFeaturesR, postAdminFeaturesR :: Handler Html
+getAdminFeaturesR = postAdminFeaturesR
+postAdminFeaturesR = do
+ uid <- requireAuthId
+ ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
+ let nameBtnForm = wrapForm nameBtnWdgt def
+ { formAction = Just $ SomeRoute AdminFeaturesR
+ , formEncoding = nameBtnEnctype
+ , formSubmit = FormNoSubmit
+ }
+ infNameConflicts <- case nameBtnResult of
+ FormSuccess BtnNameCandidatesInfer -> do
+ (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
+ unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
+ unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
+ unless (null infConflicts) $ do
+ let badKeys = map entityKey infConflicts
+ setSessionJson SessionConflictingStudyTerms badKeys
+ addMessageI Warning MsgStudyFeatureConflict
+
+ let newKeys = map fst infAccepted
+ setSessionJson SessionNewStudyTerms newKeys
+
+ if | null infAccepted
+ -> addMessageI Info MsgNoNameCandidatesInferred
+ | otherwise
+ -> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
+ redirect AdminFeaturesR
+ FormSuccess BtnNameCandidatesDeleteConflicts -> do
+ runDB $ do
+ confs <- Candidates.nameConflicts
+ incis <- Candidates.getNameIncidencesFor $ map entityKey confs
+ deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
+ addMessageI Success $ MsgIncidencesDeleted $ length incis
+ redirect AdminFeaturesR
+ FormSuccess BtnNameCandidatesDeleteAll -> do
+ runDB $ do
+ deleteWhere ([] :: [Filter StudyTermNameCandidate])
+ addMessageI Success MsgAllNameIncidencesDeleted
+ redirect AdminFeaturesR
+ _other -> runDB Candidates.nameConflicts
+
+ ((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
+ let parentsBtnForm = wrapForm parentsBtnWdgt def
+ { formAction = Just $ SomeRoute AdminFeaturesR
+ , formEncoding = parentsBtnEnctype
+ , formSubmit = FormNoSubmit
+ }
+ formResult parentsBtnResult $ \case
+ BtnParentCandidatesInfer -> do
+ (infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
+ unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
+
+ let newKeys = map (studySubTermsChild . entityVal) infAccepted
+ setSessionJson SessionNewStudyTerms newKeys
+
+ if | null infAccepted
+ -> addMessageI Info MsgNoParentCandidatesInferred
+ | otherwise
+ -> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
+ redirect AdminFeaturesR
+ BtnParentCandidatesDeleteAll -> do
+ runDB $ do
+ deleteWhere ([] :: [Filter StudySubTermParentCandidate])
+ addMessageI Success MsgAllParentIncidencesDeleted
+ redirect AdminFeaturesR
+
+ ((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm
+ let standaloneBtnForm = wrapForm standaloneBtnWdgt def
+ { formAction = Just $ SomeRoute AdminFeaturesR
+ , formEncoding = standaloneBtnEnctype
+ , formSubmit = FormNoSubmit
+ }
+ formResult standaloneBtnResult $ \case
+ BtnStandaloneCandidatesDeleteRedundant -> do
+ infRedundantStandalone <- runDB Candidates.removeRedundantStandalone
+ unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
+ redirect AdminFeaturesR
+ BtnStandaloneCandidatesDeleteAll -> do
+ runDB $ do
+ deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
+ addMessageI Success MsgAllStandaloneIncidencesDeleted
+ redirect AdminFeaturesR
+
+
+ newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
+ badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
+ ( (degreeResult,degreeTable)
+ , (studyTermsResult,studytermsTable)
+ , ((), candidateTable)
+ , userSchools
+ , ((), parentCandidateTable)
+ , (standaloneResult, standaloneCandidateTable)) <- runDB $ do
+ schools <- E.select . E.from $ \school -> do
+ E.where_ . E.exists . E.from $ \schoolFunction ->
+ E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
+ E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
+ E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+ return school
+ (,,,,,)
+ <$> mkDegreeTable
+ <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+ (Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
+ (Set.fromList schools)
+ <*> mkCandidateTable
+ <*> pure schools
+ <*> mkParentCandidateTable
+ <*> mkStandaloneCandidateTable
+
+ let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
+ degreeResult' = degreeResult <&> getDBFormResult
+ (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
+ , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
+ ))
+ updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
+ formResult degreeResult' $ \res -> do
+ void . runDB $ Map.traverseWithKey updateDegree res
+ addMessageI Success MsgStudyDegreeChangeSuccess
+ redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
+
+ let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType))
+ standaloneResult' = standaloneResult <&> getDBFormResult
+ (\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
+ , row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just
+ ))
+ formResult standaloneResult' $ \res -> do
+ updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do
+ StudyTermStandaloneCandidate{..} <- getJust candidateId
+ let termsId = StudyTermsKey' studyTermStandaloneCandidateKey
+ updated <- case (,) <$> mDegree <*> mType of
+ Nothing -> return Nothing
+ Just (degree, typ) -> do
+ ifM (existsKey termsId)
+ ( update termsId
+ [ StudyTermsDefaultDegree =. Just degree
+ , StudyTermsDefaultType =. Just typ
+ ]
+ )
+ ( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ)
+ )
+ return $ Just termsId
+ infRedundantStandalone <- Candidates.removeRedundantStandalone
+ unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
+ return updated
+
+ let newKeys = catMaybes $ Map.elems updated
+ unless (null newKeys) $ do
+ setSessionJson SessionNewStudyTerms newKeys
+
+ redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+
+
+ let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
+ studyTermsResult' = studyTermsResult <&> getDBFormResult
+ (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
+ , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
+ , row ^. _dbrOutput . _3
+ , row ^. _dbrOutput . _2 . to (Set.map entityKey)
+ , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
+ , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
+ ))
+ updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
+ degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
+ update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
+
+ forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
+ deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
+
+ forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
+ deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
+ formResult studyTermsResult' $ \res -> do
+ void . runDB $ Map.traverseWithKey updateStudyTerms res
+ addMessageI Success MsgStudyTermsChangeSuccess
+ redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+
+ siteLayoutMsg MsgAdminFeaturesHeading $ do
+ setTitleI MsgAdminFeaturesHeading
+ $(widgetFile "adminFeatures")
+ where
+ textInputCell :: Ord i
+ => Lens' a (Maybe Text)
+ -> Getter (DBRow r) (Maybe Text)
+ -> Getter (DBRow r) i
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
+ <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
+ )
+
+ checkboxCell :: Ord i
+ => Lens' a Bool
+ -> Getter (DBRow r) Bool
+ -> Getter (DBRow r) i
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+ <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
+ )
+
+ -- termKeyCell :: Ord i
+ -- => Lens' a (Maybe StudyTermsId)
+ -- -> Getter (DBRow r) (Maybe StudyTermsId)
+ -- -> Getter (DBRow r) i
+ -- -> DBRow r
+ -- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ -- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ -- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+ -- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault)
+ -- )
+
+ parentsCell :: Ord i
+ => Lens' a (Set StudyTermsId)
+ -> Getter (DBRow r) (Set StudyTermsId)
+ -> Getter (DBRow r) i
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ ( \row mkUnique -> (\(res, fieldView) -> (set lensRes . Set.fromList <$> res, fvInput fieldView))
+ <$> massInputList
+ (intField & isoField (from _StudyTermsId))
+ (const "")
+ (Just . SomeRoute . (AdminFeaturesR :#:))
+ (mkUnique ("parents" :: Text))
+ ""
+ False
+ (Just . Set.toList $ row ^. lensDefault)
+ mempty
+ )
+
+ degreeCell :: Ord i
+ => Lens' a (Maybe StudyDegreeId)
+ -> Getter (DBRow r) (Maybe StudyDegreeId)
+ -> Getter (DBRow r) i
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+ <$> mopt degreeField "" (Just $ row ^. lensDefault)
+ )
+
+ fieldTypeCell :: Ord i
+ => Lens' a (Maybe StudyFieldType)
+ -> Getter (DBRow r) (Maybe StudyFieldType)
+ -> Getter (DBRow r) i
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+ ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+ <$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault)
+ )
+
+
+ mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
+ mkDegreeTable =
+ let dbtIdent = "admin-studydegrees" :: Text
+ dbtStyle = def
+ dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
+ dbtSQLQuery = return
+ dbtRowKey = (E.^. StudyDegreeKey)
+ dbtProj = return
+ dbtColonnade = formColonnade $ mconcat
+ [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
+ , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
+ , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
+ , dbRow
+ ]
+ dbtSorting = Map.fromList
+ [ ("key" , SortColumn (E.^. StudyDegreeKey))
+ , ("name" , SortColumn (E.^. StudyDegreeName))
+ , ("short", SortColumn (E.^. StudyDegreeShorthand))
+ ]
+ dbtFilter = mempty
+ dbtFilterUI = mempty
+ dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
+ }
+ psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+ & defaultPagesize PagesizeAll
+ & defaultSorting [SortAscBy "key"]
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ in dbTable psValidator DBTable{..}
+
+ mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget)
+ mkStudytermsTable newKeys badKeys schools =
+ let dbtIdent = "admin-studyterms" :: Text
+ dbtStyle = def
+ dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
+ dbtSQLQuery = return
+ dbtRowKey = (E.^. StudyTermsKey)
+ dbtProj field@(view _dbrOutput -> Entity fId _) = do
+ fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
+ E.where_ . E.exists . E.from $ \schoolTerms ->
+ E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
+ E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
+ E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
+ return $ school E.^. SchoolId
+ fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
+ E.where_ . E.exists . E.from $ \subTerms ->
+ E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
+ E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
+ return terms
+ return $ field & _dbrOutput %~ (\field' -> (field', fieldParents, fieldSchools))
+ dbtColonnade = formColonnade $ mconcat
+ [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
+ , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
+ , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
+ , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
+ , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
+ , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
+ , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
+ , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
+ , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
+ sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
+ , dbRow
+ ]
+ dbtSorting = Map.fromList
+ [ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
+ -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
+ , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
+ )
+ , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
+ )
+ , ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName))
+ , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
+ , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
+ , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
+ ]
+ dbtFilter = mempty
+ dbtFilterUI = mempty
+ dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+ }
+ psValidator = def
+ & defaultPagesize PagesizeAll
+ & defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"]
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+
+ queryField = id
+ _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
+ _dbrKey' = _dbrOutput . _1 . _entityKey
+ in dbTable psValidator DBTable{..}
+
+ mkCandidateTable =
+ let dbtIdent = "admin-termcandidate" :: Text
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+ dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
+ dbtSQLQuery = return
+ dbtRowKey = (E.^. StudyTermNameCandidateId)
+ dbtProj = return
+ dbtColonnade = dbColonnade $ mconcat
+ [ dbRow
+ , sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
+ , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
+ , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
+ ]
+ dbtSorting = Map.fromList
+ [ ("key" , SortColumn (E.^. StudyTermNameCandidateKey))
+ , ("name" , SortColumn (E.^. StudyTermNameCandidateName))
+ , ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence))
+ ]
+ dbtFilter = Map.fromList
+ [ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateKey))
+ , ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName))
+ , ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here
+ ]
+ dbtFilterUI mPrev = mconcat
+ [ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey)
+ , prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
+ , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
+ ]
+ dbtParams = def
+ psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ in dbTable psValidator DBTable{..}
+
+ mkParentCandidateTable =
+ let dbtIdent = "admin-termparentcandidate" :: Text
+ dbtStyle = def
+ dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate)
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+ -> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate)
+ , E.SqlExpr (Maybe (Entity StudyTerms))
+ , E.SqlExpr (Maybe (Entity StudyTerms))
+ )
+ dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do
+ E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey)
+ E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
+ return (candidate, parent, child)
+ dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
+ dbtProj = return
+ dbtColonnade = dbColonnade $ mconcat
+ [ dbRow
+ , sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
+ , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
+ , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
+ , sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
+ , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence))
+ ]
+ dbtSorting = Map.fromList
+ [ ("child" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey))
+ , ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV)
+ , ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
+ , ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV)
+ , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence))
+ ]
+ dbtFilter = mempty
+ dbtFilterUI = mempty
+ dbtParams = def
+ psValidator = def
+ & defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"]
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+
+ queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c
+ queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p
+ queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c
+ in dbTable psValidator DBTable{..}
+
+ mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget)
+ mkStandaloneCandidateTable =
+ let dbtIdent = "admin-termstandalonecandidate" :: Text
+ dbtStyle = def
+ dbtSQLQuery :: E.SqlExpr (Entity StudyTermStandaloneCandidate)
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+ -> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate)
+ , E.SqlExpr (Maybe (Entity StudyTerms))
+ )
+ dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do
+ E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
+ return (candidate, sterm)
+ dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
+ dbtProj = return
+ dbtColonnade = formColonnade $ mconcat
+ [ dbRow
+ , sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
+ , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
+ , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
+ , sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')
+ , sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey')
+ ]
+ dbtSorting = Map.fromList
+ [ ("key" , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey))
+ , ("name" , SortColumn $ queryTerm >>> (E.?. StudyTermsName) >>> E.joinV)
+ , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence))
+ ]
+ dbtFilter = mempty
+ dbtFilterUI = mempty
+ dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+ }
+ psValidator = def
+ & defaultSorting [SortAscBy "key", SortAscBy "incidence"]
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+
+ queryCandidate (c `E.LeftOuterJoin` _) = c
+ queryTerm (_ `E.LeftOuterJoin` t) = t
+ _dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId
+ _dbrKey' = _dbrOutput . _1 . _entityKey
+ in dbTable psValidator DBTable{..}
diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs
new file mode 100644
index 000000000..b08f07dff
--- /dev/null
+++ b/src/Handler/Admin/Test.hs
@@ -0,0 +1,231 @@
+module Handler.Admin.Test
+ ( getAdminTestR
+ , postAdminTestR
+ ) where
+
+import Import
+import Handler.Utils
+import Jobs
+
+import Control.Monad.Trans.Writer (mapWriterT)
+
+import Data.Char (isDigit)
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Database.Persist.Sql (fromSqlKey)
+
+
+-- BEGIN - Buttons needed only here
+data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
+ deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCreate
+instance Finite ButtonCreate
+
+nullaryPathPiece ''ButtonCreate camelToPathPiece
+
+instance Button UniWorX ButtonCreate where
+ btnLabel CreateMath = [whamlet|Mathematik|]
+ btnLabel CreateInf = "Informatik"
+
+ btnClasses CreateMath = [BCIsButton, BCInfo]
+ btnClasses CreateInf = [BCIsButton, BCPrimary]
+-- END Button needed only here
+
+emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
+emailTestForm = (,)
+ <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
+ <*> ( MailContext
+ <$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
+ <*> (toMailDateTimeFormat
+ <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
+ <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
+ <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
+ )
+ )
+ where
+ toMailDateTimeFormat dt d t = \case
+ SelFormatDateTime -> dt
+ SelFormatDate -> d
+ SelFormatTime -> t
+
+makeDemoForm :: Int -> Form (Int,Bool,Double)
+makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
+ (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
+ <$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
+ <* aformSection MsgFormBehaviour
+ <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
+ <*> areq doubleField "Fliesskommazahl" Nothing
+ -- NO LONGER DESIRED IN AFORMS:
+ -- <* submitButton
+ return $ case result of
+ FormSuccess fsres
+ | errorMsgs <- validateResult fsres
+ , not $ null errorMsgs -> (FormFailure errorMsgs, widget)
+ _otherwise -> (result, widget)
+ where
+ validateResult :: (Int,Bool,Double) -> [Text]
+ validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
+ validateResult _other = []
+
+
+getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = postAdminTestR
+postAdminTestR = do
+ ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
+ let btnForm = wrapForm btnWdgt def
+ { formAction = Just $ SomeRoute AdminTestR
+ , formEncoding = btnEnctype
+ , formSubmit = FormNoSubmit
+ }
+ case btnResult of
+ (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
+ (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+ FormMissing -> return ()
+ _other -> addMessage Warning "KEIN Knopf erkannt"
+
+ ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
+ formResultModal emailResult AdminTestR $ \(email, ls) -> do
+ jId <- mapWriterT runDB $ do
+ jId <- queueJob $ JobSendTestEmail email ls
+ tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
+ return jId
+ runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
+ addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
+
+ let emailWidget' = wrapForm emailWidget def
+ { formAction = Just . SomeRoute $ AdminTestR
+ , formEncoding = emailEnctype
+ , formAttrs = [("uw-async-form", "")]
+ }
+
+
+ let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
+ ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
+ formResult demoResult demoFormAction
+ let showDemoResult = [whamlet|
+ $maybe (i,b,d) <- formResult' demoResult
+ Received values:
+
+ #{tshow res}
+ |]
diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs
index d64bd13e7..9d52233ed 100644
--- a/src/Handler/Allocation/List.hs
+++ b/src/Handler/Allocation/List.hs
@@ -26,10 +26,9 @@ countCourses :: (Num n, PersistField n)
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
-> E.SqlExpr (Entity Allocation)
-> E.SqlExpr (E.Value n)
-countCourses addWhere allocation = E.sub_select . E.from $ \allocationCourse -> do
+countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
E.&&. addWhere allocationCourse
- return E.countRows
queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
queryAvailable = queryAllocation . to (countCourses $ const E.true)
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 8a39796fc..8e126e2bb 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -75,7 +75,7 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
-lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
+lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
return $ E.max_ $ edit E.^. SubmissionEditTime
@@ -297,7 +297,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
)
, ( "submittors"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
- E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+ E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
@@ -1215,9 +1215,8 @@ assignHandler tid ssh csh cid assignSids = do
submissions <- E.select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
- let numSubmittors = E.sub_select . E.from $ \subUser -> do
+ let numSubmittors = E.subSelectCount . E.from $ \subUser ->
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
- return E.countRows
return (submission, numSubmittors)
-- prepare map
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs
index f3f8de21b..b4e5b7f51 100644
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@@ -599,11 +599,10 @@ postCApplicationsR tid ssh csh = do
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
- let numApps addWhere = E.sub_select . E.from $ \courseApplication -> do
+ let numApps addWhere = E.subSelectCount . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
addWhere courseApplication
- return E.countRows
numApps' = numApps . const $ return ()
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index b8fcf5748..9f5bc8c7f 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -371,7 +371,7 @@ getCourseNewR = do
E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
let courseCreated c =
- E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
+ E.subSelectMaybe . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
return $ E.min_ $ edit E.^. CourseEditTime
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs
index a9075cee3..10192bdd5 100644
--- a/src/Handler/Course/List.hs
+++ b/src/Handler/Course/List.hs
@@ -61,9 +61,8 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
-course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
+course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
- return (E.countRows :: E.SqlExpr (E.Value Int))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index fc687713a..bda498e20 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -269,9 +269,7 @@ deregisterParticipant uid cid = do
audit $ TransactionExamResultDeleted examResultExam uid
E.delete . E.from $ \tutorialParticipant -> do
- let tutorialCourse = E.sub_select . E.from $ \tutorial -> do
- E.where_ $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
- return $ tutorial E.^. TutorialCourse
+ let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
E.where_ $ tutorialCourse E.==. E.val cid
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs
index 39ec5b047..ccc97291f 100644
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@@ -37,9 +37,9 @@ getCShowR tid ssh csh = do
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
- let numParticipants = E.sub_select . E.from $ \part -> do
+ let numParticipants :: E.SqlExpr (E.Value Int)
+ numParticipants = E.subSelectCount . E.from $ \part ->
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
- return ( E.countRows :: E.SqlExpr (E.Value Int))
return (course,school E.^. SchoolName, numParticipants, participant)
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
@@ -146,9 +146,9 @@ getCShowR tid ssh csh = do
Nothing -> mempty
Just tutorialCapacity' -> sqlCell $ do
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
- . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
+ . E.select $ let numParticipants :: E.SqlExpr (E.Value Int)
+ numParticipants = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
in return $ E.val tutorialCapacity' E.-. numParticipants
return . toWidget $ tshow freeCapacity
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index 6f3c7e6cc..3ba3d9801 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -301,12 +301,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
- E.sub_select . E.from $ \edit -> do
+ E.subSelectMaybe . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
- E.sub_select . E.from $ \(tutorial `E.InnerJoin` participant) -> do
+ E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index a5f49fb46..046d6c7f4 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -110,7 +110,7 @@ queryExamPart :: forall a.
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
-> ExamUserTableExpr
-> E.SqlExpr (E.Value a)
-queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
+queryExamPart epId cont inp = E.subSelectUnsafe . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
examRegistration <- asks queryExamRegistration
lift $ do
@@ -528,7 +528,7 @@ postEUsersR tid ssh csh examn = do
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
- E.sub_select . E.from $ \edit -> do
+ E.subSelectMaybe . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
]
diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs
index 9fd949692..ba3a8f68e 100644
--- a/src/Handler/ExamOffice/Exams.hs
+++ b/src/Handler/ExamOffice/Exams.hs
@@ -33,21 +33,19 @@ querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlE
querySynchronised office = to . runReader $ do
exam <- view queryExam
let
- synchronised = E.sub_select . E.from $ \examResult -> do
+ synchronised = E.subSelectCount . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
E.where_ $ Exam.resultIsSynced office examResult
- return E.countRows
return synchronised
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
queryResults office = to . runReader $ do
exam <- view queryExam
let
- results = E.sub_select . E.from $ \examResult -> do
+ results = E.subSelectCount . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
- return E.countRows
return results
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 7608b1195..532326ec3 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -158,7 +158,7 @@ homeUpcomingExams uid = do
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
E.&&. E.isJust (register E.?. ExamRegistrationId)
- earliestOccurrence = E.sub_select $ E.from $ \occ -> do
+ earliestOccurrence = E.subSelectMaybe $ E.from $ \occ -> do
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
return $ E.min_ $ occ E.^. ExamOccurrenceStart
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 740ed670d..650d69d36 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -114,9 +114,9 @@ getMaterialListR tid ssh csh = do
, dbtParams = def
, dbtSQLQuery = \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
- let filesNum = E.sub_select . E.from $ \materialFile -> do
+ let filesNum :: E.SqlExpr (E.Value Int64)
+ filesNum = E.subSelectCount . E.from $ \materialFile ->
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
return (material, filesNum)
, dbtRowKey = (E.^. MaterialId)
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
@@ -331,9 +331,9 @@ postMDelR tid ssh csh mnm = do
{ drRecords = Set.singleton $ entityKey matEnt
, drGetInfo = \(material `E.InnerJoin` course) -> do
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
- let filecount = E.sub_select . E.from $ \matfile -> do
+ let filecount :: E.SqlExpr (E.Value Int64)
+ filecount = E.subSelectCount . E.from $ \matfile ->
E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
- return (E.countRows :: E.SqlExpr (E.Value Int64))
return (material,course,filecount)
, drUnjoin = \(material `E.InnerJoin` _course) -> material
, drRenderRecord = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index d6de8d24e..4611c004e 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -359,10 +359,13 @@ makeProfileData (Entity uid User{..}) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
- studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+ studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) ->
+ E.distinctOnOrderBy [ E.asc $ studyfeat E.^. StudyFeaturesId ] $ do
+ E.orderBy [ E.desc $ studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms E.^. StudyTermsId) ]
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
- E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
- E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+ E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
+ E.||. studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms E.^. StudyTermsId)
+ E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
--Tables
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
@@ -507,7 +510,7 @@ mkSubmissionTable =
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
- E.sub_select . E.from $ \subEdit -> do
+ E.subSelectMaybe . E.from $ \subEdit -> do
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
return . E.max_ $ subEdit E.^. SubmissionEditTime
@@ -590,7 +593,7 @@ mkSubmissionGroupTable =
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
- E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
+ E.subSelectMaybe . E.from $ \(user `E.InnerJoin` sgEdit) -> do
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
@@ -649,16 +652,14 @@ mkCorrectionsTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id
- corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
+ corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
- return E.countRows
- corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
+ corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
- return E.countRows
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index bc5c308d4..ff7cc41ea 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do
, sft /= SheetSolution || hasSolution
, sft /= SheetMarking || hasMarking
]
- lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
+ lastSheetEdit sheet = E.subSelectMaybe . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime
@@ -504,14 +504,14 @@ getSheetNewR tid ssh csh = do
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
searchShn sheet
- -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
+ -- let lastSheetEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
-- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
-- return . E.max_ $ sheetEdit E.^. SheetEditTime
-- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1
- let firstEdit = E.sub_select . E.from $ \sheetEdit -> do
+ let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.min_ $ sheetEdit E.^. SheetEditTime
return (sheet, firstEdit)
@@ -711,7 +711,7 @@ defaultLoads cId = do
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
- let creationTime = E.sub_select . E.from $ \sheetEdit -> do
+ let creationTime = E.subSelectMaybe . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.min_ $ sheetEdit E.^. SheetEditTime
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index abce61c63..f43384eac 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -43,9 +43,8 @@ getTermShowR = do
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
termData term = do
-- E.orderBy [E.desc $ term E.^. TermStart ]
- let courseCount = E.sub_select . E.from $ \course -> do
+ let courseCount = E.subSelectCount . E.from $ \course ->
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
- return E.countRows
return (term, courseCount)
selectRep $ do
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs
index 58931f1aa..2fc9e8627 100644
--- a/src/Handler/Tutorial/Delete.hs
+++ b/src/Handler/Tutorial/Delete.hs
@@ -23,9 +23,8 @@ postTDeleteR tid ssh csh tutn = do
, drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
, drGetInfo = \(course `E.InnerJoin` tutorial) -> do
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
- let participants = E.sub_select . E.from $ \participant -> do
+ let participants = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
- return E.countRows
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs
index 11d05bc00..11ae3dc41 100644
--- a/src/Handler/Tutorial/List.hs
+++ b/src/Handler/Tutorial/List.hs
@@ -22,9 +22,9 @@ getCTutorialListR tid ssh csh = do
where
dbtSQLQuery tutorial = do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
- let participants = E.sub_select . E.from $ \tutorialParticipant -> do
+ let participants :: E.SqlExpr (E.Value Int)
+ participants = E.subSelectCount . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
return (tutorial, participants)
dbtRowKey = (E.^. TutorialId)
dbtProj = return . over (_dbrOutput . _2) E.unValue
@@ -58,9 +58,10 @@ getCTutorialListR tid ssh csh = do
dbtSorting = Map.fromList
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
- , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
- E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+ , ("participants", SortColumn $ \tutorial -> let participantCount :: E.SqlExpr (E.Value Int)
+ participantCount = E.subSelectCount . E.from $ \tutorialParticipant ->
+ E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
+ in participantCount
)
, ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index c2d944690..a803af4df 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -439,10 +439,9 @@ deleteUser duid = do
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
- let numBuddies = E.sub_select $ E.from $ \subUsers -> do
+ let numBuddies = E.subSelectCount $ E.from $ \subUsers ->
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
- return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId
diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs
index ae9cffcb1..92ced534b 100644
--- a/src/Handler/Utils/Allocation.hs
+++ b/src/Handler/Utils/Allocation.hs
@@ -91,12 +91,11 @@ computeAllocation allocId cRestr = do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
- let participants = E.sub_select . E.from $ \participant -> do
+ let participants = E.subSelectCount . E.from $ \participant -> do
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
- E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do
+ E.where_ . E.not_ . E.exists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
- return E.countRows
whenIsJust cRestr $ \restrSet ->
E.where_ $ course E.^. CourseId `E.in_` E.valList (Set.toList restrSet)
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 85467b5f7..c11514a07 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -353,6 +353,12 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
+degreeField :: Field Handler StudyDegreeId
+degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
+
+degreeFieldEnt :: Field Handler (Entity StudyDegree)
+degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
+
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index c4230890b..99bd99691 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -274,6 +274,7 @@ sourceInvitations :: forall junction m backend.
, MonadThrow m
, PersistRecordBackend Invitation backend
, HasPersistBackend backend
+ , PersistQueryRead backend
)
=> Key (InvitationFor junction)
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
@@ -293,6 +294,7 @@ sourceInvitationsF :: forall junction map m backend.
, MonadThrow m
, PersistRecordBackend Invitation backend
, HasPersistBackend backend
+ , PersistQueryRead backend
)
=> Key (InvitationFor junction)
-> ReaderT backend m map
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index 723461206..2d4c78c0f 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/src/Handler/Utils/Sheet.hs
@@ -58,9 +58,8 @@ sheetDeleteRoute drRecords = DeleteRoute
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
- let submissions = E.sub_select . E.from $ \submission -> do
+ let submissions = E.subSelectCount . E.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
- return E.countRows
E.orderBy [E.asc $ sheet E.^. SheetName]
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index c3662286a..bbd194617 100644
--- a/src/Handler/Utils/StudyFeatures.hs
+++ b/src/Handler/Utils/StudyFeatures.hs
@@ -1,5 +1,6 @@
module Handler.Utils.StudyFeatures
( parseStudyFeatures
+ , parseSubTermsSemester
) where
import Import.NoFoundation hiding (try, (<|>))
@@ -7,9 +8,19 @@ import Import.NoFoundation hiding (try, (<|>))
import Text.Parsec
import Text.Parsec.Text
+import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
+import qualified Ldap.Client as Ldap
+
parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
+parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
+ where
+ Ldap.Attr key = ldapUserStudyFeatures
+
+parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
+parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
+ where
+ Ldap.Attr key = ldapUserSubTermsSemester
pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
@@ -19,9 +30,9 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
let
pStudyFeature = do
- _ <- pKey -- Meaning unknown at this time
+ _ <- pKey -- "Fächergruppe"
void $ char '!'
- _ <- pKey -- Meaning unknown
+ _ <- pKey -- "Studienbereich"
void $ char '!'
studyFeaturesField <- StudyTermsKey' <$> pKey
void $ char '!'
@@ -29,6 +40,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
void $ char '!'
studyFeaturesSemester <- decimal
let studyFeaturesValid = True
+ studyFeaturesSubField = Nothing
return StudyFeatures{..}
pStudyFeature `sepBy1` char '#'
@@ -45,3 +57,12 @@ decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
where
digit' = dVal <$> digit
dVal c = fromEnum c - fromEnum '0'
+
+
+pLMUTermsSemester :: Parser (StudyTermsId, Int)
+pLMUTermsSemester = do
+ subTermsKey <- StudyTermsKey' <$> pKey
+ void $ char '$'
+ semester <- decimal
+
+ return (subTermsKey, semester)
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 694ba01e7..d9d093618 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -724,7 +724,7 @@ submissionDeleteRoute drRecords = DeleteRoute
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
- let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
+ let lastEdit = E.subSelectMaybe . E.from $ \submissionEdit -> do
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
return . E.max_ $ submissionEdit E.^. SubmissionEditTime
E.orderBy [E.desc lastEdit]
diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs
index c986ed61b..729fd0eaa 100644
--- a/src/Handler/Utils/TermCandidates.hs
+++ b/src/Handler/Utils/TermCandidates.hs
@@ -25,11 +25,11 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E
--- import Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Sql as E
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
-type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
+type STKey = Int -- for convenience, assmued identical to field StudyTermNameCandidateKey
data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
deriving (Typeable, Show)
@@ -46,26 +46,44 @@ instance Exception FailedCandidateInference
-- * list of problems, ie. StudyTerms that contradict observed incidences
-- * list of redundants, i.e. redundant observed incidences
-- * list of accepted, i.e. newly accepted key/name pairs
-inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)])
-inferHandler = runDB $ inferAcc ([],[],[])
+inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)])
+inferNamesHandler = runDB $ inferAcc mempty
where
inferAcc (accAmbiguous, accRedundants, accAccepted) =
- handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do
- (infAmbis, infReds,infAccs) <- inferStep
- if null infAccs
- then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted)
- else do
+ handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do
+ (infAmbis, infReds, infAccs) <- inferStep
+ if
+ | null infAccs ->
+ return ([], accAmbiguous, infReds <> accRedundants, accAccepted')
+ | otherwise -> do
E.transactionSave -- commit transaction if there are no problems
- inferAcc (infAmbis ++ accAmbiguous, infReds ++ accRedundants, infAccs ++ accAccepted)
+ inferAcc (infAmbis <> accAmbiguous, infReds <> accRedundants, infAccs <> accAccepted)
+ where
+ accAccepted' = over (traversed . _1) StudyTermsKey' accAccepted
inferStep = do
- ambiguous <- removeAmbiguous
- redundants <- removeRedundant
- accepted <- acceptSingletons
- problems <- conflicts
+ ambiguous <- removeAmbiguousNames
+ redundants <- removeRedundantNames
+ accepted <- acceptSingletonNames
+ problems <- nameConflicts
unless (null problems) $ throwM $ FailedCandidateInference problems
return (ambiguous, redundants, accepted)
+inferParentsHandler :: Handler ([Entity StudySubTermParentCandidate], [Entity StudySubTerms])
+inferParentsHandler = runDB $ inferAcc mempty
+ where
+ inferAcc (infReds', infAccs') = do
+ (infReds, infAccs) <- inferStep
+ if
+ | null infAccs ->
+ return (infReds' <> infReds, infAccs')
+ | otherwise ->
+ inferAcc (infReds' <> infReds, infAccs' <> infAccs)
+ inferStep = do
+ redundants <- removeRedundantParents
+ accepted <- acceptSingletonParents
+ return (redundants, accepted)
+
{-
Candidate 1 11 "A"
Candidate 1 11 "B"
@@ -87,35 +105,65 @@ as a fix we simply eliminate all observations that have the same name twice, see
-- | remove candidates with ambiguous observations,
-- ie. candidates that have duplicated term names with differing keys
-- which may happen in rare cases
-removeAmbiguous :: DB [TermCandidateIncidence]
-removeAmbiguous = do
+removeAmbiguousNames :: DB [TermCandidateIncidence]
+removeAmbiguousNames = do
ambiList <- E.select $ E.from $ \candidate -> do
- E.groupBy ( candidate E.^. StudyTermCandidateIncidence
- , candidate E.^. StudyTermCandidateKey
- , candidate E.^. StudyTermCandidateName
+ E.groupBy ( candidate E.^. StudyTermNameCandidateIncidence
+ , candidate E.^. StudyTermNameCandidateKey
+ , candidate E.^. StudyTermNameCandidateName
)
E.having $ E.countRows E.!=. E.val (1 :: Int64)
- return $ candidate E.^. StudyTermCandidateIncidence
+ return $ candidate E.^. StudyTermNameCandidateIncidence
let ambiSet = E.unValue <$> List.nub ambiList
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
- deleteWhere [StudyTermCandidateIncidence <-. ambiSet]
+ deleteWhere [StudyTermNameCandidateIncidence <-. ambiSet]
return ambiSet
-- | remove known StudyTerm from candidates that have the _exact_ name,
-- ie. if a candidate contains a known key, we remove it and its associated fullname
-- only save if ambiguous candidates haven been removed
-removeRedundant :: DB [Entity StudyTermCandidate]
-removeRedundant = do
+removeRedundantNames :: DB [Entity StudyTermNameCandidate]
+removeRedundantNames = do
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
- E.on $ candidate E.^. StudyTermCandidateKey E.==. sterm E.^. StudyTermsKey
- E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
+ E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey
+ E.&&. ( E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName
+ E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do
+ E.on $ subTerm E.^. StudySubTermsParent E.==. sterm E.^. StudyTermsId
+ E.&&. subTerm E.^. StudySubTermsChild E.==. sterm2 E.^. StudyTermsId
+ E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName
+ )
+ )
return candidate
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
- forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
- deleteWhere $ ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
- : ([ StudyTermCandidateKey ==. studyTermCandidateKey ]
- ||. [ StudyTermCandidateName ==. studyTermCandidateName ])
+ forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
+ deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
+ : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ]
+ ||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
+ return redundants
+
+removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
+removeRedundantParents = do
+ redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` subTerm) -> do
+ E.on $ candidate E.^. StudySubTermParentCandidateKey E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsChild)
+ E.&&. candidate E.^. StudySubTermParentCandidateParent E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsParent)
+ return candidate
+ forM_ redundants $ \(Entity _ StudySubTermParentCandidate{..}) ->
+ E.delete . E.from $ \candidate ->
+ E.where_ $ candidate E.^. StudySubTermParentCandidateIncidence E.==. E.val studySubTermParentCandidateIncidence
+ E.&&. ( candidate E.^. StudySubTermParentCandidateParent `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
+ E.||. candidate E.^. StudySubTermParentCandidateKey `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
+ )
+ return redundants
+
+removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
+removeRedundantStandalone = do
+ redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` sterm) -> do
+ E.on $ candidate E.^. StudyTermStandaloneCandidateKey E.==. sterm E.^. StudyTermsKey
+ E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultDegree)
+ E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultType)
+ return candidate
+ deleteWhere [ StudyTermStandaloneCandidateId <-. map entityKey redundants ]
return redundants
@@ -124,12 +172,12 @@ removeRedundant = do
-- Does not delete the used candidates, user @removeRedundant@ for this later on.
-- Esqueleto does not provide the INTERESECT operator, thus
-- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
-acceptSingletons :: DB [(STKey,Text)]
-acceptSingletons = do
+acceptSingletonNames :: DB [(STKey,Text)]
+acceptSingletonNames = do
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
-- let knownKeysSet = Set.fromAscList knownKeys
-- In case of memory problems, change next lines to conduit proper:
- incidences <- fmap entityVal <$> selectList [StudyTermCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
+ incidences <- fmap entityVal <$> selectList [StudyTermNameCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
-- incidences <- E.select $ E.from $ \candidate -> do
-- E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
-- return candidate
@@ -139,11 +187,11 @@ acceptSingletons = do
groupedCandidates = foldl' groupFun mempty incidences
-- given a key, map each incidence to set of possible names for this key
- groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
- groupFun m StudyTermCandidate{..} =
+ groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermNameCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
+ groupFun m StudyTermNameCandidate{..} =
insertWith (Map.unionWith Set.union)
- studyTermCandidateKey
- (Map.singleton studyTermCandidateIncidence $ Set.singleton studyTermCandidateName)
+ studyTermNameCandidateKey
+ (Map.singleton studyTermNameCandidateIncidence $ Set.singleton studyTermNameCandidateName)
m
-- pointwise intersection per incidence gives possible candidates per key
@@ -152,36 +200,99 @@ acceptSingletons = do
-- filter candidates having a unique possibility left
fixedKeys :: [(STKey,Text)]
- fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
-
- combFixed :: [(STKey,Text)] -> STKey -> Set Text -> [(STKey,Text)]
- combFixed acc k s | Set.size s == 1 -- possibly redundant
- , [n] <- Set.elems s = (k,n):acc
- -- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
- | otherwise = acc
+ fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates
+ where
+ combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey)
+ combFixed (acc, bad) k s
+ | Set.member k bad
+ = (acc, bad)
+ | maybe False (`Set.notMember` s) (lookup k acc)
+ = (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
+ | [n] <- Set.elems s
+ = ((k,n) : acc, bad)
+ | otherwise = (acc, bad)
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
registerFixed :: (STKey, Text) -> DB ()
- registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
+ registerFixed (key, name) =
+ repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
-- register newly fixed candidates
forM_ fixedKeys registerFixed
return fixedKeys
+acceptSingletonParents :: DB [Entity StudySubTerms]
+acceptSingletonParents = do
+ candidates <- map entityVal <$> selectList [] []
+
+ let
+ groupedCandidates :: Map STKey (Map UUID (Set STKey))
+ groupedCandidates = foldl' groupFun mempty candidates
+ where
+ groupFun :: Map STKey (Map UUID (Set STKey)) -> StudySubTermParentCandidate -> Map STKey (Map UUID (Set STKey))
+ groupFun m StudySubTermParentCandidate{..} =
+ Map.insertWith (Map.unionWith Set.union)
+ studySubTermParentCandidateKey
+ (Map.singleton studySubTermParentCandidateIncidence $ Set.singleton studySubTermParentCandidateParent)
+ m
+
+ parentCandidates :: Map STKey (Set STKey)
+ parentCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
+
+ fixedParents :: [(STKey, STKey)]
+ fixedParents = fst $ Map.foldlWithKey' combFixed mempty parentCandidates
+ where
+ combFixed :: ([(STKey, STKey)], Set STKey) -> STKey -> Set STKey -> ([(STKey, STKey)], Set STKey)
+ combFixed (acc, bad) k s
+ | Set.member k bad
+ = (acc, bad)
+ | maybe False (`Set.notMember` s) (lookup k acc)
+ = (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
+ | [p] <- Set.elems s
+ = ((k, p) : acc, bad)
+ | otherwise = (acc, bad)
+
+ inserted <- forM fixedParents $ \(key, parent) -> do
+ unlessM (existsKey $ StudyTermsKey' key) $
+ insert_ (StudyTerms key Nothing Nothing Nothing Nothing)
+ unlessM (existsKey $ StudyTermsKey' parent) $
+ insert_ (StudyTerms parent Nothing Nothing Nothing Nothing)
+ insertUnique $ StudySubTerms
+ { studySubTermsChild = StudyTermsKey' key
+ , studySubTermsParent = StudyTermsKey' parent
+ }
+
+ mapM getJustEntity $ catMaybes inserted
+
-- | all existing StudyTerms that are contradiced by current observations
-conflicts :: DB [Entity StudyTerms]
-conflicts = E.select $ E.from $ \studyTerms -> do
+nameConflicts :: DB [Entity StudyTerms]
+nameConflicts = E.select $ E.from $ \studyTerms -> do
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
E.where_ $ E.exists $ E.from $ \candidateOne -> do
- E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
+ E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
E.where_ $ E.notExists . E.from $ \candidateTwo -> do
- E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
- E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
+ E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
+ E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+ E.||. E.exists ( E.from $ \(pCandidate `E.LeftOuterJoin` termsTwo) -> do
+ E.on $ pCandidate E.^. StudySubTermParentCandidateParent E.==. studyTerms E.^. StudyTermsKey
+ E.&&. E.just (pCandidate E.^. StudySubTermParentCandidateKey) E.==. termsTwo E.?. StudyTermsKey
+ E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+ E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName)
+ )
+ E.||. E.exists ( E.from $ \(subTerms `E.InnerJoin` termsTwo) -> do
+ E.on $ subTerms E.^. StudySubTermsParent E.==. studyTerms E.^. StudyTermsId
+ E.&&. subTerms E.^. StudySubTermsChild E.==. termsTwo E.^. StudyTermsId
+ E.where_ $ termsTwo E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+ E.||. E.isNothing (termsTwo E.^. StudyTermsName)
+ )
return studyTerms
+
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
-getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
-getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
- E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
- return $ candidate E.^. StudyTermCandidateIncidence
+getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
+getNameIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
+ E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
+ return $ candidate E.^. StudyTermNameCandidateIncidence
+ where
+ stks' = stks <&> unStudyTermsKey
diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs
index 30fc48c25..20e816c26 100644
--- a/src/Jobs/Handler/SendNotification/Allocation.hs
+++ b/src/Jobs/Handler/SendNotification/Allocation.hs
@@ -86,11 +86,10 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
let
unratedAppCount :: E.SqlExpr (E.Value Natural)
- unratedAppCount = E.sub_select . E.from $ \application -> do
+ unratedAppCount = E.subSelectCount . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
- return E.countRows
return ( course E.^. CourseTerm
, course E.^. CourseSchool
@@ -128,11 +127,10 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
let
outdatedRatingsAppCount :: E.SqlExpr (E.Value Natural)
- outdatedRatingsAppCount = E.sub_select . E.from $ \application -> do
+ outdatedRatingsAppCount = E.subSelectCount . E.from $ \application ->
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
- return E.countRows
return ( course E.^. CourseTerm
, course E.^. CourseSchool
@@ -170,13 +168,13 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
)
- let allocatedCount = E.sub_select . E.from $ \participant -> do
+ let allocatedCount :: E.SqlExpr (E.Value Int64)
+ allocatedCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
- let participantCount = E.sub_select . E.from $ \participant -> do
+ let participantCount :: E.SqlExpr (E.Value Int64)
+ participantCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
return (course, allocatedCount, participantCount)
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
diff --git a/src/Model.hs b/src/Model.hs
index 5e049e254..f59815c79 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Model
( module Model
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index f75aa2ef5..dde364c03 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
module Model.Migration
( migrateAll
, requiresMigration
@@ -585,6 +587,10 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "user" DROP COLUMN "mail_languages";
|]
)
+ , ( AppliedMigrationKey [migrationVersion|27.0.0|] [version|28.0.0|]
+ , whenM (tableExists "exam_part_corrector") $
+ tableDropEmpty "exam_part_corrector"
+ )
]
diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs
index 33685c89b..54d6d5b00 100644
--- a/src/Model/Types/Common.hs
+++ b/src/Model/Types/Common.hs
@@ -30,6 +30,7 @@ type StudyDegreeKey = Int
type StudyTermsName = Text
type StudyTermsShorthand = Text
type StudyTermsKey = Int
+type StudySubTermsKey = Int
type SchoolName = CI Text
type SchoolShorthand = CI Text
diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs
index 00b5a93e5..7cddd01b0 100644
--- a/src/Model/Types/Misc.hs
+++ b/src/Model/Types/Misc.hs
@@ -34,6 +34,7 @@ data StudyFieldType = FieldPrimary | FieldSecondary
derivePersistField "StudyFieldType"
instance Universe StudyFieldType
instance Finite StudyFieldType
+nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
data Theme
diff --git a/src/Utils.hs b/src/Utils.hs
index 65ea3be49..ddfb60acd 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -237,10 +237,6 @@ stepTextCounter text
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
--- | Ignore warnings for unused variables with a more specific type
-notUsedT :: a -> Text
-notUsedT = notUsed
-
fromText :: (IsString a, Textual t) => t -> a
fromText = fromString . unpack
@@ -732,7 +728,7 @@ choice = foldr (<|>) empty
--------------
data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
- | SessionNewStudyTerms
+ | SessionNewStudyTerms | SessionConflictingStudyTerms
| SessionBearer
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe SessionKey
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 688c3f9eb..e64bc46a7 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -49,6 +49,12 @@ _nullable = prism' toNullable fromNullable
_SchoolId :: Iso' SchoolId SchoolShorthand
_SchoolId = iso unSchoolKey SchoolKey
+_StudyTermsId :: Iso' StudyTermsId StudyTermsKey
+_StudyTermsId = iso unStudyTermsKey StudyTermsKey'
+
+_StudyDegreeId :: Iso' StudyDegreeId StudyDegreeKey
+_StudyDegreeId = iso unStudyDegreeKey StudyDegreeKey'
+
_Maybe :: Iso' (Maybe ()) Bool
_Maybe = iso (is _Just) (bool Nothing (Just ()))
@@ -83,6 +89,7 @@ makeClassyFor_ ''StudyFeatures
makeClassyFor_ ''StudyDegree
makeClassyFor_ ''StudyTerms
+makeClassyFor_ ''StudySubTerms
_entityKey :: Getter (Entity record) (Key record)
@@ -126,7 +133,6 @@ hasEntityUser = hasEntity
-- instance (HasUser a) => HasUser (Entity a) where
-- hasUser = _entityVal . hasUser
-
makeLenses_ ''SheetCorrector
makeLenses_ ''Load
@@ -143,7 +149,9 @@ makePrisms ''AuthResult
makePrisms ''FormResult
-makeLenses_ ''StudyTermCandidate
+makeLenses_ ''StudyTermNameCandidate
+makeLenses_ ''StudySubTermParentCandidate
+makeLenses_ ''StudyTermStandaloneCandidate
makeLenses_ ''FieldView
makeLenses_ ''FieldSettings
diff --git a/stack.yaml b/stack.yaml
index a5abb45dd..a1cd45876 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -39,7 +39,11 @@ extra-deps:
- directory-1.3.4.0
- HaXml-1.25.5
- - esqueleto-3.0.0
+
+ - persistent-2.10.4
+ - persistent-postgresql-2.10.1
+ - persistent-template-2.7.3
+ - esqueleto-3.2.3
- HaskellNet-SSL-0.3.4.1
- sandi-0.5
diff --git a/templates/adminFeatures.cassius b/templates/adminFeatures.cassius
new file mode 100644
index 000000000..cc48016f1
--- /dev/null
+++ b/templates/adminFeatures.cassius
@@ -0,0 +1,3 @@
+#admin-studyterms
+ select, option, input
+ min-width: 50px
\ No newline at end of file
diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet
index db3db4626..8bbf0b8b8 100644
--- a/templates/adminFeatures.hamlet
+++ b/templates/adminFeatures.hamlet
@@ -1,19 +1,40 @@
$newline never
- _{MsgStudyFeatureInferenceNoConflicts}
- $else
-
+ $if null infNameConflicts
+ _{MsgStudyFeatureInferenceNoNameConflicts}
+ $else
+
+ _{MsgStudyFeaturesDegrees}
^{degreeTable}
+ _{MsgStudyFeaturesTerms}
^{studytermsTable}
_{MsgStudyFeatureInference}
- $if null infConflicts
-
_{MsgStudyFeatureInferenceConflictsHeading}
-
- $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
-
+ _{MsgStudyFeatureNameInference}
+
_{MsgStudyFeatureInferenceNameConflictsHeading}
+
+ $forall Entity _ (StudyTerms ky _ nm _ _) <- infNameConflicts
+
+ _{MsgStudyFeaturesNameCandidates}
+ ^{candidateTable}
+
+ _{MsgStudyFeatureParentInference}
+ ^{parentsBtnForm}
-
+ _{MsgStudyFeaturesParentCandidates}
+ ^{parentCandidateTable}
+
+ _{MsgStudyFeaturesStandaloneCandidates}
+ ^{standaloneBtnForm}
+
+ ^{standaloneCandidateTable}
diff --git a/templates/course-user.hamlet b/templates/course-user.hamlet
index 2748e248b..a70589875 100644
--- a/templates/course-user.hamlet
+++ b/templates/course-user.hamlet
@@ -37,11 +37,10 @@ $newline never
_{MsgStudyFeatureAge}
_{MsgStudyFeatureValid}
_{MsgStudyFeatureUpdate}
- $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
- $with _ <- notUsedT studyFeaturesUser
+ $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
- _{field}#{notUsedT studyFeaturesField}
- _{degree}#{notUsedT studyFeaturesDegree}
+ _{field}
+ _{degree}
_{studyFeaturesType}
#{studyFeaturesSemester}
#{hasTickmark studyFeaturesValid}
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 7ef70f398..fe327abe3 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -43,11 +43,10 @@ $newline never
_{MsgStudyFeatureValid}
_{MsgStudyFeatureUpdate}
- $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
- $with _ <- notUsedT studyFeaturesUser
+ $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
_{field}#{notUsedT studyFeaturesField}
- _{degree}#{notUsedT studyFeaturesDegree}
+ _{field}
+ _{degree}
_{studyFeaturesType}
#{studyFeaturesSemester}
#{hasTickmark studyFeaturesValid}
diff --git a/test/Database.hs b/test/Database.hs
index 0de2da726..1ab81bb3b 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -317,87 +317,88 @@ fillDb = do
sdChem2 = StudyTermsKey' 113
sdBWL = StudyTermsKey' 21
sdDeut = StudyTermsKey' 103
- repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk")
- repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")
- repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier")
- repsert sdPhys $ StudyTerms 128 Nothing Nothing -- intentionally left unknown
- repsert sdBioI1 $ StudyTerms 221 Nothing Nothing -- intentionally left unknown
- repsert sdBioI2 $ StudyTerms 228 Nothing Nothing -- intentionally left unknown
- repsert sdBiol $ StudyTerms 26 Nothing Nothing -- intentionally left unknown
- repsert sdChem1 $ StudyTerms 61 Nothing Nothing -- intentionally left unknown
- repsert sdChem2 $ StudyTerms 113 Nothing Nothing -- intentionally left unknown
- repsert sdBWL $ StudyTerms 21 Nothing Nothing -- intentionally left unknown
- repsert sdDeut $ StudyTerms 103 Nothing Nothing -- intentionally left unknown
+ repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk") Nothing Nothing
+ repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik") Nothing Nothing
+ repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier") Nothing Nothing
+ repsert sdPhys $ StudyTerms 128 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdBioI1 $ StudyTerms 221 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdBioI2 $ StudyTerms 228 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdBiol $ StudyTerms 26 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdChem1 $ StudyTerms 61 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdChem2 $ StudyTerms 113 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdBWL $ StudyTerms 21 Nothing Nothing Nothing Nothing -- intentionally left unknown
+ repsert sdDeut $ StudyTerms 103 Nothing Nothing Nothing Nothing -- intentionally left unknown
incidence1 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence1 221 "Mathematik"
- void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence1 105 "Mathematik"
+ void . insert $ StudyTermNameCandidate incidence1 221 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence1 221 "Mathematik"
+ void . insert $ StudyTermNameCandidate incidence1 105 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence1 105 "Mathematik"
incidence2 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence2 221 "Chemie"
- void . insert $ StudyTermCandidate incidence2 61 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence2 61 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence2 221 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence2 221 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence2 61 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence2 61 "Chemie"
incidence3 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence3 113 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence3 113 "Chemie"
incidence4 <- liftIO getRandom -- ambiguous incidence
- void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence4 221 "Chemie"
- void . insert $ StudyTermCandidate incidence4 221 "Biologie"
- void . insert $ StudyTermCandidate incidence4 61 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence4 61 "Chemie"
- void . insert $ StudyTermCandidate incidence4 61 "Biologie"
- void . insert $ StudyTermCandidate incidence4 61 "Chemie"
- void . insert $ StudyTermCandidate incidence4 26 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence4 26 "Chemie"
- void . insert $ StudyTermCandidate incidence4 26 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence4 221 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence4 221 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence4 221 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence4 61 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence4 61 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence4 61 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence4 61 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence4 26 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence4 26 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence4 26 "Biologie"
incidence5 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence5 228 "Physik"
- void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence5 128 "Physik"
+ void . insert $ StudyTermNameCandidate incidence5 228 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence5 228 "Physik"
+ void . insert $ StudyTermNameCandidate incidence5 128 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence5 128 "Physik"
incidence6 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence6 228 "Physik"
- void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence6 128 "Physik"
+ void . insert $ StudyTermNameCandidate incidence6 228 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence6 228 "Physik"
+ void . insert $ StudyTermNameCandidate incidence6 128 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence6 128 "Physik"
incidence7 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence7 228 "Physik"
- void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence7 128 "Physik"
- void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence7 228 "Physik"
+ void . insert $ StudyTermNameCandidate incidence7 228 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence7 128 "Physik"
+ void . insert $ StudyTermNameCandidate incidence7 128 "Bioinformatik"
incidence8 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence8 128 "Physik"
- void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik"
- void . insert $ StudyTermCandidate incidence8 121 "Physik"
- void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik"
+ void . insert $ StudyTermNameCandidate incidence8 128 "Physik"
+ void . insert $ StudyTermNameCandidate incidence8 128 "Medieninformatik"
+ void . insert $ StudyTermNameCandidate incidence8 121 "Physik"
+ void . insert $ StudyTermNameCandidate incidence8 121 "Medieninformatik"
incidence9 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence9 79 "Informatik"
+ void . insert $ StudyTermNameCandidate incidence9 79 "Informatik"
incidence10 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence10 103 "Deutsch"
- void . insert $ StudyTermCandidate incidence10 103 "Betriebswirtschaftslehre"
- void . insert $ StudyTermCandidate incidence10 21 "Deutsch"
- void . insert $ StudyTermCandidate incidence10 21 "Betriebswirtschaftslehre"
+ void . insert $ StudyTermNameCandidate incidence10 103 "Deutsch"
+ void . insert $ StudyTermNameCandidate incidence10 103 "Betriebswirtschaftslehre"
+ void . insert $ StudyTermNameCandidate incidence10 21 "Deutsch"
+ void . insert $ StudyTermNameCandidate incidence10 21 "Betriebswirtschaftslehre"
incidence11 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence11 221 "Chemie"
- void . insert $ StudyTermCandidate incidence11 221 "Biologie"
- void . insert $ StudyTermCandidate incidence11 61 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence11 61 "Chemie"
- void . insert $ StudyTermCandidate incidence11 61 "Biologie"
- void . insert $ StudyTermCandidate incidence11 26 "Bioinformatik"
- void . insert $ StudyTermCandidate incidence11 26 "Chemie"
- void . insert $ StudyTermCandidate incidence11 26 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence11 221 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence11 221 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence11 221 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence11 61 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence11 61 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence11 61 "Biologie"
+ void . insert $ StudyTermNameCandidate incidence11 26 "Bioinformatik"
+ void . insert $ StudyTermNameCandidate incidence11 26 "Chemie"
+ void . insert $ StudyTermNameCandidate incidence11 26 "Biologie"
incidence12 <- liftIO getRandom
- void . insert $ StudyTermCandidate incidence12 103 "Deutsch"
- void . insert $ StudyTermCandidate incidence12 103 "Betriebswirtschaftslehre"
- void . insert $ StudyTermCandidate incidence12 21 "Deutsch"
- void . insert $ StudyTermCandidate incidence12 21 "Betriebswirtschaftslehre"
+ void . insert $ StudyTermNameCandidate incidence12 103 "Deutsch"
+ void . insert $ StudyTermNameCandidate incidence12 103 "Betriebswirtschaftslehre"
+ void . insert $ StudyTermNameCandidate incidence12 21 "Deutsch"
+ void . insert $ StudyTermNameCandidate incidence12 21 "Betriebswirtschaftslehre"
sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
maxMuster
sdBsc
sdInf
+ Nothing
FieldPrimary
2
now
@@ -406,6 +407,7 @@ fillDb = do
maxMuster
sdBsc
sdMath
+ Nothing
FieldSecondary
2
now
@@ -414,6 +416,7 @@ fillDb = do
tinaTester
sdBsc
sdInf
+ Nothing
FieldPrimary
4
now
@@ -422,6 +425,7 @@ fillDb = do
tinaTester
sdLAG
sdPhys
+ Nothing
FieldPrimary
1
now
@@ -430,6 +434,7 @@ fillDb = do
tinaTester
sdLAR
sdMedi
+ Nothing
FieldPrimary
7
now
@@ -438,6 +443,7 @@ fillDb = do
tinaTester
sdMst
sdMath
+ Nothing
FieldPrimary
3
now