- #{tshow res} - |] - - -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'}
- |]
-
-
--- 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..99b657f99
--- /dev/null
+++ b/src/Handler/Admin/StudyFeatures.hs
@@ -0,0 +1,315 @@
+{-# 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 qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter, sqlFOJproj)
+
+import qualified Handler.Utils.TermCandidates as Candidates
+
+import qualified Data.Maybe as Maybe
+
+
+-- BEGIN - Buttons needed only for StudyTermNameCandidateManagement
+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 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 (bimap entityKey entityKey <$> confs)
+ deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
+ addMessageI Success $ MsgIncidencesDeleted $ length incis
+ return []
+ FormSuccess BtnCandidatesDeleteAll -> runDB $ do
+ deleteWhere ([] :: [Filter StudyTermNameCandidate])
+ 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 (bimap entityKey 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 (Either StudySubTermsId StudyTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
+ studyTermsResult' = studyTermsResult <&> Map.mapKeys (\(mbL, mbR) -> Maybe.fromJust $ fmap Left mbR <|> fmap Right mbL) . getDBFormResult
+ (\row -> ( row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsName . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName . _Just)
+ , row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand . _Just)
+ , row ^. _dbrOutput . _3
+ , row ^? _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just
+ , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
+ , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just
+ ))
+ updateStudyTerms (Right studyTermsKey) (name,short,schools,_parent,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]
+ updateStudyTerms (Left studySubTermsKey) (name,short,_schools,parent,_degree,_type) = do
+ parentExists <- fmap (fromMaybe False) . for parent $ fmap (is _Just) . get
+ update studySubTermsKey [StudySubTermsName =. name, StudySubTermsShorthand =. short, StudySubTermsParent =. guard parentExists *> parent]
+ 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 & 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)
+ )
+
+ 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 (intField & isoField (from _StudyDegreeId)) "" (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 Int -> Set (Either StudySubTermsId StudyTermsId) -> Set (Entity School) -> DB (FormResult (DBFormResult (Maybe StudyTermsId, Maybe StudySubTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId))), Widget)
+ mkStudytermsTable newKeys badKeys' schools =
+ let dbtIdent = "admin-studyterms" :: Text
+ dbtStyle = def
+ dbtSQLQuery :: E.SqlExpr (Maybe (Entity StudyTerms)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity StudySubTerms)) -> E.SqlQuery (E.SqlExpr (Maybe (Entity StudyTerms)), E.SqlExpr (Maybe (Entity StudySubTerms)))
+ dbtSQLQuery (studyTerms `E.FullOuterJoin` studySubTerms) = do
+ E.on $ studyTerms E.?. StudyTermsKey E.==. studySubTerms E.?. StudySubTermsKey
+ return (studyTerms, studySubTerms)
+ dbtRowKey (studyTerms `E.FullOuterJoin` studySubTerms) = (studyTerms E.?. StudyTermsKey, studySubTerms E.?. StudySubTermsKey)
+ dbtProj field = do
+ fieldSchools <- for (field ^. _dbrOutput . _1) $ \field' -> 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' ^. _entityKey)
+ E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
+ return $ school E.^. SchoolId
+ return $ field & _dbrOutput %~ (\(field', subField) -> (field', subField, fromMaybe Set.empty fieldSchools))
+ dbtColonnade = formColonnade $ mconcat
+ [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey))
+ , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (termKeyCell _4 (pre $ _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just) _dbrKey')
+ , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (maybe mempty (isNewCell . flip Set.member newKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey))
+ , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (maybe mempty (isBadCell . flip Set.member badKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey))
+ , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsName <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName) _dbrKey')
+ , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand) _dbrKey')
+ , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just) _dbrKey')
+ , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just) _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 $ \t -> E.maybe (querySubField t E.?. StudySubTermsKey) E.just $ queryField t E.?. StudyTermsKey)
+ , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
+ , ("isnew" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys)
+ E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys)
+ )
+ , ("isbad" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys)
+ E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys)
+ )
+ , ("name" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsName) E.just . E.joinV $ queryField t E.?. StudyTermsName)
+ , ("short" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsShorthand) E.just . E.joinV $ queryField t E.?. StudyTermsShorthand)
+ , ("degree" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultDegree)
+ , ("field-type" , SortColumn $ \t -> queryField t 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 = $(sqlFOJproj 2 1)
+ querySubField = $(sqlFOJproj 2 2)
+ _dbrKey' :: Getter (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId))
+ (Maybe StudyTermsId, Maybe StudySubTermsId)
+ _dbrKey' = $(multifocusL 2) (_dbrOutput . _1 . applying (_Entity . _1)) (_dbrOutput . _2 . applying (_Entity . _1))
+
+ badKeys = Set.map (either unStudySubTermsKey unStudyTermsKey) badKeys'
+ 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{..}
+
diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs
new file mode 100644
index 000000000..7acf3a7ea
--- /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
+ <$> (MailLanguages <$> 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 (minIntField n "Zahl") (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/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index c3662286a..62599a9c7 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 (StudySubTermsId, 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 (StudySubTermsId, Int)
+pLMUTermsSemester = do
+ subTermsKey <- StudySubTermsKey' <$> pKey
+ void $ char '$'
+ semester <- decimal
+
+ return (subTermsKey, semester)
diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs
index c986ed61b..e31338dac 100644
--- a/src/Handler/Utils/TermCandidates.hs
+++ b/src/Handler/Utils/TermCandidates.hs
@@ -25,13 +25,13 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E
--- import Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils 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]
+data FailedCandidateInference = FailedCandidateInference [Either (Entity StudySubTerms) (Entity StudyTerms)]
deriving (Typeable, Show)
instance Exception FailedCandidateInference
@@ -46,7 +46,7 @@ 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 :: Handler ([Either (Entity StudySubTerms) (Entity StudyTerms)],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(STKey,Text)])
inferHandler = runDB $ inferAcc ([],[],[])
where
inferAcc (accAmbiguous, accRedundants, accAccepted) =
@@ -90,32 +90,37 @@ as a fix we simply eliminate all observations that have the same name twice, see
removeAmbiguous :: DB [TermCandidateIncidence]
removeAmbiguous = 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 :: DB [Entity StudyTermNameCandidate]
removeRedundant = 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
+ redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` (sterm `E.FullOuterJoin` ssubterm)) -> do
+ E.on E.true
+ E.on $ ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey
+ E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName)
+ )
+ E.||. ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. ssubterm E.?. StudySubTermsKey
+ E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (ssubterm E.?. StudySubTermsName)
+ )
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
@@ -127,9 +132,10 @@ removeRedundant = do
acceptSingletons :: DB [(STKey,Text)]
acceptSingletons = do
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
+ knownSubKeys <- fmap unStudySubTermsKey <$> selectKeysList [StudySubTermsName !=. Nothing] [Asc StudySubTermsKey]
-- 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 ++ knownSubKeys] [] -- 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 +145,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
@@ -162,7 +168,13 @@ acceptSingletons = do
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
registerFixed :: (STKey, Text) -> DB ()
- registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
+ registerFixed (key, name) = do
+ isSub <- is _Just <$> get (StudySubTermsKey' key)
+ if
+ | isSub
+ -> repsert (StudySubTermsKey' key) $ StudySubTerms key Nothing Nothing (Just name)
+ | otherwise
+ -> repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
-- register newly fixed candidates
forM_ fixedKeys registerFixed
@@ -170,18 +182,31 @@ acceptSingletons = do
-- | all existing StudyTerms that are contradiced by current observations
-conflicts :: DB [Entity StudyTerms]
-conflicts = 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_ $ 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)
- return studyTerms
+conflicts :: DB [Either (Entity StudySubTerms) (Entity StudyTerms)]
+conflicts = (++) <$> fmap (map Left) conflictingSubTerms <*> fmap (map Right) conflictingTerms
+ where
+ conflictingTerms = 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.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
+ E.where_ $ E.notExists . E.from $ \candidateTwo -> do
+ E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
+ E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+ return studyTerms
+ conflictingSubTerms = E.select $ E.from $ \studySubTerms -> do
+ E.where_ $ E.not_ $ E.isNothing $ studySubTerms E.^. StudySubTermsName
+ E.where_ $ E.exists $ E.from $ \candidateOne -> do
+ E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studySubTerms E.^. StudySubTermsKey
+ E.where_ $ E.notExists . E.from $ \candidateTwo -> do
+ E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
+ E.where_ $ studySubTerms E.^. StudySubTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+ return studySubTerms
+
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
-getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
+getIncidencesFor :: [Either (Key StudySubTerms) (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
+ E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
+ return $ candidate E.^. StudyTermNameCandidateIncidence
+ where
+ stks' = stks <&> either unStudySubTermsKey unStudyTermsKey
diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs
index 50048eb42..2bd257a0b 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..d1e1373e1 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
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 4ed056e10..483a205d8 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,7 @@ makePrisms ''AuthResult
makePrisms ''FormResult
-makeLenses_ ''StudyTermCandidate
+makeLenses_ ''StudyTermNameCandidate
makeLenses_ ''FieldView
makeLenses_ ''FieldSettings
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 ea5e214b6..75d87ae7c 100644
--- a/templates/adminFeatures.hamlet
+++ b/templates/adminFeatures.hamlet
@@ -1,3 +1,4 @@
+$newline never
Studiengangseingträge mit beobachteten Konflikten:
- $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
-
_{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 d35a0b82c..540016b6d 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -42,11 +42,10 @@
_{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}