Work on #39

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):

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
 

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)

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
     }

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

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
     }

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{..}
 

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"

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
 

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
     }

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
         }

src/Handler/Users.hs

@@ -85,6 +85,7 @@ getUsersR = do
           )
         ]
     , dbtFilter    = mempty
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtIdent     = "users" :: Text
     }

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|
+      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
+    |]
+    fieldEnctype = UrlEncoded
+
 
 funcForm :: forall k v m.
             ( Finite k, Ord k

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)

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(..))
 

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

templates/table/layout-filter-default.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<section>
+  <form method=GET action=#{filterAction} enctype=#{filterEnctype}>
+    ^{filterWgdt}
+<section>
+  ^{scrolltable}

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
       <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>