{-# LANGUAGE NoImplicitPrelude , OverloadedStrings , OverloadedLists , RecordWildCards , TemplateHaskell , QuasiQuotes , MultiParamTypeClasses , TypeFamilies , FlexibleContexts , PartialTypeSignatures #-} module Handler.Term where import Import import Handler.Utils -- import qualified Data.Text as T import Yesod.Form.Bootstrap3 import Colonnade hiding (bool) import qualified Database.Esqueleto as E getTermShowR :: Handler TypedContent getTermShowR = do -- terms <- runDB $ selectList [] [Desc TermStart] ------- ÄQUIVALENT: -- term <- runDB $ E.select . E.from $ \(term) -> do -- E.orderBy [E.desc $ term E.^. TermStart ] -- return term -- let termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64)) termData term = do -- E.orderBy [E.desc $ term E.^. TermStart ] let courseCount = E.sub_select . E.from $ \course -> do E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm return E.countRows return (term, courseCount) selectRep $ do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = widgetColonnade $ mconcat [ sortable Nothing "Kürzel" $ anchorCell (\(Entity tid _, _) -> TermCourseListR tid) (\(Entity tid _, _) -> [whamlet|#{display tid}|]) , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(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 "Kurse" $ \(_, E.Value numCourses) -> cell [whamlet|_{MsgNumCourses numCourses}|] , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termStart , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termEnd , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays ] -- let adminColonnade = -- [ sortable Nothing "Edit" $ \(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} -- |] -- ] table <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtSorting = [ ( "start" , SortColumn $ \term -> term E.^. TermStart ) , ( "end" , SortColumn $ \term -> term E.^. TermEnd ) , ( "lecture-start" , SortColumn $ \term -> term E.^. TermLectureStart ) , ( "lecture-end" , SortColumn $ \term -> term E.^. TermLectureEnd ) ] , dbtFilter = [ ( "active" , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) ) , ( "course" , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are [] -> E.val True :: E.SqlExpr (E.Value Bool) cshs -> E.exists . E.from $ \course -> do E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs ) ] , dbtAttrs = tableDefault , dbtIdent = "terms" :: Text } defaultLayout $ do setTitle "Freigeschaltete Semester" $(widgetFile "terms") getTermEditR :: Handler Html getTermEditR = do -- TODO: Defaults für Semester hier ermitteln und übergeben termEditHandler Nothing postTermEditR :: Handler Html postTermEditR = termEditHandler Nothing getTermEditExistR :: TermId -> Handler Html getTermEditExistR tid = do term <- runDB $ get tid termEditHandler term termEditHandler :: Maybe Term -> Handler Html termEditHandler term = do ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term case result of (FormSuccess res) -> do let tid = TermKey $ termName res -- term <- runDB $ get $ TermKey termName runDB $ repsert tid res -- VOR INTERNATIONALISIERUNG: -- let tid = termToText $ termName res -- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." -- addMessage "success" [shamlet| #{msg} |] -- MIT INTERNATIONALISIERUNG: addMessageI "success" $ MsgTermEdited tid redirect TermShowR (FormMissing ) -> return () (FormFailure _) -> addMessageI "warning" MsgInvalidInput let actionUrl = TermEditR defaultLayout $ do setTitleI MsgTermEditHeading $(widgetFile "formPage") newTermForm :: Maybe Term -> Form Term newTermForm template html = do renderMessage <- getMessageRender (result, widget) <- flip (renderAForm FormStandard) html $ Term <$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName <$> template) <*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template) <*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template) <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined <*> areq dayField (fsl "Beginn Vorlesungen") (termLectureStart <$> template) <*> areq dayField (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd <$> template) <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template) <* submitButton return $ case result of FormSuccess termResult | errorMsgs <- validateTerm termResult , not $ null errorMsgs -> (FormFailure errorMsgs, [whamlet|

Fehler:
    $forall errmsg <- errorMsgs
  • #{errmsg} ^{widget} |] ) _ -> (result, widget) {- where set :: Text -> FieldSettings site set = bfs -}