diff --git a/src/Foundation.hs b/src/Foundation.hs index cd447ff78..fcfca5a29 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -154,6 +154,9 @@ instance RenderMessage UniWorX TermIdentifier where Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX String where + renderMessage f ls str = renderMessage f ls $ Text.pack str + -- Access Control data AccessPredicate diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 54617fa19..9a12cf70e 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} module Handler.Sheet where @@ -23,7 +24,7 @@ import qualified Data.Text as T -- import Data.Function ((&)) -- import Colonnade hiding (fromMaybe, singleton) -import Yesod.Colonnade +import qualified Yesod.Colonnade as Yesod -- import qualified Data.UUID.Cryptographic as UUID import qualified Data.Conduit.List as C @@ -180,7 +181,7 @@ getSheetList courseEnt = do setTitle $ toHtml $ T.append "Übungsblätter " csh if null sheets then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] - else encodeWidgetTable tableDefault colSheets sheets + else Yesod.encodeWidgetTable tableDefault colSheets sheets -- Show single sheet @@ -211,12 +212,14 @@ getSShowR tid csh shn = do E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) - let colonnadeFiles = mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) - (\(E.Value fName,_,_) -> str2widget fName) - , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime) - ] + let + colonnadeFiles :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) + colonnadeFiles = mconcat + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype + , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) + (\(E.Value fName,_,_) -> str2widget fName) + , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime) + ] fileTable <- dbTable def $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3d738fe32..4b1a211bc 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -13,6 +13,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} module Handler.Submission where @@ -49,7 +50,7 @@ import Data.Bifunctor import System.FilePath import Colonnade hiding (bool) -import Yesod.Colonnade +import qualified Yesod.Colonnade as Yesod import qualified Text.Blaze.Html5.Attributes as HA @@ -236,7 +237,8 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do let formText = Nothing :: Maybe UniWorXMessage actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute -- Maybe construct a table to display uploaded archive files - let colonnadeFiles cid = mconcat + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) + colonnadeFiles cid = mconcat -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle) (\(Entity _ File{..}) -> str2widget fileTitle) @@ -356,9 +358,9 @@ submissionTable = do anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID colonnade = mconcat - [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText - , headed "Kurs" $ anchorCell anchorCourse courseText - , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName + [ headed "Abgabe-ID" $ Yesod.anchorCell anchorSubmission submissionText + , headed "Kurs" $ Yesod.anchorCell anchorCourse courseText + , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> Yesod.textCell $ sheetName ] toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission toExternal (_, cID, _) = return cID diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f09bc9e9a..683c87e9b 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -7,6 +7,7 @@ , MultiParamTypeClasses , TypeFamilies , FlexibleContexts + , PartialTypeSignatures #-} module Handler.Term where @@ -18,7 +19,6 @@ import Handler.Utils import Yesod.Form.Bootstrap3 import Colonnade hiding (bool) -import Yesod.Colonnade import qualified Database.Esqueleto as E @@ -41,33 +41,35 @@ getTermShowR = do selectRep $ do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do - let colonnadeTerms = mconcat - [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do - -- Scrap this if to slow, create term edit page instead - adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False - [whamlet| - $if adminLink == Authorized - - #{termToText termName} - $else - #{termToText termName} - |] - , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> - stringCell $ formatTimeGerWD termLectureStart - , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> - stringCell $ formatTimeGerWD termLectureEnd - , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> - textCell $ bool "" tickmark termActive - , sortable Nothing "Kursliste" $ anchorCell - (\(Entity tid _, _) -> TermCourseListR tid) - (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|]) - , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> + let + colonnadeTerms :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) + colonnadeTerms = mconcat + [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do + -- Scrap this if to slow, create term edit page instead + adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False + [whamlet| + $if adminLink == Authorized + + #{termToText termName} + $else + #{termToText termName} + |] + , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> + stringCell $ formatTimeGerWD termLectureStart + , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> + stringCell $ formatTimeGerWD termLectureEnd + , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> + textCell $ (bool "" tickmark termActive :: Text) + , sortable Nothing "Kursliste" $ anchorCell + (\(Entity tid _, _) -> TermCourseListR tid) + (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|]) + , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termStart - , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> + , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termEnd - , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays - ] + ] table <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 03b46992f..c0a606175 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -10,29 +10,32 @@ , FlexibleInstances , MultiParamTypeClasses , TypeFamilies + , ScopedTypeVariables + , TupleSections + , RankNTypes #-} module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn , DBRow(..), DBOutput - , DBTable(..) + , DBTable(..), IsDBTable(..) , PaginationSettings(..) , PSValidator(..) , Sortable(..), sortable , dbTable + , textCell, stringCell, anchorCell ) where import Handler.Utils.Table.Pagination.Types -import Import +import Import hiding (Proxy(..)) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Language as E (From) import Text.Blaze (Attribute) import qualified Text.Blaze.Html5.Attributes as Html5 import qualified Text.Blaze.Html5 as Html5 -import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..)) import qualified Data.Binary.Builder as Builder @@ -42,6 +45,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) +import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) import Data.Map (Map, (!)) import qualified Data.Map as Map @@ -50,12 +54,15 @@ import Data.Profunctor (lmap) import Colonnade hiding (bool, fromMaybe, singleton) import Colonnade.Encode -import Yesod.Colonnade import Text.Hamlet (hamletFile) import Data.Ratio ((%)) +import Control.Lens + +import Data.Proxy + data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } @@ -106,28 +113,28 @@ data DBRow r = DBRow class DBOutput r r' where dbProj :: r -> r' -instance DBOutput r r where +instance DBOutput (DBRow r) (DBRow r) where dbProj = id instance DBOutput (DBRow r) r where dbProj = dbrOutput instance DBOutput (DBRow r) (Int64, r) where dbProj = (,) <$> dbrIndex <*> dbrOutput - -data DBTable = forall a r r' h i t. +data DBTable m x = forall a r r' h i t. ( ToSortable h, Functor h , E.SqlSelect a r, DBOutput (DBRow r) r' , PathPiece i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable { dbtSQLQuery :: t -> E.SqlQuery a - , dbtColonnade :: Colonnade h r' (Cell UniWorX) + , dbtColonnade :: Colonnade h r' (DBCell m x) , dbtSorting :: Map Text (SortColumn t) , dbtFilter :: Map Text (FilterColumn t) - , dbtAttrs :: Attribute + , dbtAttrs :: Attribute -- FIXME: currently unused , dbtIdent :: i } + data PaginationSettings = PaginationSettings { psSorting :: [(Text, SortDirection)] , psFilter :: Map Text [Text] @@ -145,9 +152,9 @@ instance Default PaginationSettings where , psShortcircuit = False } -newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } +newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } -instance Default PSValidator where +instance Default (PSValidator m x) where def = PSValidator $ \DBTable{..} -> \case Nothing -> def Just ps -> swap . (\act -> execRWS act () ps) $ do @@ -156,8 +163,59 @@ instance Default PSValidator where modify $ \ps -> ps { psLimit = psLimit def } tell . pure $ SomeMessage MsgPSLimitNonPositive +class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where + type DBResult m x :: * + type DBResult' m x :: * -dbTable :: PSValidator -> DBTable -> Handler Widget + data DBCell m x :: * + cellAttrs :: Lens' (DBCell m x) [(Text, Text)] + cellContents :: DBCell m x -> WriterT x m Widget + + cell :: Widget -> DBCell m x + + + dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) + runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (Widget, x) -> m' (DBResult m x) + +instance IsDBTable (WidgetT UniWorX IO) () where + type DBResult (WidgetT UniWorX IO) () = Widget + type DBResult' (WidgetT UniWorX IO) () = () + + data DBCell (WidgetT UniWorX IO) () = WidgetCell + { dbCellAttrs :: [(Text, Text)] + , dbCellContents :: Widget + } + cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as } + cellContents = return . dbCellContents + + cell = WidgetCell [] + + dbWidget Proxy Proxy = iso (, ()) $ view _1 + runDBTable = return . join . fmap (view _1) + +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) = (FormResult a, Enctype) + + data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell + { formCellAttrs :: [(Text, Text)] + , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) + } + cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as } + cellContents = WriterT . fmap swap . formCellContents + + cell widget = FormCell [] $ return (mempty, widget) + + dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) + ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) + -- runDBTable :: MForm (HandlerT UniWorX IO) (Widget, FormResult a) -> m ((FormResult a, Widget), Enctype) + runDBTable = undefined -- use runFormPost + +instance IsDBTable m a => IsString (DBCell m a) where + fromString = cell . fromString + + +dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x) dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do let sortingOptions = mkOptionList @@ -214,23 +272,39 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), | otherwise = 0 rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows' - bool return (sendResponse <=< tblLayout) psShortcircuit $ do - getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest - let table = $(widgetFile "table/colonnade") - pageCount = max 1 . ceiling $ rowCount % psLimit - pageNumbers = [0..pred pageCount] + table' :: WriterT x m Widget + table' = do + getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + + let tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams - withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell - { cellContents = $(widgetFile "table/sortable-header") - , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs - } - where + genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do + widget <- cellContents sortableContent + let directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] - sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions - toAttr SortAsc = ["sorted-asc"] - toAttr SortDesc = ["sorted-desc"] - $(widgetFile "table/layout") + isSortable = isJust sortableKey + isSorted = (`elem` directions) + attrs = sortableContent ^. cellAttrs + return $(widgetFile "table/cell/header") + + wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable + + wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do + widget <- cellContents cell + let attrs = cell ^. cellAttrs + return $(widgetFile "table/cell/body") + + let table = $(widgetFile "table/colonnade") + pageCount = max 1 . ceiling $ rowCount % psLimit + pageNumbers = [0..pred pageCount] + + return $(widgetFile "table/layout") + + dbWidget' :: Iso' (DBResult m x) (Widget, DBResult' m x) + dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x) + + bool return (sendResponse <=< tblLayout . view (dbWidget' . _1)) psShortcircuit <=< runDBTable $ runWriterT table' where tblLayout :: Widget -> Handler Html tblLayout tbl' = do @@ -240,22 +314,17 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] -widgetFromCell :: - (Attribute -> WidgetT site IO () -> WidgetT site IO ()) - -> Cell site - -> WidgetT site IO () -widgetFromCell f (Cell attrs contents) = - f attrs contents -td,th :: - Attribute -> WidgetT site IO () -> WidgetT site IO () +--- DBCell utility functions -td = liftParent Html5.td -th = liftParent Html5.th +textCell, stringCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a +stringCell = textCell +textCell msg = cell [whamlet|_{msg}|] -liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a -liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do - (a,gwd) <- f hdata - let Body bodyFunc = gwdBody gwd - newBodyFunc render = - el Html5.! attrs $ (bodyFunc render) - return (a,gwd { gwdBody = Body newBodyFunc }) +anchorCell :: IsDBTable m a + => (r -> Route UniWorX) + -> (r -> Widget) + -> (r -> DBCell m a) +anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link") + where + route = mkRoute val + widget = mkWidget val diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 1c0c883d6..416079055 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -40,4 +40,3 @@ instance ToSortable Headed where instance ToSortable Headless where pSortable = Nothing - diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet new file mode 100644 index 000000000..6c36d333f --- /dev/null +++ b/templates/table/cell/body.hamlet @@ -0,0 +1,2 @@ + + ^{widget} diff --git a/templates/table/cell/header.hamlet b/templates/table/cell/header.hamlet new file mode 100644 index 000000000..d8e5b6cd4 --- /dev/null +++ b/templates/table/cell/header.hamlet @@ -0,0 +1,11 @@ + + $maybe flag <- sortableKey + $case directions + $of [SortAsc] + "-desc")}> + ^{widget} + $of _ + "-asc")}> + ^{widget} + $nothing + ^{widget} diff --git a/templates/table/cell/link.hamlet b/templates/table/cell/link.hamlet new file mode 100644 index 000000000..21ce1108a --- /dev/null +++ b/templates/table/cell/link.hamlet @@ -0,0 +1,2 @@ + + ^{widget} diff --git a/templates/table/colonnade.hamlet b/templates/table/colonnade.hamlet index 189d195b4..e9877a5cd 100644 --- a/templates/table/colonnade.hamlet +++ b/templates/table/colonnade.hamlet @@ -1,18 +1,13 @@ $newline never - $maybe sortableP <- pSortable - $with toSortable <- toSortable sortableP - - - $forall OneColonnade{..} <- getColonnade dbtColonnade - - - ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead} + $maybe wHeaders' <- wHeaders + + + $forall widget <- wHeaders' + ^{widget} $nothing - $forall row <- rows + $forall row <- wRows - $forall OneColonnade{..} <- getColonnade dbtColonnade - - - ^{widgetFromCell td $ oneColonnadeEncode row} + $forall widget <- row + ^{widget}