fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Streamline monoidal summaries for dbtables containing forms

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-25 17:35:24 +01:00
parent 1ccb8b7c32
commit c9ba51a0c9
5 changed files with 61 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Handler/Corrections.hs
View File

@ -132,7 +132,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData)))
colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSelect = dbSelect (applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
@ -334,12 +334,16 @@ correctionsR whereClause (formColonnade -> displayColumns) dbtFilterUI psValidat
((actionRes', table), statistics) <- runDB $ do
-- Query for Table
tableRes <- makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return def
{ dbParamsFormAction = Just $ SomeRoute currentRoute
tableRes <- makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormAddSubmit = True
, dbParamsFormAdditional = \frag -> do
(actionRes, action) <- multiAction actions Nothing
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
}
-- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
gradingSummary <- do

10
src/Handler/SystemMessage.hs
View File

@ -156,7 +156,7 @@ postMessageListR = do
let
dbtSQLQuery = return
dbtColonnade = mconcat
[ dbSelect _2 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
[ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
@ -198,8 +198,10 @@ postMessageListR = do
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
{ dbParamsFormAction = Just $ SomeRoute MessageListR
, dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute MessageListR
, dbParamsFormAttrs = []
, dbParamsFormAddSubmit = True
, dbParamsFormAdditional = \frag -> do
now <- liftIO getCurrentTime
@ -210,6 +212,8 @@ postMessageListR = do
]
(actionRes, action) <- multiAction actions (Just SMActivate)
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
}
, dbtIdent = "messages" :: Text
}

6
src/Handler/Utils/Table/Cells.hs
View File

@ -4,6 +4,7 @@ import Import
import Data.Monoid (Any(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Writer (WriterT)
import Utils.Lens
import Handler.Utils
@ -15,7 +16,10 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
-- Special cells
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
indicatorCell = writerCell . tell $ Any True
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act)
-- Datatype cells
timeCell :: IsDBTable m a => UTCTime -> DBCell m a

76
src/Handler/Utils/Table/Pagination.hs
View File

@ -401,8 +401,8 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) =>
dbHandler :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
dbInvalidateResult :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
dbInvalidateResult _ _ _ = return
dbInvalidateResult :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBParams m x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
dbInvalidateResult _ _ = return
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
cellAttrs = dbCell . _1
@ -461,58 +461,60 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
def = DBParamsDB
instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
{ dbParamsFormMethod :: StdMethod
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
, dbParamsFormAttrs :: [(Text, Text)]
, dbParamsFormAddSubmit :: Bool
, dbParamsFormAdditional :: Form a
, dbParamsFormEvaluate :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => Form a -> m' ((FormResult a, Widget), Enctype)
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormResult :: Lens' x (FormResult a)
}
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Widget)
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. FormCell
{ formCellAttrs :: [(Text, Text)]
, formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
, formCellContents :: WriterT x (MForm (HandlerT UniWorX IO)) (FormResult a, Widget)
, formCellLens :: Lens' x (FormResult a)
}
-- dbCell :: Iso'
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
-- ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) x)
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
dbCell = iso
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
(\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
(\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
dbInvalidateResult _ _ reason result = do
dbInvalidateResult DBParamsForm{..} reason result = do
reasonTxt <- getMessageRender <*> pure reason
return $ case result of
(FormFailure errs, wdgt) -> (FormFailure $ reasonTxt : errs, wdgt)
(_, wdgt) -> (FormFailure $ pure reasonTxt , wdgt)
let
adjResult (FormFailure errs) = FormFailure $ reasonTxt : errs
adjResult _ = FormFailure $ pure reasonTxt
return $ over (_1 . dbParamsFormResult) adjResult result
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormAddSubmit = False
, dbParamsFormAdditional = \_ -> return mempty
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
}
dbParamsFormWrap :: Monoid a => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) -> Form a -> Form a
dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
dbParamsFormWrap DBParamsForm{..} tableForm frag = do
let form = mappend <$> tableForm frag <*> dbParamsFormAdditional mempty
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
((res, fWidget), enctype) <- listen form
return . (res,) $ do
btnId <- newIdent
@ -556,9 +558,9 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
mempty = FormCell mempty (return mempty)
(FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
(FormCell attrs c l) `mappend` (FormCell attrs' c' l') = FormCell (mappend attrs attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', mappend w w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString
@ -685,7 +687,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
table' :: WriterT x m Widget
table' = do
let
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- sortableContent ^. cellContents
@ -721,7 +722,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
[ do
pKeys <- previousKeys
guard $ pKeys /= currentKeys
return . dbInvalidateResult (Proxy @m) (Proxy @x) . DBTIRowsMissing $ length previousKeys - length currentKeys
return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
]
dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
@ -848,22 +849,23 @@ getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall res r i a. (Ord i, Monoid res)
=> Lens' res (DBFormResult i a (DBRow r))
=> Lens' res (FormResult (DBFormResult i a (DBRow r)))
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell resLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) res)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
i <- genIndex input
i <- lift $ genIndex input
hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
let
mkUnique :: PathPiece p => p -> Text
mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
where
rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
(edit, w) <- genForm input mkUnique
return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
(edit, w) <- lift $ genForm input mkUnique
return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
, formCellLens
}
@ -874,10 +876,10 @@ dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
=> Lens' res (DBFormResult i a (DBRow r))
=> Lens' res (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) res)
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
where
genForm _ mkUnique = do

3
src/Utils/Lens.hs
View File

@ -16,6 +16,9 @@ _PathPiece = prism' toPathPiece fromPathPiece
maybePrism :: Prism' a b -> Prism' (Maybe a) (Maybe b)
maybePrism p = prism' (fmap $ review p) (fmap $ preview p )
applying :: Applicative f => Lens' s a -> Lens' (f s) (f a)
applying l = lens (fmap $ view l) (liftA2 . flip $ set l)
_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
_InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l