530 lines
30 KiB
Haskell
530 lines
30 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Admin.StudyFeatures
|
|
( getAdminFeaturesR, postAdminFeaturesR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
|
|
|
import qualified Handler.Utils.TermCandidates as Candidates
|
|
|
|
|
|
data ButtonAdminStudyTermsNames
|
|
= BtnNameCandidatesInfer
|
|
| BtnNameCandidatesDeleteConflicts
|
|
| BtnNameCandidatesDeleteAll
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonAdminStudyTermsNames
|
|
instance Finite ButtonAdminStudyTermsNames
|
|
|
|
nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
|
|
|
|
instance Button UniWorX ButtonAdminStudyTermsNames where
|
|
btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary]
|
|
btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
|
|
btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger]
|
|
|
|
data ButtonAdminStudyTermsParents
|
|
= BtnParentCandidatesInfer
|
|
| BtnParentCandidatesDeleteAll
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonAdminStudyTermsParents
|
|
instance Finite ButtonAdminStudyTermsParents
|
|
|
|
nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
|
|
|
|
instance Button UniWorX ButtonAdminStudyTermsParents where
|
|
btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
|
|
btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
|
|
|
|
data ButtonAdminStudyTermsStandalone
|
|
= BtnStandaloneCandidatesDeleteRedundant
|
|
| BtnStandaloneCandidatesDeleteAll
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonAdminStudyTermsStandalone
|
|
instance Finite ButtonAdminStudyTermsStandalone
|
|
|
|
nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id
|
|
|
|
instance Button UniWorX ButtonAdminStudyTermsStandalone where
|
|
btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
|
|
btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
|
|
|
|
|
|
{-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-}
|
|
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
|
getAdminFeaturesR = postAdminFeaturesR
|
|
postAdminFeaturesR = do
|
|
uid <- requireAuthId
|
|
((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
|
|
let nameBtnForm = wrapForm nameBtnWdgt def
|
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
|
, formEncoding = nameBtnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
infNameConflicts <- case nameBtnResult of
|
|
FormSuccess BtnNameCandidatesInfer -> do
|
|
(infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
|
|
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
|
|
unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
|
|
unless (null infConflicts) $ do
|
|
let badKeys = map entityKey infConflicts
|
|
setSessionJson SessionConflictingStudyTerms badKeys
|
|
addMessageI Warning MsgStudyFeatureConflict
|
|
|
|
let newKeys = map fst infAccepted
|
|
setSessionJson SessionNewStudyTerms newKeys
|
|
|
|
if | null infAccepted
|
|
-> addMessageI Info MsgNoNameCandidatesInferred
|
|
| otherwise
|
|
-> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
|
|
redirect AdminFeaturesR
|
|
FormSuccess BtnNameCandidatesDeleteConflicts -> do
|
|
runDB $ do
|
|
confs <- Candidates.nameConflicts
|
|
incis <- Candidates.getNameIncidencesFor $ map entityKey confs
|
|
deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
|
|
addMessageI Success $ MsgIncidencesDeleted $ length incis
|
|
redirect AdminFeaturesR
|
|
FormSuccess BtnNameCandidatesDeleteAll -> do
|
|
runDB $ do
|
|
deleteWhere ([] :: [Filter StudyTermNameCandidate])
|
|
addMessageI Success MsgAllNameIncidencesDeleted
|
|
redirect AdminFeaturesR
|
|
_other -> runDB Candidates.nameConflicts
|
|
|
|
((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
|
|
let parentsBtnForm = wrapForm parentsBtnWdgt def
|
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
|
, formEncoding = parentsBtnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
formResult parentsBtnResult $ \case
|
|
BtnParentCandidatesInfer -> do
|
|
(infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
|
|
unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
|
|
|
|
let newKeys = map (studySubTermsChild . entityVal) infAccepted
|
|
setSessionJson SessionNewStudyTerms newKeys
|
|
|
|
if | null infAccepted
|
|
-> addMessageI Info MsgNoParentCandidatesInferred
|
|
| otherwise
|
|
-> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
|
|
redirect AdminFeaturesR
|
|
BtnParentCandidatesDeleteAll -> do
|
|
runDB $ do
|
|
deleteWhere ([] :: [Filter StudySubTermParentCandidate])
|
|
addMessageI Success MsgAllParentIncidencesDeleted
|
|
redirect AdminFeaturesR
|
|
|
|
((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm
|
|
let standaloneBtnForm = wrapForm standaloneBtnWdgt def
|
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
|
, formEncoding = standaloneBtnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
formResult standaloneBtnResult $ \case
|
|
BtnStandaloneCandidatesDeleteRedundant -> do
|
|
infRedundantStandalone <- runDB Candidates.removeRedundantStandalone
|
|
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
|
redirect AdminFeaturesR
|
|
BtnStandaloneCandidatesDeleteAll -> do
|
|
runDB $ do
|
|
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
|
|
addMessageI Success MsgAllStandaloneIncidencesDeleted
|
|
redirect AdminFeaturesR
|
|
|
|
|
|
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
|
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
|
|
( (degreeResult,degreeTable)
|
|
, (studyTermsResult,studytermsTable)
|
|
, ((), candidateTable)
|
|
, userSchools
|
|
, ((), parentCandidateTable)
|
|
, (standaloneResult, standaloneCandidateTable)) <- runDB $ do
|
|
schools <- E.select . E.from $ \school -> do
|
|
E.where_ . E.exists . E.from $ \schoolFunction ->
|
|
E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
|
|
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
|
|
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
return school
|
|
(,,,,,)
|
|
<$> mkDegreeTable
|
|
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
|
(Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
|
|
(Set.fromList schools)
|
|
<*> mkCandidateTable
|
|
<*> pure schools
|
|
<*> mkParentCandidateTable
|
|
<*> mkStandaloneCandidateTable
|
|
|
|
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
|
|
degreeResult' = degreeResult <&> getDBFormResult
|
|
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
|
|
, row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
|
|
))
|
|
updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
|
|
formResult degreeResult' $ \res -> do
|
|
void . runDB $ Map.traverseWithKey updateDegree res
|
|
addMessageI Success MsgStudyDegreeChangeSuccess
|
|
redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
|
|
|
let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType))
|
|
standaloneResult' = standaloneResult <&> getDBFormResult
|
|
(\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
|
|
, row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just
|
|
))
|
|
formResult standaloneResult' $ \res -> do
|
|
updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do
|
|
StudyTermStandaloneCandidate{..} <- getJust candidateId
|
|
let termsId = StudyTermsKey' studyTermStandaloneCandidateKey
|
|
updated <- case (,) <$> mDegree <*> mType of
|
|
Nothing -> return Nothing
|
|
Just (degree, typ) -> do
|
|
ifM (existsKey termsId)
|
|
( update termsId
|
|
[ StudyTermsDefaultDegree =. Just degree
|
|
, StudyTermsDefaultType =. Just typ
|
|
]
|
|
)
|
|
( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ)
|
|
)
|
|
return $ Just termsId
|
|
infRedundantStandalone <- Candidates.removeRedundantStandalone
|
|
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
|
return updated
|
|
|
|
let newKeys = catMaybes $ Map.elems updated
|
|
unless (null newKeys) $ do
|
|
setSessionJson SessionNewStudyTerms newKeys
|
|
|
|
redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
|
|
|
|
let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
|
|
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
|
(\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
|
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
|
|
, row ^. _dbrOutput . _3
|
|
, row ^. _dbrOutput . _2 . to (Set.map entityKey)
|
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
|
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
|
|
))
|
|
updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
|
|
degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
|
|
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
|
|
|
|
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
|
|
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
|
|
|
|
forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
|
|
deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
|
|
formResult studyTermsResult' $ \res -> do
|
|
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
|
addMessageI Success MsgStudyTermsChangeSuccess
|
|
redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
|
|
siteLayoutMsg MsgAdminFeaturesHeading $ do
|
|
setTitleI MsgAdminFeaturesHeading
|
|
$(widgetFile "adminFeatures")
|
|
where
|
|
textInputCell :: Ord i
|
|
=> Lens' a (Maybe Text)
|
|
-> Getter (DBRow r) (Maybe Text)
|
|
-> Getter (DBRow r) i
|
|
-> DBRow r
|
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
(\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvInput
|
|
<$> 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 -> bimap (fmap $ set lensRes) fvInput
|
|
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
|
)
|
|
|
|
-- termKeyCell :: Ord i
|
|
-- => Lens' a (Maybe StudyTermsId)
|
|
-- -> Getter (DBRow r) (Maybe StudyTermsId)
|
|
-- -> Getter (DBRow r) i
|
|
-- -> DBRow r
|
|
-- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
-- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
-- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
|
-- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault)
|
|
-- )
|
|
|
|
parentsCell :: Ord i
|
|
=> Lens' a (Set StudyTermsId)
|
|
-> Getter (DBRow r) (Set StudyTermsId)
|
|
-> Getter (DBRow r) i
|
|
-> DBRow r
|
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
( \row mkUnique -> bimap (fmap $ set lensRes . Set.fromList) fvInput
|
|
<$> massInputList
|
|
(intField & isoField (from _StudyTermsId))
|
|
(const "")
|
|
(Just . SomeRoute . (AdminFeaturesR :#:))
|
|
(mkUnique ("parents" :: Text))
|
|
""
|
|
False
|
|
(Just . Set.toList $ row ^. lensDefault)
|
|
mempty
|
|
)
|
|
|
|
degreeCell :: Ord i
|
|
=> Lens' a (Maybe StudyDegreeId)
|
|
-> Getter (DBRow r) (Maybe StudyDegreeId)
|
|
-> Getter (DBRow r) i
|
|
-> DBRow r
|
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
( \row _mkUnique -> bimap (fmap $ set lensRes) fvInput
|
|
<$> mopt degreeField "" (Just $ row ^. lensDefault)
|
|
)
|
|
|
|
fieldTypeCell :: Ord i
|
|
=> Lens' a (Maybe StudyFieldType)
|
|
-> Getter (DBRow r) (Maybe StudyFieldType)
|
|
-> Getter (DBRow r) i
|
|
-> DBRow r
|
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
( \row _mkUnique -> bimap (fmap $ set lensRes) fvInput
|
|
<$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault)
|
|
)
|
|
|
|
|
|
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
|
|
mkDegreeTable =
|
|
let dbtIdent = "admin-studydegrees" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyDegreeKey)
|
|
dbtProj = return
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
|
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
|
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
|
|
, dbRow
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn (E.^. StudyDegreeKey))
|
|
, ("name" , SortColumn (E.^. StudyDegreeName))
|
|
, ("short", SortColumn (E.^. StudyDegreeShorthand))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
|
}
|
|
psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
|
& defaultPagesize PagesizeAll
|
|
& defaultSorting [SortAscBy "key"]
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget)
|
|
mkStudytermsTable newKeys badKeys schools =
|
|
let dbtIdent = "admin-studyterms" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyTermsKey)
|
|
dbtProj field@(view _dbrOutput -> Entity fId _) = do
|
|
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
|
|
E.where_ . E.exists . E.from $ \schoolTerms ->
|
|
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
|
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
|
|
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
|
|
return $ school E.^. SchoolId
|
|
fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
|
|
E.where_ . E.exists . E.from $ \subTerms ->
|
|
E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
|
|
E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
|
|
return terms
|
|
return $ field & _dbrOutput %~ (, fieldParents, fieldSchools)
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
|
, sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
|
|
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
|
|
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
|
|
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
|
|
, sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
|
|
, sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
|
|
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
|
|
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
|
|
, dbRow
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
|
|
-- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
|
|
, ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
|
|
)
|
|
, ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
|
|
)
|
|
, ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName))
|
|
, ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
|
|
, ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
|
|
, ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
}
|
|
psValidator = def
|
|
& defaultPagesize PagesizeAll
|
|
& defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"]
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
queryField = id
|
|
_dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
|
|
_dbrKey' = _dbrOutput . _1 . _entityKey
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkCandidateTable =
|
|
let dbtIdent = "admin-termcandidate" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyTermNameCandidateId)
|
|
dbtProj = return
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ dbRow
|
|
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
|
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn (E.^. StudyTermNameCandidateKey))
|
|
, ("name" , SortColumn (E.^. StudyTermNameCandidateName))
|
|
, ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateKey))
|
|
, ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName))
|
|
, ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey)
|
|
, prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
|
|
, prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
|
|
]
|
|
dbtParams = def
|
|
psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkParentCandidateTable =
|
|
let dbtIdent = "admin-termparentcandidate" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
|
-> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate)
|
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
|
)
|
|
dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do
|
|
E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey)
|
|
E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
|
|
return (candidate, parent, child)
|
|
dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
|
|
dbtProj = return
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ dbRow
|
|
, sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
|
|
, sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
|
|
, sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
|
|
, sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence))
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("child" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey))
|
|
, ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV)
|
|
, ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
|
|
, ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV)
|
|
, ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
psValidator = def
|
|
& defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"]
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c
|
|
queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p
|
|
queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c
|
|
in dbTable psValidator DBTable{..}
|
|
|
|
mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget)
|
|
mkStandaloneCandidateTable =
|
|
let dbtIdent = "admin-termstandalonecandidate" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermStandaloneCandidate)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
|
-> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate)
|
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
|
)
|
|
dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do
|
|
E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
|
|
return (candidate, sterm)
|
|
dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
|
|
dbtProj = return
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ dbRow
|
|
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
|
|
, sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')
|
|
, sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey')
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("key" , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey))
|
|
, ("name" , SortColumn $ queryTerm >>> (E.?. StudyTermsName) >>> E.joinV)
|
|
, ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence))
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
}
|
|
psValidator = def
|
|
& defaultSorting [SortAscBy "key", SortAscBy "incidence"]
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
queryCandidate (c `E.LeftOuterJoin` _) = c
|
|
queryTerm (_ `E.LeftOuterJoin` t) = t
|
|
_dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId
|
|
_dbrKey' = _dbrOutput . _1 . _entityKey
|
|
in dbTable psValidator DBTable{..}
|