feat(features-of-study): record parent & standalone candidates
This commit is contained in:
Gregor Kleen
parent
46096dc35f
commit
2621d36b7d
@ -1987,3 +1987,7 @@ ShortSexNotApplicable: k.A.
|
||||
|
||||
ShowSex: Geschlechter anderer Nutzer anzeigen
|
||||
ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
|
||||
|
||||
StudySubTermsParentKey: Elter
|
||||
StudyTermsDefaultDegree: Abschluss
|
||||
StudyTermsDefaultFieldType: Typ
|
||||
@ -55,11 +55,13 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
|
||||
user UserId
|
||||
degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.
|
||||
field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc.
|
||||
subField StudySubTermsId Maybe
|
||||
type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach
|
||||
semester Int
|
||||
updated UTCTime default=now() -- last update from LDAP
|
||||
valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets)
|
||||
UniqueStudyFeatures user degree field type semester
|
||||
deriving Eq
|
||||
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
|
||||
StudyDegree -- Studienabschluss
|
||||
key Int -- LMU-internal key
|
||||
@ -69,17 +71,35 @@ StudyDegree -- Studienabschluss
|
||||
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
|
||||
deriving Show
|
||||
StudyTerms -- Studiengang
|
||||
key Int -- LMU-internal key
|
||||
key Int -- standardised key
|
||||
shorthand Text Maybe -- admin determined shorthand
|
||||
name Text Maybe -- description given by LDAP
|
||||
defaultDegree StudyDegreeId Maybe
|
||||
defaultType StudyFieldType Maybe
|
||||
Primary key -- column key is used as actual DB row key
|
||||
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
|
||||
deriving Show
|
||||
StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
|
||||
StudySubTerms
|
||||
key Int
|
||||
parent StudyTermsId Maybe
|
||||
shorthand Text Maybe
|
||||
name Text Maybe
|
||||
Primary key
|
||||
deriving Show
|
||||
StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
|
||||
-- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
|
||||
-- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
|
||||
-- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
|
||||
incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs
|
||||
key Int -- a possible key for the studyTermName
|
||||
key Int -- a possible key for the studyTermName or studySubTermName
|
||||
name Text -- studyTermName as plain text from LDAP
|
||||
deriving Show Eq Ord
|
||||
StudySubTermParentCandidate
|
||||
incidence TermCandidateIncidence
|
||||
key Int
|
||||
parent Int
|
||||
deriving Show Eq Ord
|
||||
StudyTermStandaloneCandidate
|
||||
incidence TermCandidateIncidence
|
||||
key Int
|
||||
deriving Show Eq Ord
|
||||
@ -7,7 +7,7 @@ module Auth.LDAP
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
||||
, ldapUserSchoolAssociation, ldapSex
|
||||
, ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -61,7 +61,7 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex :: Ldap.Attr
|
||||
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
@ -69,9 +69,10 @@ ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
ldapSex = Ldap.Attr "schacGender"
|
||||
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||
|
||||
ldapUserEmail :: NonEmpty Ldap.Attr
|
||||
ldapUserEmail = Ldap.Attr "mail" :|
|
||||
|
||||
@ -2,7 +2,7 @@ module Database.Esqueleto.Utils.TH
|
||||
( SqlIn(..)
|
||||
, sqlInTuple, sqlInTuples
|
||||
, unValueN, unValueNIs
|
||||
, sqlIJproj, sqlLOJproj
|
||||
, sqlIJproj, sqlLOJproj, sqlFOJproj
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -84,3 +84,6 @@ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
|
||||
|
||||
sqlLOJproj :: Int -> Int -> ExpQ
|
||||
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
|
||||
|
||||
sqlFOJproj :: Int -> Int -> ExpQ
|
||||
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
|
||||
|
||||
@ -44,6 +44,7 @@ import qualified Data.Map as Map
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.List (nubBy, (!!), findIndex)
|
||||
import qualified Data.List as List
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
@ -3504,36 +3505,98 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||
userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
|
||||
userSubTermsSemesters' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSubTermsSemester
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||
sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
name <- termNames
|
||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
||||
return (key, name)
|
||||
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
|
||||
subTermsKeys = unStudySubTermsKey . fst <$> sts
|
||||
|
||||
(,) <$> sfKeys ++ subTermsKeys <*> termNames
|
||||
|
||||
let
|
||||
assimilateSubTerms :: [(StudySubTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudySubTermsKey, Maybe StudyTermsId)) DB [StudyFeatures]
|
||||
assimilateSubTerms [] xs = return xs
|
||||
assimilateSubTerms ((subterm'@(StudySubTermsKey' subterm), subSemester) : subterms) unusedFeats = do
|
||||
standalone <- lift . get $ StudyTermsKey' subterm
|
||||
case standalone of
|
||||
_other
|
||||
| (_ : matches, unusedFeats') <- partition (\StudyFeatures{..} -> subterm == unStudyTermsKey studyFeaturesField
|
||||
&& subSemester == studyFeaturesSemester
|
||||
) unusedFeats
|
||||
-> assimilateSubTerms subterms $ unusedFeats' ++ matches
|
||||
| any ((== subterm) . unStudyTermsKey . studyFeaturesField) unusedFeats
|
||||
-> assimilateSubTerms subterms unusedFeats
|
||||
Just StudyTerms{..}
|
||||
| Just defDegree <- studyTermsDefaultDegree
|
||||
, Just defType <- studyTermsDefaultType
|
||||
-> (:) (StudyFeatures userId defDegree (StudyTermsKey' subterm) Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
|
||||
Nothing
|
||||
| [] <- unusedFeats -> do
|
||||
tell $ Set.singleton (subterm, Nothing)
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
_other -> do
|
||||
knownParent <- lift $ (>>= studySubTermsParent) <$> get subterm'
|
||||
let matchingFeatures = case knownParent of
|
||||
Just p -> filter ((== p) . studyFeaturesField) unusedFeats
|
||||
Nothing -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||
unless (is _Just knownParent) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||
if
|
||||
| is _Just knownParent
|
||||
-> (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm')) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
|
||||
| otherwise
|
||||
-> assimilateSubTerms subterms unusedFeats
|
||||
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
||||
|
||||
let
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runConduitPure
|
||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash
|
||||
$ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
|
||||
|
||||
candidatesRecorded <- E.selectExists . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
||||
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate) -> do
|
||||
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
|
||||
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
||||
return StudyTermCandidate{..}
|
||||
(studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
|
||||
let studyTermNameCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermNameCandidate{..}
|
||||
insertMany_ studyTermCandidates'
|
||||
|
||||
let
|
||||
studySubTermParentCandidates' = do
|
||||
(studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
|
||||
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudySubTermParentCandidate{..}
|
||||
studyTermStandaloneCandidates' = do
|
||||
(studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
|
||||
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermStandaloneCandidate{..}
|
||||
insertMany_ studySubTermParentCandidates'
|
||||
insertMany_ studyTermStandaloneCandidates'
|
||||
|
||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True, StudyFeaturesSubField =. studyFeaturesSubField]
|
||||
associateUserSchoolsByTerms userId
|
||||
|
||||
let
|
||||
|
||||
@ -1,36 +1,16 @@
|
||||
module Handler.Admin where
|
||||
module Handler.Admin
|
||||
( module Handler.Admin
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Jobs
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Writer (mapWriterT)
|
||||
|
||||
-- import Data.Time
|
||||
import Data.Char (isDigit)
|
||||
import qualified Data.Text as Text
|
||||
-- import Data.Function ((&))
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Database.Persist.Sql (fromSqlKey)
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
||||
|
||||
import qualified Handler.Utils.TermCandidates as Candidates
|
||||
|
||||
-- import Colonnade hiding (fromMaybe)
|
||||
-- import Yesod.Colonnade
|
||||
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
import Handler.Admin.StudyFeatures as Handler.Admin
|
||||
|
||||
|
||||
getAdminR :: Handler Html
|
||||
getAdminR = -- do
|
||||
getAdminR =
|
||||
siteLayoutMsg MsgAdminHeading $ do
|
||||
setTitleI MsgAdminHeading
|
||||
[whamlet|
|
||||
@ -38,472 +18,3 @@ getAdminR = -- do
|
||||
Its current purpose is to provide links to some important admin functions
|
||||
|]
|
||||
|
||||
-- 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|Ma<i>thema</i>tik|]
|
||||
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:
|
||||
<ul>
|
||||
<li>#{show i}
|
||||
<li>#{show b}
|
||||
<li>#{show d}
|
||||
$nothing
|
||||
No form values received, due to #
|
||||
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
||||
$case demoResult
|
||||
$of FormSuccess _
|
||||
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
||||
success, which should not happen here.
|
||||
$of FormMissing
|
||||
Form data missing, probably empty.
|
||||
$of FormFailure msgs
|
||||
<ul>
|
||||
$forall m <- msgs
|
||||
<li>#{m}
|
||||
|]
|
||||
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
|
||||
|
||||
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
|
||||
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
|
||||
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
|
||||
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
|
||||
|
||||
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
|
||||
|
||||
{- The following demonstrates the use of @massInput@.
|
||||
|
||||
@massInput@ takes as arguments:
|
||||
- A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
|
||||
- Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
|
||||
- An initial value to pre-fill the field with
|
||||
|
||||
@massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
|
||||
-}
|
||||
let
|
||||
-- We define the fields of the configuration struct @MassInput@:
|
||||
|
||||
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
||||
--
|
||||
-- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
||||
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
||||
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
|
||||
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
|
||||
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
|
||||
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
|
||||
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
|
||||
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
|
||||
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
|
||||
|
||||
-- | Make a single massInput-Cell
|
||||
--
|
||||
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
|
||||
mkCellForm :: ListPosition -- ^ Position of this cell
|
||||
-> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
|
||||
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
|
||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||
-> Form Int
|
||||
mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
|
||||
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
||||
return (intRes, toWidget csrf >> fvInput intView)
|
||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
||||
deleteCell = miDeleteList
|
||||
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
||||
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
||||
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
|
||||
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
|
||||
|
||||
-- The actual call to @massInput@ is comparatively simple:
|
||||
|
||||
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
||||
|
||||
|
||||
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
||||
siteLayout locallyDefinedPageHeading $ do
|
||||
-- defaultLayout $ do
|
||||
setTitle "Uni2work Admin Testpage"
|
||||
$(widgetFile "adminTest")
|
||||
|
||||
[whamlet|<h2>Formular Demonstration|]
|
||||
wrapForm formWidget FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
|
||||
, formEncoding = formEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just FIDAdminDemo
|
||||
}
|
||||
showDemoResult
|
||||
|
||||
miIdent <- newIdent
|
||||
let miForm' = wrapForm miForm FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AdminTestR :#: miIdent
|
||||
, formEncoding = miEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just miIdent
|
||||
}
|
||||
[whamlet|
|
||||
<h2>Mass-Input
|
||||
^{miForm'}
|
||||
$case miResult
|
||||
$of FormMissing
|
||||
$of FormFailure errs
|
||||
<ul>
|
||||
$forall err <- errs
|
||||
<li>#{err}
|
||||
$of FormSuccess res
|
||||
<p style="white-space:pre-wrap; font-family:monospace;">
|
||||
#{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
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
$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{..}
|
||||
|
||||
|
||||
32
src/Handler/Admin/ErrorMessage.hs
Normal file
32
src/Handler/Admin/ErrorMessage.hs
Normal file
@ -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
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
$case t
|
||||
$of String t'
|
||||
#{t'}
|
||||
$of t'
|
||||
#{encodePrettyToTextBuilder t'}
|
||||
|
||||
^{ctView'}
|
||||
|]
|
||||
315
src/Handler/Admin/StudyFeatures.hs
Normal file
315
src/Handler/Admin/StudyFeatures.hs
Normal file
@ -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{..}
|
||||
|
||||
231
src/Handler/Admin/Test.hs
Normal file
231
src/Handler/Admin/Test.hs
Normal file
@ -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|Ma<i>thema</i>tik|]
|
||||
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:
|
||||
<ul>
|
||||
<li>#{show i}
|
||||
<li>#{show b}
|
||||
<li>#{show d}
|
||||
$nothing
|
||||
No form values received, due to #
|
||||
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
||||
$case demoResult
|
||||
$of FormSuccess _
|
||||
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
||||
success, which should not happen here.
|
||||
$of FormMissing
|
||||
Form data missing, probably empty.
|
||||
$of FormFailure msgs
|
||||
<ul>
|
||||
$forall m <- msgs
|
||||
<li>#{m}
|
||||
|]
|
||||
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
|
||||
|
||||
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
|
||||
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
|
||||
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
|
||||
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
|
||||
|
||||
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
|
||||
|
||||
{- The following demonstrates the use of @massInput@.
|
||||
|
||||
@massInput@ takes as arguments:
|
||||
- A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
|
||||
- Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
|
||||
- An initial value to pre-fill the field with
|
||||
|
||||
@massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
|
||||
-}
|
||||
let
|
||||
-- We define the fields of the configuration struct @MassInput@:
|
||||
|
||||
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
||||
--
|
||||
-- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
||||
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
||||
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
|
||||
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
|
||||
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
|
||||
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
|
||||
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
|
||||
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
|
||||
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
|
||||
|
||||
-- | Make a single massInput-Cell
|
||||
--
|
||||
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
|
||||
mkCellForm :: ListPosition -- ^ Position of this cell
|
||||
-> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
|
||||
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
|
||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||
-> Form Int
|
||||
mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
|
||||
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
||||
return (intRes, toWidget csrf >> fvInput intView)
|
||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
||||
deleteCell = miDeleteList
|
||||
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
||||
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
||||
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
|
||||
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
|
||||
|
||||
-- The actual call to @massInput@ is comparatively simple:
|
||||
|
||||
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
||||
|
||||
|
||||
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
||||
siteLayout locallyDefinedPageHeading $ do
|
||||
-- defaultLayout $ do
|
||||
setTitle "Uni2work Admin Testpage"
|
||||
$(widgetFile "adminTest")
|
||||
|
||||
[whamlet|<h2>Formular Demonstration|]
|
||||
wrapForm formWidget FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
|
||||
, formEncoding = formEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just FIDAdminDemo
|
||||
}
|
||||
showDemoResult
|
||||
|
||||
miIdent <- newIdent
|
||||
let miForm' = wrapForm miForm FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ AdminTestR :#: miIdent
|
||||
, formEncoding = miEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just miIdent
|
||||
}
|
||||
[whamlet|
|
||||
<h2>Mass-Input
|
||||
^{miForm'}
|
||||
$case miResult
|
||||
$of FormMissing
|
||||
$of FormFailure errs
|
||||
<ul>
|
||||
$forall err <- errs
|
||||
<li>#{err}
|
||||
$of FormSuccess res
|
||||
<p style="white-space:pre-wrap; font-family:monospace;">
|
||||
#{tshow res}
|
||||
|]
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -34,6 +34,7 @@ data StudyFieldType = FieldPrimary | FieldSecondary
|
||||
derivePersistField "StudyFieldType"
|
||||
instance Universe StudyFieldType
|
||||
instance Finite StudyFieldType
|
||||
nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
|
||||
|
||||
|
||||
data Theme
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
3
templates/adminFeatures.cassius
Normal file
3
templates/adminFeatures.cassius
Normal file
@ -0,0 +1,3 @@
|
||||
#admin-studyterms
|
||||
select, option, input
|
||||
min-width: 50px
|
||||
@ -1,3 +1,4 @@
|
||||
$newline never
|
||||
<section>
|
||||
^{degreeTable}
|
||||
<section>
|
||||
@ -10,8 +11,13 @@
|
||||
$else
|
||||
<h3>Studiengangseingträge mit beobachteten Konflikten:
|
||||
<ul>
|
||||
$forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
|
||||
<li> #{show ky} - #{foldMap id nm}
|
||||
$forall conflict <- infConflicts
|
||||
<li>
|
||||
$case conflict
|
||||
$of Right (Entity _ (StudyTerms ky _ nm _ _))
|
||||
#{show ky} - #{foldMap id nm}
|
||||
$of Left (Entity _ (StudySubTerms ky _ _ nm))
|
||||
#{show ky} - #{foldMap id nm}
|
||||
^{btnForm}
|
||||
|
||||
<div .container>
|
||||
|
||||
@ -37,11 +37,10 @@ $newline never
|
||||
<th .table__th>_{MsgStudyFeatureAge}
|
||||
<th .table__th>_{MsgStudyFeatureValid}
|
||||
<th .table__th>_{MsgStudyFeatureUpdate}
|
||||
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
|
||||
$with _ <- notUsedT studyFeaturesUser
|
||||
$forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
|
||||
<tr .table__row>
|
||||
<td .table__td>_{field}#{notUsedT studyFeaturesField}
|
||||
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
|
||||
<td .table__td>_{field}
|
||||
<td .table__td>_{degree}
|
||||
<td .table__td>_{studyFeaturesType}
|
||||
<td .table__td>#{studyFeaturesSemester}
|
||||
<td .table__td>#{hasTickmark studyFeaturesValid}
|
||||
|
||||
@ -42,11 +42,10 @@
|
||||
<th .table__th>_{MsgStudyFeatureValid}
|
||||
<th .table__th>_{MsgStudyFeatureUpdate}
|
||||
|
||||
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
|
||||
$with _ <- notUsedT studyFeaturesUser
|
||||
$forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
|
||||
<tr.table__row>
|
||||
<td .table__td>_{field}#{notUsedT studyFeaturesField}
|
||||
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
|
||||
<td .table__td>_{field}
|
||||
<td .table__td>_{degree}
|
||||
<td .table__td>_{studyFeaturesType}
|
||||
<td .table__td>#{studyFeaturesSemester}
|
||||
<td .table__td>#{hasTickmark studyFeaturesValid}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user