From 3541c1dc40d477f0b9fe2381b18622931f776dc7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 Dec 2018 18:55:06 +0100 Subject: [PATCH 01/47] Prevent user from locking themselves out (authpreds) --- src/Handler/Home.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f4125de79..911827e00 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -283,8 +283,12 @@ getAuthPredsR, postAuthPredsR :: Handler Html getAuthPredsR = postAuthPredsR postAuthPredsR = do (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - - let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) + + let + blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ] + taForm authTag + | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag) + | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard $ AuthTagActive From 01cee62b10b6963852f7fa4501f8cf887c3fff95 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 Dec 2018 19:30:29 +0100 Subject: [PATCH 02/47] Work on #39 --- messages/uniworx/de.msg | 3 ++ src/Data/CaseInsensitive/Instances.hs | 5 ++ src/Data/Monoid/Instances.hs | 19 ++++++++ src/Handler/Corrections.hs | 1 + src/Handler/Course.hs | 19 +++++++- src/Handler/Home.hs | 2 + src/Handler/Profile.hs | 5 ++ src/Handler/Sheet.hs | 7 +-- src/Handler/Submission.hs | 3 +- src/Handler/SystemMessage.hs | 9 ++-- src/Handler/Term.hs | 1 + src/Handler/Users.hs | 1 + src/Handler/Utils/Form.hs | 24 +++++++++ src/Handler/Utils/Table/Pagination.hs | 51 +++++++++++++++----- src/Import/NoFoundation.hs | 1 + src/Utils/Form.hs | 2 +- templates/table/layout-filter-default.hamlet | 6 +++ templates/widgets/form.hamlet | 2 +- 18 files changed, 136 insertions(+), 25 deletions(-) create mode 100644 src/Data/Monoid/Instances.hs create mode 100644 templates/table/layout-filter-default.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1595dc8d9..340c9fa16 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -72,6 +72,8 @@ CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gese CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein +CourseFilterSearch: Volltext-Suche +CourseFilterRegistered: Registriert NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -233,6 +235,7 @@ CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen CorrAutoSetCorrector: Korrekturen verteilen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! +JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure} SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist): diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 7dc9123e8..c9e7f0c5d 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.CaseInsensitive.Instances @@ -20,6 +21,8 @@ import Language.Haskell.TH.Syntax (Lift(..)) import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..)) +import qualified Database.Esqueleto as E + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -37,6 +40,8 @@ instance PersistFieldSql (CI Text) where instance PersistFieldSql (CI String) where sqlType _ = SqlOther "citext" +instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a) + instance ToJSON a => ToJSON (CI a) where toJSON = toJSON . CI.original diff --git a/src/Data/Monoid/Instances.hs b/src/Data/Monoid/Instances.hs new file mode 100644 index 000000000..44909d53f --- /dev/null +++ b/src/Data/Monoid/Instances.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Monoid.Instances + ( + ) where + +import ClassyPrelude +import Data.Monoid + +type instance Element (Dual a) = a +instance MonoPointed (Dual a) +type instance Element (Sum a) = a +instance MonoPointed (Sum a) +type instance Element (Product a) = a +instance MonoPointed (Product a) +type instance Element (First a) = a +instance MonoPointed (First a) +type instance Element (Last a) = a +instance MonoPointed (Last a) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 803ef4bae..b77167ca8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -277,6 +277,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) ] + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "corrections" :: Text } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e843ade32..d34542f87 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -12,6 +12,8 @@ import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 +import Data.Monoid (Last(..)) + import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map @@ -161,13 +163,27 @@ makeCourseTable whereClause colChoices psValidator = do | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias) ) + , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> course2Registered muid tExpr E.==. E.val needle + ) + , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + ) ] + , dbtFilterUI = mconcat + [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing + , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing + ] , dbtStyle = def , dbtIdent = "courses" :: Text } getCourseListR :: Handler Html -getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! +getCourseListR = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ colCourseDescr @@ -182,7 +198,6 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle - [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO $(widgetFile "courses") getTermCurrentR :: Handler Html diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 911827e00..f5bd47c51 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -97,6 +97,7 @@ homeAnonymous = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } @@ -198,6 +199,7 @@ homeUser uid = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} + , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index dab2a6b83..410f6862a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -273,6 +273,7 @@ mkOwnedCoursesTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} @@ -319,6 +320,7 @@ mkEnrolledCoursesTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] + , dbtFilterUI = mempty , dbtStyle = def } @@ -396,6 +398,7 @@ mkSubmissionTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} @@ -465,6 +468,7 @@ mkSubmissionGroupTable = , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} @@ -538,6 +542,7 @@ mkCorrectionsTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) ] + dbtFilterUI = mempty in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6728e11a2..f8b4b8f51 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -225,8 +225,8 @@ getSheetListR tid ssh csh = do -- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType) -- ) ] - , dbtFilter = Map.fromList - [] + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "sheets" :: Text } @@ -294,7 +294,8 @@ getSShowR tid ssh csh shn = do , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) , dbtStyle = def - , dbtFilter = Map.empty + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cc645a929..7129dfeeb 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -310,7 +310,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) ) ] - , dbtFilter = Map.empty + , dbtFilter = mempty + , dbtFilterUI = mempty } mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 0bde9b1c8..a71104eff 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -178,12 +178,9 @@ postMessageListR = do { dbtSQLQuery , dbtColonnade , dbtProj - , dbtSorting = Map.fromList - [ -- TODO: from, to, authenticated, severity - ] - , dbtFilter = Map.fromList - [ - ] + , dbtSorting = mempty -- TODO: from, to, authenticated, severity + , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "messages" :: Text } diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 41262bd44..0b1e67100 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -126,6 +126,7 @@ getTermShowR = do E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs ) ] + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "terms" :: Text } diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ec3924508..d3a9a1d50 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -85,6 +85,7 @@ getUsersR = do ) ] , dbtFilter = mempty + , dbtFilterUI = mempty , dbtStyle = def , dbtIdent = "users" :: Text } diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc16635d7..906aa48fc 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -45,6 +45,9 @@ import Text.Read (readMaybe) import Utils.Lens +import Data.Aeson (eitherDecodeStrict') +import Data.Aeson.Text (encodeToLazyText) + ---------------------------- -- Buttons (new version ) -- ---------------------------- @@ -455,6 +458,27 @@ langField :: Bool -- ^ Only allow values from `appLanguages` langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages +jsonField :: ( ToJSON a, FromJSON a + , MonadHandler m + , RenderMessage (HandlerSite m) UniWorXMessage + , RenderMessage (HandlerSite m) FormMessage + ) + => Bool {-^ Hidden? -} + -> Field m a +jsonField hide = Field{..} + where + inputType :: Text + inputType + | hide = "hidden" + | otherwise = "text" + fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v + fieldParse [] [] = return $ Right Nothing + fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired + fieldView theId name attrs val isReq = liftWidgetT [whamlet| + + |] + fieldEnctype = UrlEncoded + funcForm :: forall k v m. ( Finite k, Ord k diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 808ad04af..170d52bbd 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination ) where import Handler.Utils.Table.Pagination.Types +import Handler.Utils.Form import Utils import Utils.Lens.TH @@ -228,6 +229,11 @@ data DBStyle = DBStyle { dbsEmptyStyle :: DBEmptyStyle , dbsEmptyMessage :: UniWorXMessage , dbsAttrs :: [(Text, Text)] + , dbsLayoutFilter :: Widget -- ^ Filter UI + -> Enctype + -> Text -- ^ Filter action (target uri) + -> Widget -- ^ Table + -> Widget } instance Default DBStyle where @@ -235,8 +241,12 @@ instance Default DBStyle where { dbsEmptyStyle = def , dbsEmptyMessage = MsgNoTableContent , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ] + , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default") } +type FilterKey = CI Text +type SortingKey = CI Text + data DBTable m x = forall a r r' h i t. ( ToSortable h, Functor h , E.SqlSelect a r @@ -246,8 +256,9 @@ data DBTable m x = forall a r r' h i t. { dbtSQLQuery :: t -> E.SqlQuery a , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r' , dbtColonnade :: Colonnade h r' (DBCell m x) - , dbtSorting :: Map (CI Text) (SortColumn t) - , dbtFilter :: Map (CI Text) (FilterColumn t) + , dbtSorting :: Map SortingKey (SortColumn t) + , dbtFilter :: Map FilterKey (FilterColumn t) + , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtStyle :: DBStyle , dbtIdent :: i } @@ -379,18 +390,31 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piResult <- lift . runInputGetResult $ PaginationInput + piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + + piInput <- lift . runInputGetResult $ PaginationInput <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "page") - piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + let filterPi + | FormSuccess PaginationInput{..} <- piPrevious <|> piInput + = def{ piSorting, piLimit } + | otherwise + = def + + ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,) + <$> areq (jsonField True) "" (Just filterPi) + <*> dbtFilterUI + + let + piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit let - (errs, PaginationSettings{..}) = case piPrevious <|> piResult of + (errs, PaginationSettings{..}) = case piResult of FormSuccess pi | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi @@ -398,7 +422,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing _ -> runPSValidator dbtable Nothing paginationInput - | FormSuccess pi <- piPrevious <|> piResult + | FormSuccess pi <- piResult , not $ piIsUnset pi = pi | otherwise @@ -419,18 +443,23 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' + getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let rowCount | (E.Value n, _):_ <- rows' = n | otherwise = 0 + tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams + + filterAction = tblLink + $ setParam (wIdent "page") Nothing + . Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter + table' :: WriterT x m Widget table' = do - getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest let - tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams - genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do widget <- sortableContent ^. cellContents let @@ -456,7 +485,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return $(widgetFile "table/layout") - bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' + bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html tblLayout tbl' = do @@ -464,7 +493,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet") setParam :: Text -> Maybe Text -> QueryText -> QueryText - setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] + setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ] dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x -> DB (DBResult (HandlerT UniWorX IO) x) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 3bd7ebc45..a832df0db 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -41,6 +41,7 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) +import Data.Monoid.Instances as Import () import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5450e0f40..c754bf227 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -28,7 +28,7 @@ import Utils.Message ------------------- -- | Use this type to pass information to the form template -data FormLayout = FormStandard +data FormLayout = FormStandard | FormDBTableFilter renderAForm :: Monad m => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do diff --git a/templates/table/layout-filter-default.hamlet b/templates/table/layout-filter-default.hamlet new file mode 100644 index 000000000..9291c30fb --- /dev/null +++ b/templates/table/layout-filter-default.hamlet @@ -0,0 +1,6 @@ +$newline never +
+
+ ^{filterWgdt} +
+ ^{scrolltable} diff --git a/templates/widgets/form.hamlet b/templates/widgets/form.hamlet index 79c2178a6..50d90cbb3 100644 --- a/templates/widgets/form.hamlet +++ b/templates/widgets/form.hamlet @@ -1,7 +1,7 @@ $newline never #{fragment} $case formLayout - $of FormStandard + $of _ $forall view <- views $# TODO: add class 'form-group--submit' if this is the submit-button view
From 2d05c2c9a947d94a59d8ff94c0f3f12dea8dfc29 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 7 Dec 2018 11:39:39 +0100 Subject: [PATCH 03/47] minor fixes --- messages/uniworx/de.msg | 2 +- src/Handler/Utils/Form.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8b15af8b0..474c0ab8f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -390,8 +390,8 @@ SheetTypeBonus grading@SheetGrading: Bonus SheetTypeNormal grading@SheetGrading: Normal SheetTypeInformational grading@SheetGrading: Keine Wertung SheetTypeNotGraded: Unbewertet +SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information der Teilnehmer. SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. -SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer. SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt. SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc16635d7..57ce35936 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -312,7 +312,7 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) -data SheetType' = Bonus' | Normal' | Informational' | NotGraded' +data SheetType' = Normal' | Bonus' | Informational' | NotGraded' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetType' @@ -353,8 +353,8 @@ sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler S sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template) where selOptions = Map.fromList - [ ( Bonus' , Bonus <$> gradingReq ) - , ( Normal', Normal <$> gradingReq ) + [ ( Normal', Normal <$> gradingReq ) + , ( Bonus' , Bonus <$> gradingReq ) , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) ] From 5728d413cf613430a1d109627ccd6daed6913ff1 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 7 Dec 2018 12:58:13 +0100 Subject: [PATCH 04/47] refactored as suggested by Gregor in #253 --- src/Handler/Sheet.hs | 89 ++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 44 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index f8b4b8f51..2884043f8 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -146,13 +146,12 @@ getSheetListR tid ssh csh = do lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.max_ $ sheetEdit E.^. SheetEditTime - sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission))) + sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery () sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return (sheet, lastSheetEdit sheet, submission) sheetCol = widgetColonnade . mconcat $ [ dbRow , sortable (Just "name") (i18nCell MsgSheet) @@ -197,48 +196,50 @@ getSheetListR tid ssh csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - table <- runDB $ dbTableWidget' psValidator DBTable - { dbtSQLQuery = sheetData - , dbtColonnade = sheetCol - , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) } - -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) - , dbtSorting = Map.fromList - [ ( "name" - , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName - ) - , ( "last-edit" - , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet - ) - , ( "submission-since" - , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom - ) - , ( "submission-until" - , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo - ) - , ( "rating" - , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints - ) --- GitLab Issue $143: HOW TO SORT? --- , ( "percent" --- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> --- case sheetType of -- no Haskell inside Esqueleto, right? --- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType) --- ) - ] - , dbtFilter = mempty - , dbtFilterUI = mempty - , dbtStyle = def - , dbtIdent = "sheets" :: Text - } - -- Collect summary over all Sheets, not just the ones shown due to pagination: - statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> do - rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do - E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission - E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet - E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) - return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows + (table,statistics) <- runDB $ liftA2 (,) + (dbTableWidget' psValidator DBTable + { dbtColonnade = sheetCol + , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) + -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission) + , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) } + -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) + , dbtSorting = Map.fromList + [ ( "name" + , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName + ) + , ( "last-edit" + , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet + ) + , ( "submission-since" + , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom + ) + , ( "submission-until" + , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo + ) + , ( "rating" + , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints + ) + -- GitLab Issue $143: HOW TO SORT? + -- , ( "percent" + -- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> + -- case sheetType of -- no Haskell inside Esqueleto, right? + -- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType) + -- ) + ] + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtStyle = def + , dbtIdent = "sheets" :: Text + } + ) ( + -- Collect summary over all Sheets, not just the ones shown due to pagination: + gradeSummaryWidget MsgSheetGradingSummaryTitle . + foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) + <$> ( + E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> + sheetData dt *> return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) + ) + ) defaultLayout $ do $(widgetFile "sheetList") From 0407d10654644a16f9697904dc409a8fa8cd5057 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 7 Dec 2018 14:16:03 +0100 Subject: [PATCH 05/47] Fixes #253 --- src/Handler/Sheet.hs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 2884043f8..a1ec6ad96 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -146,12 +146,17 @@ getSheetListR tid ssh csh = do lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.max_ $ sheetEdit E.^. SheetEditTime + sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery () sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + + sheetFilter :: SheetName -> DB Bool + sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False + sheetCol = widgetColonnade . mconcat $ [ dbRow , sortable (Just "name") (i18nCell MsgSheet) @@ -194,15 +199,17 @@ getSheetListR tid ssh csh = do _other -> mempty _other -> mempty ] + psValidator = def & defaultSorting [("submission-since", SortAsc)] - (table,statistics) <- runDB $ liftA2 (,) + + (table,raw_statistics) <- runDB $ liftA2 (,) (dbTableWidget' psValidator DBTable { dbtColonnade = sheetCol , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission) , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) } - -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) + -> dbr <$ guardM (lift $ sheetFilter sheetName) , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName @@ -233,13 +240,16 @@ getSheetListR tid ssh csh = do } ) ( -- Collect summary over all Sheets, not just the ones shown due to pagination: - gradeSummaryWidget MsgSheetGradingSummaryTitle . - foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) - <$> ( - E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> - sheetData dt *> return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) - ) + do + rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> + sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) + flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName) ) + + let statistics = + gradeSummaryWidget MsgSheetGradingSummaryTitle $ + foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) + raw_statistics defaultLayout $ do $(widgetFile "sheetList") From 30a5aff70efc7dcc948c55aba4efc25b793fc65d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 11 Dec 2018 21:21:02 +0100 Subject: [PATCH 06/47] Implement connection pooling for LDAP --- config/keter_testworx.yml | 3 ++ config/keter_uni2work.yml | 3 ++ config/settings.yml | 6 ++- src/Application.hs | 7 ++- src/Auth/LDAP.hs | 13 ++--- src/Foundation.hs | 13 ++--- src/Import/NoFoundation.hs | 2 + src/Ldap/Client/Pool.hs | 100 +++++++++++++++++++++++++++++++++++++ src/Settings.hs | 2 + 9 files changed, 134 insertions(+), 15 deletions(-) create mode 100644 src/Ldap/Client/Pool.hs diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index be7037613..4f1d648db 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -27,7 +27,10 @@ stanzas: - LDAPPASS - LDAPBASE - LDAPSCOPE + - LDAPSEARCHTIME + - LDAPSTRIPES - LDAPTIMEOUT + - LDAPLIMIT - DUMMY_LOGIN - DETAILED_LOGGING - LOG_ALL diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index 873124070..15f9eee7e 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -27,7 +27,10 @@ stanzas: - LDAPPASS - LDAPBASE - LDAPSCOPE + - LDAPSEARCHTIME + - LDAPSTRIPES - LDAPTIMEOUT + - LDAPLIMIT - DETAILED_LOGGING - LOG_ALL - LOGLEVEL diff --git a/config/settings.yml b/config/settings.yml index 2ff396932..0a8252dae 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -66,7 +66,11 @@ ldap: pass: "_env:LDAPPASS:" baseDN: "_env:LDAPBASE:" scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" + timeout: "_env:LDAPSEARCHTIME:5" + pool: + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" smtp: host: "_env:SMTPHOST:" diff --git a/src/Application.hs b/src/Application.hs index cdf4d9ecc..144945e00 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -139,13 +139,14 @@ makeFoundation appSettings@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") (error "sessionKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") @@ -166,6 +167,8 @@ makeFoundation appSettings@AppSettings{..} = do sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + + ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool) -- Perform database migration using our application's logging settings. migrateAll `runSqlPool` sqlPool @@ -173,7 +176,7 @@ makeFoundation appSettings@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached handleJobs foundation diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 2b053ce05..ce07bb83c 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -17,6 +17,7 @@ import qualified Control.Monad.Catch as Exc import Utils.Form +import Ldap.Client (Ldap) import qualified Ldap.Client as Ldap import qualified Data.Text.Encoding as Text @@ -36,7 +37,7 @@ data CampusMessage = MsgCampusIdentNote | MsgCampusInvalidCredentials -findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] +findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter where userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent @@ -66,8 +67,8 @@ campusLogin :: forall site. , RenderMessage site CampusMessage , Button site SubmitButton , Show (ButtonCssClass site) - ) => LdapConf -> AuthPlugin site -campusLogin conf@LdapConf{..} = AuthPlugin{..} + ) => LdapConf -> LdapPool -> AuthPlugin site +campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where apName = "LDAP" apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent @@ -79,7 +80,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..} redirect LoginR FormMissing -> redirect LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do - ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do + ldapResult <- withLdap pool $ \ldap -> do Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) Ldap.bind ldap ldapDn ldapPassword findUser conf ldap campusIdent [userPrincipalName] @@ -117,8 +118,8 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError instance Exception CampusUserException -campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList []) -campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do +campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do diff --git a/src/Foundation.hs b/src/Foundation.hs index 601db3527..cf3483b6d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -102,6 +102,7 @@ data UniWorX = UniWorX , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool + , appLdapPool :: Maybe LdapPool , appWidgetMemcached :: Maybe Memcached.Connection , appHttpManager :: Manager , appLogger :: (ReleaseKey, TVar Logger) @@ -1581,11 +1582,11 @@ instance YesodAuth UniWorX where acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth $logDebugS "auth" $ tshow Creds{..} - AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings + UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod - flip catches excHandlers $ case appLdapConf of - Just ldapConf -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra + flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of + Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do + ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData let @@ -1669,8 +1670,8 @@ instance YesodAuth UniWorX where where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - authPlugins (appSettings -> AppSettings{..}) = catMaybes - [ campusLogin <$> appLdapConf + authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes + [ campusLogin <$> appLdapConf <*> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin ] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index a832df0db..868ba4b67 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -50,6 +50,8 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey) import Network.Mail.Mime.Instances as Import () import Yesod.Core.Instances as Import () +import Ldap.Client.Pool as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs new file mode 100644 index 000000000..ad84150e2 --- /dev/null +++ b/src/Ldap/Client/Pool.hs @@ -0,0 +1,100 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ldap.Client.Pool + ( LdapPool + , LdapExecutor, Ldap, LdapError + , withLdap + , createLdapPool + ) where + +import ClassyPrelude + +import Ldap.Client (Ldap, LdapError) +import qualified Ldap.Client as Ldap + +import Data.Pool + +import Control.Monad.Logger +import Data.Time.Clock (NominalDiffTime) + +import Data.Dynamic + + +type LdapPool = Pool LdapExecutor +data LdapExecutor = LdapExecutor + { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a) + , ldapDestroy :: TMVar () + } + +instance Exception LdapError + + +withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a) +withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act + + +createLdapPool :: ( MonadLoggerIO m, MonadIO m ) + => Ldap.Host + -> Ldap.PortNumber + -> Int -- ^ Stripes + -> NominalDiffTime -- ^ Timeout + -> Int -- ^ Limit + -> m LdapPool +createLdapPool host port stripes timeout limit = do + logFunc <- askLoggerIO + + let + mkExecutor :: IO LdapExecutor + mkExecutor = do + ldapDestroy <- newEmptyTMVarIO + ldapAct <- newEmptyTMVarIO + + let + ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a) + ldapExec act = do + ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic)) + atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer) + either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer) + `catches` + [ Handler $ return . Left . Ldap.ParseError + , Handler $ return . Left . Ldap.ResponseError + , Handler $ return . Left . Ldap.IOError + , Handler $ return . Left . Ldap.DisconnectError + ] + + go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO () + go waiting ldap = do + $logDebugS "LdapExecutor" "Waiting" + for_ waiting $ atomically . flip putTMVar Nothing + instruction <- atomically $ (Nothing <$ takeTMVar ldapDestroy) <|> (Just <$> takeTMVar ldapAct) + case instruction of + Nothing -> $logDebugS "LdapExecutor" "Terminating" + Just (act, returnRes) -> do + $logDebugS "LdapExecutor" "Executing" + res <- try . liftIO $ act ldap + didReturn <- atomically $ tryPutTMVar returnRes res + unless didReturn $ + $logErrorS "LdapExecutor" "Could not return result" + either throwM (const $ return ()) res + `catches` + [ Handler (\(Ldap.ResponseError _) -> return ()) + ] + go Nothing ldap + + setup <- newEmptyTMVarIO + void . fork . flip runLoggingT logFunc $ do + $logDebugS "LdapExecutor" "Starting" + res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) + case res of + Left exc -> do + $logWarnS "LdapExecutor" $ tshow exc + atomically . void . tryPutTMVar setup $ Just exc + Right res' -> return res' + + maybe (return ()) throwM =<< atomically (takeTMVar setup) + + return LdapExecutor{..} + + delExecutor :: LdapExecutor -> IO () + delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy () + liftIO $ createPool mkExecutor delExecutor stripes timeout limit diff --git a/src/Settings.hs b/src/Settings.hs index 8abbc1fe1..f511e579b 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -162,6 +162,7 @@ data LdapConf = LdapConf , ldapBase :: Ldap.Dn , ldapScope :: Ldap.Scope , ldapTimeout :: Int32 + , ldapPool :: ResourcePoolConf } deriving (Show) data SmtpConf = SmtpConf @@ -248,6 +249,7 @@ instance FromJSON LdapConf where ldapBase <- Ldap.Dn <$> o .: "baseDN" ldapScope <- o .: "scope" ldapTimeout <- o .: "timeout" + ldapPool <- o .: "pool" return LdapConf{..} deriveFromJSON From 306fb351adb3834d7dc381c0770712d2a1cf9bba Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 12 Dec 2018 12:05:22 +0100 Subject: [PATCH 07/47] =?UTF-8?q?Error=20Handling=20f=C3=BCr=20SinkSubmiss?= =?UTF-8?q?ion?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- messages/uniworx/de.msg | 9 ++++++++- src/Foundation.hs | 1 + src/Handler/Corrections.hs | 31 ++++++++++++++++--------------- src/Handler/Submission.hs | 22 +++++++++++----------- src/Handler/Utils/Submission.hs | 30 +++++++++++++----------------- src/Import/NoFoundation.hs | 1 + src/Model/Submission.hs | 22 ++++++++++++++++++++++ 7 files changed, 72 insertions(+), 44 deletions(-) create mode 100644 src/Model/Submission.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index af38effd0..2ee21fdf2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -234,7 +234,7 @@ CorrUploadField: Korrekturen CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen CorrAutoSetCorrector: Korrekturen verteilen -NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! +NatField name@Text: #{name} muss eine natürliche Zahl sein! JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure} SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: @@ -295,6 +295,13 @@ RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein +SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor +SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. +SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich. +SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen! + +MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error} + NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter diff --git a/src/Foundation.hs b/src/Foundation.hs index cf3483b6d..5f2795e56 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -199,6 +199,7 @@ embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''RatingException id +embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b77167ca8..ba494b409 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -580,13 +580,12 @@ postCorrectionR tid ssh csh shn cid = do FormSuccess fileUploads -> do uid <- requireAuthId - void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - {-case res of - (Left _) -> addMessageI Success MsgRatingFilesUpdated - (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected - (Right other) -> throw other-} - - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + case res of + Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors + (Just _) -> do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR mr <- getMessageRender let sheetTypeDesc = mr sheetType @@ -621,13 +620,15 @@ postCorrectionsUploadR = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId - subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True - if - | null subs -> addMessageI Warning MsgNoCorrectionsUploaded - | otherwise -> do - subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] - mr <- (toHtml .) <$> getMessageRender - addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) + mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True + case mbSubs of + Nothing -> return () + (Just subs) + | null subs -> addMessageI Warning MsgNoCorrectionsUploaded + | otherwise -> do + subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] + mr <- (toHtml .) <$> getMessageRender + addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) defaultLayout $ @@ -671,7 +672,7 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do - allDone <- fmap getAll . execWriterT $ do + allDone <- fmap getAll . execWriterT $ do forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") tell . All $ null invalids diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 7129dfeeb..a011f5295 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -4,7 +4,7 @@ import Import import Jobs --- import Yesod.Form.Bootstrap3 +-- import Yesod.Form.Bootstrap3 import Handler.Utils import Handler.Utils.Submission @@ -55,7 +55,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing flip (renderAForm FormStandard) html $ (,) <$> fileUploadForm - <*> ( (:|) + <*> ( (:|) -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students) <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy @@ -66,7 +66,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu <* submitButton where (groupNr, editableBuddies) - | Arbitrary{..} <- grouping = (maxParticipants, True) + | Arbitrary{..} <- grouping = (maxParticipants, True) | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False) | otherwise = (0, False) @@ -140,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) - + shid' <- submissionSheet <$> get404 smid unless (shid == shid') $ invalidArgsI [MsgSubmissionWrongSheet] @@ -169,7 +169,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits) ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies) - mCID <- runDBJobs $ do + mCID <- (fmap join) . msgSubmissionErrors . runDBJobs $ do res' <- case res of FormMissing -> return FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs @@ -193,7 +193,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do E.&&. submission E.^. SubmissionSheet E.==. E.val shid case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 Nothing -> return () - Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return $ E.countRows E.>. E.val (0 :: Int64) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) @@ -252,7 +252,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do return $ Just cID (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) _other -> return Nothing - + case mCID of Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () @@ -281,7 +281,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in timeCell fileTime ] - coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) + coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do @@ -349,7 +349,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat case results of [Entity _ File{ fileContent = Just c, fileTitle }] -> do - whenM downloadFiles $ + whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () @@ -359,13 +359,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do - when (sfType == SubmissionCorrected) $ + when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | otherwise = ZIPArchiveName $ toPathPiece cID - + addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] respondSourceDB "application/zip" $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 3d405fff8..0730f157d 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -5,6 +5,7 @@ module Handler.Utils.Submission , submissionFileSource, submissionFileQuery , submissionMultiArchive , SubmissionSinkException(..) + , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB! , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet ) where @@ -267,14 +268,6 @@ instance Monoid SubmissionSinkState where mempty = memptydefault mappend = mappenddefault -data SubmissionSinkException = DuplicateFileTitle FilePath - | DuplicateRating - | RatingWithoutUpdate - | ForeignRating CryptoFileNameSubmission - deriving (Typeable, Show) - -instance Exception SubmissionSinkException - submissionBlacklist :: [Pattern] submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") @@ -311,6 +304,18 @@ extractRatingsMsg = do mr <- (toHtml . ) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) +-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann! +msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a) +msgSubmissionErrors = flip catches + [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException) + , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) + , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do + mr <- getMessageRender + addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx) + return Nothing + ] . fmap Just + + sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction @@ -510,15 +515,6 @@ sinkSubmission userId mExists isUpdate = do -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId | otherwise -> return () -data SubmissionMultiSinkException - = SubmissionSinkException - { _submissionSinkId :: CryptoFileNameSubmission - , _submissionSinkFedFile :: Maybe FilePath - , _submissionSinkException :: SubmissionSinkException - } - deriving (Typeable, Show) - -instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 868ba4b67..91cebefe8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -8,6 +8,7 @@ import Model as Import import Model.Types.JSON as Import import Model.Migration as Import import Model.Rating as Import +import Model.Submission as Import import Settings as Import import Settings.StaticFiles as Import import Yesod.Auth as Import diff --git a/src/Model/Submission.hs b/src/Model/Submission.hs new file mode 100644 index 000000000..0f931911b --- /dev/null +++ b/src/Model/Submission.hs @@ -0,0 +1,22 @@ +module Model.Submission where + +import ClassyPrelude.Yesod +import CryptoID + +data SubmissionSinkException = DuplicateFileTitle FilePath + | DuplicateRating + | RatingWithoutUpdate + | ForeignRating CryptoFileNameSubmission + deriving (Typeable, Show) + +instance Exception SubmissionSinkException + +data SubmissionMultiSinkException + = SubmissionSinkException + { _submissionSinkId :: CryptoFileNameSubmission + , _submissionSinkFedFile :: Maybe FilePath + , _submissionSinkException :: SubmissionSinkException + } + deriving (Typeable, Show) + +instance Exception SubmissionMultiSinkException From 553d14e8093e18381b3e4525e4a86af888d2ade8 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 12 Dec 2018 15:20:13 +0100 Subject: [PATCH 08/47] single runDB for correction statistics ensures match --- src/Handler/Corrections.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index ba494b409..e2987b6cd 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -301,7 +301,18 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do - tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return + (tableForm, statistics) <- runDB $ do + -- Query for Table + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return + -- Similar Query for Statistics over alle possible Table elements (not just the ones shown) + gradingSummary <- do + let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime) + points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints + -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn [] + return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points + let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary + return (tableForm,statistics) + ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf (actionRes, action) <- multiAction actions Nothing @@ -379,12 +390,6 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute - gradingSummary <- runDB $ do - let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime) - points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints - -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn [] - return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points - let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") From 19a25ec520995146c18f8b68041aa6c3821f8ea7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 13 Dec 2018 15:10:43 +0100 Subject: [PATCH 09/47] Rework dbtable forms, cleanup --- src/Handler/Corrections.hs | 48 +++--- src/Handler/Course.hs | 7 +- src/Handler/Home.hs | 4 +- src/Handler/Profile.hs | 15 +- src/Handler/Sheet.hs | 6 +- src/Handler/Submission.hs | 1 + src/Handler/SystemMessage.hs | 50 ++++-- src/Handler/Term.hs | 1 + src/Handler/Users.hs | 3 +- src/Handler/Utils/Table/Pagination.hs | 160 ++++++++++++++------ src/Handler/Utils/Table/Pagination/Types.hs | 25 ++- src/Import/NoFoundation.hs | 1 + templates/corrections-grade.hamlet | 5 +- templates/corrections.hamlet | 7 +- templates/system-message-list.hamlet | 5 +- templates/table/cell/header.hamlet | 4 +- templates/table/form-wrap.hamlet | 5 + 17 files changed, 235 insertions(+), 112 deletions(-) create mode 100644 templates/table/form-wrap.hamlet diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b77167ca8..de08b182d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -127,8 +127,8 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) -colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) -colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId +colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) +colSelect = dbSelect _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 @@ -174,12 +174,12 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_ in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b)))) -colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell +colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done)) colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b)))) -colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell +colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) @@ -187,14 +187,14 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for ) colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text)))) -colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell +colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery = correctionsTableQuery whereClause (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> @@ -279,6 +279,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do ] , dbtFilterUI = mempty , dbtStyle = def + , dbtParams , dbtIdent = "corrections" :: Text } @@ -301,13 +302,19 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do - tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return - ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do - (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf - (actionRes, action) <- multiAction actions Nothing - return ((,) <$> actionRes <*> selectionRes, table <> action) - Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler + + (actionRes', table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return def + { dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAddSubmit = True + , dbParamsFormAdditional = \frag -> do + (actionRes, action) <- multiAction actions Nothing + return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) + } + + let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + & mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast + case actionRes of FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs FormMissing -> return () @@ -795,14 +802,17 @@ postCorrectionsGradeR = do , colCommentField ] -- Continue here psValidator = def - & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) + & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) + dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do + cID <- encrypt subId + void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True + return i - tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do - cID <- encrypt subId - void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True - return i - ((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def + { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR + , dbParamsFormAddSubmit = True + } case tableRes of FormMissing -> return () diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index d34542f87..cd62c1333 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -179,6 +179,7 @@ makeCourseTable whereClause colChoices psValidator = do , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing ] , dbtStyle = def + , dbtParams = def , dbtIdent = "courses" :: Text } @@ -194,7 +195,7 @@ getCourseListR = do ] whereClause = const $ E.val True validator = def - & defaultSorting [("course", SortAsc), ("term", SortDesc)] + & defaultSorting [SortAscBy "course", SortDescBy "term"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle @@ -225,7 +226,7 @@ getTermSchoolCourseListR tid ssh = do course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh validator = def - & defaultSorting [("cshort", SortAsc)] + & defaultSorting [SortAscBy "cshort"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI $ MsgTermSchoolCourseListTitle tid school @@ -247,7 +248,7 @@ getTermCourseListR tid = do ] whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid validator = def - & defaultSorting [("cshort", SortAsc)] + & defaultSorting [SortAscBy "cshort"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f5bd47c51..abde50485 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -99,6 +99,7 @@ homeAnonymous = do ] -} , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def , dbtIdent = "upcomingdeadlines" :: Text } -- let features = $(widgetFile "featureList") @@ -167,7 +168,7 @@ homeUser uid = do (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) tickmark ] - let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] + let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"] sheetTable <- runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade @@ -201,6 +202,7 @@ homeUser uid = do ] -} , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } + , dbtParams = def , dbtIdent = "upcomingdeadlines" :: Text } -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 410f6862a..cb487fcc8 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -262,7 +262,7 @@ mkOwnedCoursesTable = courseCellCL <$> view _dbrOutput ] - validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ] + validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ] dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) @@ -274,6 +274,7 @@ mkOwnedCoursesTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty + dbtParams = def in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} @@ -285,7 +286,7 @@ mkEnrolledCoursesTable = -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) withType = id - validator = def & defaultSorting [("time",SortDesc)] + validator = def & defaultSorting [SortDescBy "time"] in \uid -> dbTableWidget' validator DBTable @@ -322,6 +323,7 @@ mkEnrolledCoursesTable = ] , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def } @@ -385,7 +387,7 @@ mkSubmissionTable = validator = def -- DUPLICATED CODE: Handler.Corrections & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") - & defaultSorting [("edit",SortDesc)] + & defaultSorting [SortDescBy "edit"] dbtSorting' uid = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) @@ -399,6 +401,7 @@ mkSubmissionTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty + dbtParams = def in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} @@ -455,7 +458,7 @@ mkSubmissionGroupTable = validator = def -- DUPLICATED CODE: Handler.Corrections & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") - & defaultSorting [("edit",SortDesc)] + & defaultSorting [SortDescBy "edit"] dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) @@ -469,6 +472,7 @@ mkSubmissionGroupTable = , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty + dbtParams = def in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} @@ -529,7 +533,7 @@ mkCorrectionsTable = int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue) ] - validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)] + validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"] dbtSorting = Map.fromList [ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) @@ -543,6 +547,7 @@ mkCorrectionsTable = , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) ] dbtFilterUI = mempty + dbtParams = def in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a1ec6ad96..ccacabe32 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do ] psValidator = def - & defaultSorting [("submission-since", SortAsc)] + & defaultSorting [SortAscBy "submission-since"] (table,raw_statistics) <- runDB $ liftA2 (,) (dbTableWidget' psValidator DBTable @@ -236,6 +236,7 @@ getSheetListR tid ssh csh = do , dbtFilter = mempty , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def , dbtIdent = "sheets" :: Text } ) ( @@ -298,7 +299,7 @@ getSShowR tid ssh csh shn = do , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def - & defaultSorting [("type", SortAsc), ("path", SortAsc)] + & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles @@ -319,6 +320,7 @@ getSShowR tid ssh csh shn = do , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) ] + , dbtParams = def } (hasHints, hasSolution) <- runDB $ do hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 7129dfeeb..a38b191e1 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -312,6 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do ] , dbtFilter = mempty , dbtFilterUI = mempty + , dbtParams = def } mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index a71104eff..96fe43cf7 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -13,6 +13,8 @@ import Handler.Utils import Utils.Lens +import qualified Database.Esqueleto as E + htmlField' :: Field (HandlerT UniWorX IO) Html htmlField' = htmlField @@ -154,7 +156,7 @@ postMessageListR = do let dbtSQLQuery = return dbtColonnade = mconcat - [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId + [ dbSelect _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 @@ -173,28 +175,46 @@ postMessageListR = do { dbrOutput = (smE, smT) , .. } - psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) - tableForm <- runDB $ dbTable psValidator DBTable + psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) + (tableRes', tableView) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery , dbtColonnade , dbtProj - , dbtSorting = mempty -- TODO: from, to, authenticated, severity + , dbtSorting = Map.fromList + [ ( "from" + , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom + ) + , ( "to" + , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo + ) + , ( "authenticated" + , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly + ) + , ( "severity" + , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity + ) + ] , dbtFilter = mempty , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def + { dbParamsFormAction = Just $ SomeRoute MessageListR + , dbParamsFormAddSubmit = True + , dbParamsFormAdditional = \frag -> do + now <- liftIO getCurrentTime + let actions = Map.fromList + [ (SMDelete, pure SMDDelete) + , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) + , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) + ] + (actionRes, action) <- multiAction actions (Just SMActivate) + return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) + } , dbtIdent = "messages" :: Text } - ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do - (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf - now <- liftIO getCurrentTime - let actions = Map.fromList - [ (SMDelete, pure SMDDelete) - , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) - , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) - ] - (actionRes, action) <- multiAction actions (Just SMActivate) - $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes) - return ((,) <$> actionRes <*> selectionRes, table <> action) + + let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast case tableRes of FormMissing -> return () diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 0b1e67100..358d31ef8 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -128,6 +128,7 @@ getTermShowR = do ] , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def , dbtIdent = "terms" :: Text } defaultLayout $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d3a9a1d50..e2f0fbbdd 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -67,7 +67,7 @@ getUsersR = do |] ] psValidator = def - & defaultSorting [("name", SortAsc),("display-name", SortAsc)] + & defaultSorting [SortAscBy "name", SortAscBy "display-name"] ((), userList) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) @@ -87,6 +87,7 @@ getUsersR = do , dbtFilter = mempty , dbtFilterUI = mempty , dbtStyle = def + , dbtParams = def , dbtIdent = "users" :: Text } diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 170d52bbd..872294986 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,15 +1,18 @@ module Handler.Utils.Table.Pagination - ( SortColumn(..), SortDirection(..) + ( module Handler.Utils.Table.Pagination.Types + , SortColumn(..), SortDirection(..) + , pattern SortAscBy, pattern SortDescBy , FilterColumn(..), IsFilterColumn , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) + , DBParams(..) , cellAttrs, cellContents , PaginationSettings(..), PaginationInput(..), piIsUnset , PSValidator(..) , defaultFilter, defaultSorting , restrictFilter, restrictSorting - , ToSortable(..), Sortable(..), sortable + , ToSortable(..), Sortable(..) , dbTable , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade @@ -38,9 +41,6 @@ import qualified Data.Binary.Builder as Builder import qualified Network.Wai as Wai -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI - import Control.Monad.RWS hiding ((<>), mapM_) import Control.Monad.Writer hiding ((<>), mapM_) import Control.Monad.Reader (ReaderT(..), mapReaderT) @@ -65,18 +65,21 @@ import Data.Aeson (Options(..), defaultOptions, decodeStrict') import Data.Aeson.Text import Data.Aeson.TH (deriveJSON) +import qualified Data.Text as Text + data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc - deriving (Eq, Ord, Enum, Show, Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +instance Universe SortDirection +instance Finite SortDirection + instance PathPiece SortDirection where toPathPiece SortAsc = "asc" toPathPiece SortDesc = "desc" - fromPathPiece (CI.mk -> t) - | t == "asc" = Just SortAsc - | t == "desc" = Just SortDesc - | otherwise = Nothing + fromPathPiece = finiteFromPathPiece deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 @@ -87,6 +90,29 @@ sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t +data SortingSetting = SortingSetting + { sortKey :: SortingKey + , sortDir :: SortDirection + } deriving (Eq, Ord, Show, Read) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''SortingSetting + +instance PathPiece SortingSetting where + toPathPiece SortingSetting{..} = toPathPiece sortKey <> "-" <> toPathPiece sortDir + fromPathPiece str = do + let sep = "-" + let (Text.dropEnd (Text.length sep) -> key, dir) = Text.breakOnEnd sep str + SortingSetting <$> fromPathPiece key <*> fromPathPiece dir + +pattern SortAscBy :: SortingKey -> SortingSetting +pattern SortAscBy key = SortingSetting key SortAsc + +pattern SortDescBy :: SortingKey -> SortingSetting +pattern SortDescBy key = SortingSetting key SortDesc + + data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool) @@ -111,8 +137,8 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon | otherwise = go (acc, is3 . (i:)) is2 data PaginationSettings = PaginationSettings - { psSorting :: [(CI Text, SortDirection)] - , psFilter :: Map (CI Text) [Text] + { psSorting :: [SortingSetting] + , psFilter :: Map FilterKey [Text] , psLimit :: Int64 , psPage :: Int64 } @@ -132,8 +158,8 @@ deriveJSON defaultOptions } ''PaginationSettings data PaginationInput = PaginationInput - { piSorting :: Maybe [(CI Text, SortDirection)] - , piFilter :: Maybe (Map (CI Text) [Text]) + { piSorting :: Maybe [SortingSetting] + , piFilter :: Maybe (Map FilterKey [Text]) , piLimit :: Maybe Int64 , piPage :: Maybe Int64 } deriving (Eq, Ord, Show, Read, Generic) @@ -194,29 +220,29 @@ instance Default (PSValidator m x) where asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p }) -defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x +defaultFilter :: Map FilterKey [Text] -> PSValidator m x -> PSValidator m x defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' where injectDefault x = case x >>= piFilter of Just _ -> id Nothing -> set (_2._psFilter) psFilter -defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x +defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' where injectDefault x = case x >>= piSorting of Just _ -> id Nothing -> set (_2._psSorting) psSorting -restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x +restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps where restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p } -restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x +restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps where - restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } + restrict' p = p { psSorting = filter (\SortingSetting{..} -> restrict sortKey sortDir) $ psSorting p } data DBEmptyStyle = DBESNoHeading | DBESHeading @@ -244,9 +270,6 @@ instance Default DBStyle where , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default") } -type FilterKey = CI Text -type SortingKey = CI Text - data DBTable m x = forall a r r' h i t. ( ToSortable h, Functor h , E.SqlSelect a r @@ -260,10 +283,12 @@ data DBTable m x = forall a r r' h i t. , dbtFilter :: Map FilterKey (FilterColumn t) , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtStyle :: DBStyle + , dbtParams :: DBParams m x , dbtIdent :: i } -class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where +class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where + data DBParams m x :: * type DBResult m x :: * -- type DBResult' m x :: * @@ -275,7 +300,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget -- | Format @DBTable@ when not short-circuiting dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) - runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) + runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)] cellAttrs = dbCell . _1 @@ -284,6 +309,7 @@ cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget) cellContents = dbCell . _2 instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where + data DBParams (HandlerT UniWorX IO) x = DBParamsWidget type DBResult (HandlerT UniWorX IO) x = (x, Widget) -- type DBResult' (WidgetT UniWorX IO) () = () @@ -299,13 +325,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where -- dbWidget Proxy Proxy = iso (, ()) $ view _1 dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f - runDBTable = liftHandlerT + runDBTable _ _ = liftHandlerT instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where mempty = WidgetCell mempty $ return mempty (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c') +instance Default (DBParams (HandlerT UniWorX IO) x) where + def = DBParamsWidget + instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where + data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget) data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell @@ -320,15 +350,25 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget) - runDBTable = mapReaderT liftHandlerT + runDBTable _ _ = mapReaderT liftHandlerT instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where mempty = DBCell mempty $ return mempty (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c') +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 - -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype) - type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a + data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult 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) + } + 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)) (FormResult a) = (FormResult a, Enctype) data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell @@ -345,15 +385,37 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi - dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form + 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 = return . withFragment + runDBTable dbtable pi = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . (dbParamsFormWrap (dbtParams dbtable)) . addPIHiddenField dbtable pi . withFragment + +instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where + def = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormAddSubmit = False + , dbParamsFormAdditional = \_ -> return mempty + , dbParamsFormEvaluate = liftHandlerT . runFormPost + } + +dbParamsFormWrap :: Monoid a => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) -> Form a -> Form a +dbParamsFormWrap DBParamsForm{..} tableForm frag = do + let form = mappend <$> tableForm frag <*> dbParamsFormAdditional mempty + ((res, fWidget), enctype) <- listen form + return . (res,) $ do + btnId <- newIdent + act <- traverse toTextUrl dbParamsFormAction + let submitField = buttonField BtnSubmit + enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype + $(widgetFile "table/form-wrap") addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet| + $newline never |] where @@ -373,10 +435,10 @@ dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DB dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do let sortingOptions = mkOptionList - [ Option t' (t, d) t' + [ Option t' (SortingSetting t d) t' | (t, _) <- mapToList dbtSorting , d <- [SortAsc, SortDesc] - , let t' = CI.foldedCase t <> "-" <> toPathPiece d + , let t' = toPathPiece $ SortingSetting t d ] wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n @@ -394,7 +456,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db piInput <- lift . runInputGetResult $ PaginationInput <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") - <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) + <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter) <*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "page") @@ -427,7 +489,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db = pi | otherwise = def - psSorting' = map (first (dbtSorting !)) psSorting + psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting mapM_ (addMessageI Warning) errs @@ -454,7 +516,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db filterAction = tblLink $ setParam (wIdent "page") Nothing - . Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter + . Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter table' :: WriterT x m Widget table' = do @@ -463,7 +525,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do widget <- sortableContent ^. cellContents let - directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] + directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ] isSortable = isJust sortableKey isSorted = (`elem` directions) attrs = sortableContent ^. cellAttrs @@ -485,7 +547,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return $(widgetFile "table/layout") - bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table' + bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable dbtable paginationInput . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html tblLayout tbl' = do @@ -585,16 +647,17 @@ instance Ord i => Monoid (DBFormResult r i a) where getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m -formCell :: forall r i a. Ord i - => (r -> MForm (HandlerT UniWorX IO) i) +formCell :: forall res r i a. (Ord i, Monoid res) + => Lens' res (DBFormResult r i a) + -> (r -> MForm (HandlerT UniWorX IO) i) -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) - -> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a))) -formCell genIndex genForm input = FormCell + -> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res)) +formCell resLens genIndex genForm input = FormCell { formCellAttrs = [] , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget) i <- genIndex input (edit, w) <- genForm input i - return (DBFormResult . Map.singleton i . (input,) <$> edit, w) + return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w) } @@ -604,10 +667,11 @@ formCell genIndex genForm input = FormCell dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex -dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i) - => Setter' a Bool +dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res) + => Lens' res (DBFormResult r i a) + -> Setter' a Bool -> (r -> MForm (HandlerT UniWorX IO) i) - -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a))) -dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do + -> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res)) +dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False) - return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|]) + return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|]) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 6bc9e1286..58884b3da 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -1,4 +1,12 @@ -module Handler.Utils.Table.Pagination.Types where +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Handler.Utils.Table.Pagination.Types + ( FilterKey, SortingKey + , Sortable(..) + , sortable + , ToSortable(..) + , SortableP(..) + ) where import Import hiding (singleton) @@ -7,12 +15,23 @@ import Colonnade.Encode import Data.CaseInsensitive (CI) +import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + +newtype FilterKey = FilterKey { _unFilterKey :: CI Text } + deriving (Show, Read) + deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey) +newtype SortingKey = SortingKey { _unSortingKey :: CI Text } + deriving (Show, Read) + deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + data Sortable a = Sortable - { sortableKey :: Maybe (CI Text) + { sortableKey :: Maybe SortingKey , sortableContent :: a } -sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c +sortable :: Maybe SortingKey -> c -> (a -> c) -> Colonnade Sortable a c sortable k h = singleton (Sortable k h) instance Headedness Sortable where diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 868ba4b67..3227bbeb8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -41,6 +41,7 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) +import Data.Monoid as Import (Last(..), First(..)) import Data.Monoid.Instances as Import () import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/templates/corrections-grade.hamlet b/templates/corrections-grade.hamlet index f68d51e69..2d2943787 100644 --- a/templates/corrections-grade.hamlet +++ b/templates/corrections-grade.hamlet @@ -1,5 +1,2 @@
- - ^{table} -