Modularize & clean up homepage

Fixes #306

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
 

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

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|]

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

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 <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
-    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
-              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
-            ^{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")

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 <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
+  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")
+

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
+              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
+            ^{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")

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

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

templates/home.hamlet

@@ -1,5 +0,0 @@
-<div .container>
-  <h2>
-    Kurse mit offener Registrierung
-  <div .container>
-    ^{courseTable}

templates/home/openCourses.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeOpenCourses}
+  ^{courseTable}

templates/home/upcomingSheets.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeUpcomingSheets}
+  ^{sheetTable}

templates/homeUser.hamlet

@@ -1,17 +0,0 @@
-<div .container>
-  <h2>
-    Anstehende Übungsblätter
-  <div .container>
-    ^{sheetTable}
-
-<!--
-<div .container>
-  <h1>
-    Anstehende Klausuren
-  TODO
-
-<div .container>
-  <h1>
-    Anstehende Kursanmeldungen
-  TODO
--->