diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7d51240f3..da8e563fa 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -273,6 +273,9 @@ DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen +HomeOpenCourses: Kurse mit offener Registrierung +HomeUpcomingSheets: Anstehende Übungsblätter + NumCourses num@Int64: #{display num} Kurse CloseAlert: Schliessen diff --git a/src/Application.hs b/src/Application.hs index 1dd037aba..20824d216 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -76,6 +76,8 @@ import qualified Database.Memcached.Binary.IO as Memcached -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common import Handler.Home +import Handler.Info +import Handler.Help import Handler.Profile import Handler.Users import Handler.Admin diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs new file mode 100644 index 000000000..f151b6c18 --- /dev/null +++ b/src/Data/List/NonEmpty/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.List.NonEmpty.Instances + ( + ) where + +import Data.List.NonEmpty + +import Language.Haskell.TH.Syntax (Lift(..)) + +instance Lift a => Lift (NonEmpty a) where + lift (toList -> xs) = [e|fromList xs|] diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs new file mode 100644 index 000000000..39c1f5381 --- /dev/null +++ b/src/Handler/Help.hs @@ -0,0 +1,67 @@ +module Handler.Help where + +import Import +import Handler.Utils +import Jobs + +import qualified Data.Map as Map + +data HelpIdentOptions = HIUser | HIEmail | HIAnonymous + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance Universe HelpIdentOptions +instance Finite HelpIdentOptions + +nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) +embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") + +data HelpForm = HelpForm + { hfReferer:: Maybe (Route UniWorX) + , hfUserId :: Either (Maybe Address) UserId + , hfRequest:: Text + } + +helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm +helpForm mReferer mUid = HelpForm + <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) + <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) + where + identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) + identActions = Map.fromList $ case mUid of + (Just uid) -> (HIUser, pure $ Right uid):defaultActions + Nothing -> defaultActions + + defaultActions = + [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) + , (HIAnonymous, pure $ Left Nothing) + ] + +getHelpR, postHelpR :: Handler Html +getHelpR = postHelpR +postHelpR = do + mUid <- maybeAuthId + mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) + isModal <- hasCustomHeader HeaderIsModal + + ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid + let form = wrapForm formWidget def + { formAction = Just $ SomeRoute HelpR + , formEncoding = formEnctype + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } + + formResultModal res HelpR $ \HelpForm{..} -> do + now <- liftIO getCurrentTime + hfReferer' <- traverse toTextUrl hfReferer + queueJob' JobHelpRequest + { jSender = hfUserId + , jHelpRequest = hfRequest + , jRequestTime = now + , jReferer = hfReferer' + } + tell . pure =<< messageI Success MsgHelpSent + + defaultLayout $ do + setTitleI MsgHelpTitle + $(widgetFile "help") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 7b60a6da3..dba365b9c 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,23 +4,20 @@ import Import import Handler.Utils import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Database.Esqueleto as E -import Jobs -import Development.GitRev - getHomeR :: Handler Html getHomeR = do muid <- maybeAuthId - case muid of - Nothing -> homeAnonymous - Just uid -> homeUser uid + defaultLayout $ do + setTitleI MsgHomeHeading + maybe mempty homeUpcomingSheets muid + homeOpenCourses -homeAnonymous :: Handler Html -homeAnonymous = do +homeOpenCourses :: Widget +homeOpenCourses = do cTime <- liftIO getCurrentTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) @@ -47,7 +44,7 @@ homeAnonymous = do , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- runDB $ dbTableWidget' def DBTable + courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable { dbtSQLQuery = tableData , dbtRowKey = (E.^. CourseId) , dbtColonnade = colonnade @@ -75,16 +72,12 @@ homeAnonymous = do , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "open-courses" :: Text } - -- let features = $(widgetFile "featureList") - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" - defaultLayout - -- (widgetFile "dsgvDisclaimer") - $(widgetFile "home") + $(widgetFile "home/openCourses") -homeUser :: Key User -> Handler Html -homeUser uid = do +homeUpcomingSheets :: UserId -> Widget +homeUpcomingSheets uid = do cTime <- liftIO getCurrentTime let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) @@ -140,7 +133,7 @@ homeUser uid = do (toWidget $ hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] - sheetTable <- runDB $ dbTableWidget' validator DBTable + sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade @@ -175,155 +168,6 @@ homeUser uid = do , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "upcoming-sheets" :: Text } - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." - defaultLayout $ - -- setTitle "Willkommen zum Uni2work Test!" - $(widgetFile "homeUser") - -- (widgetFile "dsgvDisclaimer") - --- | Versionsgeschichte -getVersionR :: Handler TypedContent -getVersionR = getInfoR -- TODO - --- | Impressum -getImpressumR :: Handler Html -getImpressumR = -- do - siteLayoutMsg' MsgMenuImpressum $ do - setTitleI MsgImpressumHeading - $(i18nWidgetFile "imprint") - - --- | Hinweise zu Datenschutz und Aufbewahrungspflichten -getDataProtR :: Handler Html -getDataProtR = -- do - siteLayoutMsg' MsgMenuDataProt $ do - setTitleI MsgDataProtHeading - $(i18nWidgetFile "data-protection") - - --- | Allgemeine Informationen -getInfoR :: Handler TypedContent -getInfoR = selectRep $ do - let infoHeading = [whamlet|Re-Implementierung von UniWorX|] - provideRep . siteLayout infoHeading $ do - let features = $(widgetFile "featureList") - gitInfo :: Text - gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" - changeLog <- withUrlRenderer $(textFile "ChangeLog.md") - $(widgetFile "versionHistory") - provideRep $ - return ($gitDescribe :: Text) - - - - -data HelpIdentOptions = HIUser | HIEmail | HIAnonymous - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance Universe HelpIdentOptions -instance Finite HelpIdentOptions - -nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) -embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") - -data HelpForm = HelpForm - { hfReferer:: Maybe (Route UniWorX) - , hfUserId :: Either (Maybe Address) UserId - , hfRequest:: Text - } - -helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm -helpForm mReferer mUid = HelpForm - <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) - <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) - where - identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) - identActions = Map.fromList $ case mUid of - (Just uid) -> (HIUser, pure $ Right uid):defaultActions - Nothing -> defaultActions - - defaultActions = - [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) - , (HIAnonymous, pure $ Left Nothing) - ] - -getHelpR, postHelpR :: Handler Html -getHelpR = postHelpR -postHelpR = do - mUid <- maybeAuthId - mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) - isModal <- hasCustomHeader HeaderIsModal - - ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid - let form = wrapForm formWidget def - { formAction = Just $ SomeRoute HelpR - , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] - } - - formResultModal res HelpR $ \HelpForm{..} -> do - now <- liftIO getCurrentTime - hfReferer' <- traverse toTextUrl hfReferer - queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpRequest = hfRequest - , jRequestTime = now - , jReferer = hfReferer' - } - tell . pure =<< messageI Success MsgHelpSent - - defaultLayout $ do - setTitleI MsgHelpTitle - $(widgetFile "help") - - -getInfoLecturerR :: Handler Html -getInfoLecturerR = - siteLayoutMsg' MsgInfoLecturerTitle $ do - setTitleI MsgInfoLecturerTitle - $(i18nWidgetFile "info-lecturer") - - -getAuthPredsR, postAuthPredsR :: Handler Html -getAuthPredsR = postAuthPredsR -postAuthPredsR = do - (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - - 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 <$> funcForm taForm (fslI MsgActiveAuthTags) True - - mReferer <- runMaybeT $ do - param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) - MaybeT . return $ fromPathPiece param - - let authActiveForm = wrapForm authActiveWidget' def - { formAction = Just $ SomeRoute AuthPredsR - , formEncoding = authActiveEnctype - , formSubmit = FormDualSubmit - } - authActiveWidget' - = [whamlet| - $newline never - $maybe referer <- mReferer - - ^{authActiveWidget} - |] - - formResult authActiveRes $ \authTagActive -> do - setSessionJson SessionActiveAuthTags authTagActive - modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) - addMessageI Success MsgAuthPredsActiveChanged - redirect $ fromMaybe AuthPredsR mReferer - - siteLayoutMsg MsgAuthPredsActive $ do - setTitleI MsgAuthPredsActive - $(widgetFile "authpreds") + $(widgetFile "home/upcomingSheets") diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs new file mode 100644 index 000000000..9790ed143 --- /dev/null +++ b/src/Handler/Info.hs @@ -0,0 +1,48 @@ +module Handler.Info where + +import Import +import Handler.Utils + +import Development.GitRev + +-- | Versionsgeschichte +getVersionR :: Handler TypedContent +getVersionR = selectRep $ do + provideRep $ + return ($gitDescribe :: Text) + provideRep getInfoR + +-- | Impressum +getImpressumR :: Handler Html +getImpressumR = -- do + siteLayoutMsg' MsgMenuImpressum $ do + setTitleI MsgImpressumHeading + $(i18nWidgetFile "imprint") + + +-- | Hinweise zu Datenschutz und Aufbewahrungspflichten +getDataProtR :: Handler Html +getDataProtR = -- do + siteLayoutMsg' MsgMenuDataProt $ do + setTitleI MsgDataProtHeading + $(i18nWidgetFile "data-protection") + + +-- | Allgemeine Informationen +getInfoR :: Handler Html +getInfoR = do + let infoHeading = [whamlet|Re-Implementierung von UniWorX|] + siteLayout infoHeading $ do + let features = $(widgetFile "featureList") + gitInfo :: Text + gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" + changeLog <- withUrlRenderer $(textFile "ChangeLog.md") + $(widgetFile "versionHistory") + + +getInfoLecturerR :: Handler Html +getInfoLecturerR = + siteLayoutMsg' MsgInfoLecturerTitle $ do + setTitleI MsgInfoLecturerTitle + $(i18nWidgetFile "info-lecturer") + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d582abf41..5de418a34 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -10,7 +10,7 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -491,3 +491,44 @@ mkCorrectionsTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} + +getAuthPredsR, postAuthPredsR :: Handler Html +getAuthPredsR = postAuthPredsR +postAuthPredsR = do + (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + + 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 <$> funcForm taForm (fslI MsgActiveAuthTags) True + + mReferer <- runMaybeT $ do + param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) + MaybeT . return $ fromPathPiece param + + let authActiveForm = wrapForm authActiveWidget' def + { formAction = Just $ SomeRoute AuthPredsR + , formEncoding = authActiveEnctype + , formSubmit = FormDualSubmit + } + authActiveWidget' + = [whamlet| + $newline never + $maybe referer <- mReferer + + ^{authActiveWidget} + |] + + formResult authActiveRes $ \authTagActive -> do + setSessionJson SessionActiveAuthTags authTagActive + modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) + addMessageI Success MsgAuthPredsActiveChanged + redirect $ fromMaybe AuthPredsR mReferer + + siteLayoutMsg MsgAuthPredsActive $ do + setTitleI MsgAuthPredsActive + $(widgetFile "authpreds") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 7683950d1..3d6f1d4d4 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -10,7 +10,8 @@ import qualified Data.Set as Set import Data.CaseInsensitive (original) -- import qualified Data.CaseInsensitive as CI -import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qRunIO) -- import Language.Haskell.TH.Datatype import Text.Hamlet (shamletFile) @@ -26,6 +27,12 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils +import System.Directory (listDirectory) +import System.FilePath.Posix (takeBaseName) + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty + downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do @@ -140,6 +147,15 @@ warnTermDays tid times = do -- which contains a file for each language, -- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet i18nWidgetFile :: FilePath -> Q Exp -i18nWidgetFile = - -- TODO write code to distinguish languages here - widgetFile . ( "de") +i18nWidgetFile basename = do + let i18nDirectory = "templates" basename + availableFiles <- qRunIO $ listDirectory i18nDirectory + let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles + availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations + + ws <- newName "ws" + letE + [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename l) [] + | l <- unpack <$> NonEmpty.toList availableTranslations' + ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] + ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index dd0861ab9..457682087 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -42,7 +42,8 @@ import GHC.Exts as Import (IsList) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) -import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.List.NonEmpty.Instances as Import () +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 () diff --git a/templates/home.hamlet b/templates/home.hamlet deleted file mode 100644 index 3995b864f..000000000 --- a/templates/home.hamlet +++ /dev/null @@ -1,5 +0,0 @@ -
-

- Kurse mit offener Registrierung -
- ^{courseTable} diff --git a/templates/home/openCourses.hamlet b/templates/home/openCourses.hamlet new file mode 100644 index 000000000..d578cf404 --- /dev/null +++ b/templates/home/openCourses.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeOpenCourses} + ^{courseTable} diff --git a/templates/home/upcomingSheets.hamlet b/templates/home/upcomingSheets.hamlet new file mode 100644 index 000000000..d109294c9 --- /dev/null +++ b/templates/home/upcomingSheets.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeUpcomingSheets} + ^{sheetTable} diff --git a/templates/homeUser.hamlet b/templates/homeUser.hamlet deleted file mode 100644 index 479d27ab9..000000000 --- a/templates/homeUser.hamlet +++ /dev/null @@ -1,17 +0,0 @@ -
-

- Anstehende Übungsblätter -
- ^{sheetTable} - -