465 lines
23 KiB
Haskell
465 lines
23 KiB
Haskell
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 Utils.Lens
|
|
|
|
-- 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 as E
|
|
|
|
import Handler.Utils.Table.Cells
|
|
import qualified Handler.Utils.TermCandidates as Candidates
|
|
|
|
-- import Colonnade hiding (fromMaybe)
|
|
-- import Yesod.Colonnade
|
|
|
|
-- import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
|
getAdminR :: Handler Html
|
|
getAdminR = -- do
|
|
siteLayoutMsg MsgAdminHeading $ do
|
|
setTitleI MsgAdminHeading
|
|
[whamlet|
|
|
This shall become the Administrators' overview page.
|
|
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 (HandlerT UniWorX IO) (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)})|]
|
|
return jId
|
|
writeJobCtl $ JobCtlPerform jId
|
|
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}
|
|
|]
|
|
|
|
|
|
{- 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 (HandlerT UniWorX IO)) (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
|
|
((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)) <- runDB $ (,,)
|
|
<$> mkDegreeTable
|
|
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
|
(Set.fromList $ map entityKey infConflicts)
|
|
<*> mkCandidateTable
|
|
|
|
-- 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))
|
|
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
|
(\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
|
|
, row ^. _dbrOutput . _entityVal . _studyTermsShorthand
|
|
))
|
|
updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
|
|
formResult studyTermsResult' $ \res -> do
|
|
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
|
addMessageI Success MsgStudyTermsChangeSuccess
|
|
|
|
siteLayoutMsg MsgAdminFeaturesHeading $ do
|
|
setTitleI MsgAdminFeaturesHeading
|
|
$(widgetFile "adminFeatures")
|
|
where
|
|
textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
|
|
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
|
<$> mopt textField "" (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))
|
|
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
|
|
, 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) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
|
|
mkStudytermsTable newKeys badKeys =
|
|
let dbtIdent = "admin-studyterms" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. StudyTermsKey)
|
|
dbtProj = return
|
|
dbtColonnade = formColonnade $ mconcat
|
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
|
|
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
|
|
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
|
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
|
|
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
|
|
, 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{..}
|
|
|