Cleanup

src/Foundation.hs

@@ -61,16 +61,6 @@ data UniWorX = UniWorX
     , appCryptoIDKey :: CryptoIDKey
     }
 
-data MenuItem = MenuItem
-    { menuItemLabel :: Text
-    , menuItemRoute :: Route UniWorX
-    , menuItemAccessCallback :: Bool
-    }
-
-data MenuTypes
-    = NavbarLeft  MenuItem
-    | NavbarRight MenuItem
-
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -85,6 +75,17 @@ data MenuTypes
 -- type Widget = WidgetT UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+data MenuItem = MenuItem
+    { menuItemLabel :: Text
+    , menuItemRoute :: Route UniWorX
+    , menuItemAccessCallback :: Handler Bool
+    }
+
+data MenuTypes
+    = NavbarLeft  { menuItem :: MenuItem }
+    | NavbarRight { menuItem :: MenuItem }
+    | NavbarExtra { menuItem :: MenuItem }
+
 -- | A convenient synonym for creating forms.
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 
@@ -113,7 +114,7 @@ instance Yesod UniWorX where
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
     yesodMiddleware = defaultYesodMiddleware
 
-    defaultLayout = defaultMenuLayout defaultLinks
+    defaultLayout = defaultLinkLayout []
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
@@ -206,57 +207,49 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb  _ = return ("home", Nothing)
 
   
-defaultLinks :: Maybe (UserId, User) -> [MenuTypes]
+defaultLinks :: [MenuTypes]
-defaultLinks muser = -- Define the menu items of the header.
+defaultLinks = -- Define the menu items of the header.
   [ NavbarLeft $ MenuItem
       { menuItemLabel = "Home"
       , menuItemRoute = HomeR
-      , menuItemAccessCallback = True
+      , menuItemAccessCallback = return True
       }
   , NavbarLeft $ MenuItem
       { menuItemLabel = "Kurse"
       , menuItemRoute = CourseListR
-      , menuItemAccessCallback = True
+      , menuItemAccessCallback = return True
       }                    
   , NavbarRight $ MenuItem
       { menuItemLabel = "Profile"
       , menuItemRoute = ProfileR
-      , menuItemAccessCallback = isJust muser
+      , menuItemAccessCallback = isJust <$> maybeAuthPair
       }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Login"
       , menuItemRoute = AuthR LoginR
-      , menuItemAccessCallback = isNothing muser
+      , menuItemAccessCallback = isNothing <$> maybeAuthPair
       }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Logout"
       , menuItemRoute = AuthR LogoutR
-      , menuItemAccessCallback = isJust muser
+      , menuItemAccessCallback = isJust <$> maybeAuthPair
       }
   ]
 
-defaultLinkLayout :: (Maybe (UserId, User) -> [MenuTypes]) -> Widget -> Handler Html
+defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html
-defaultLinkLayout menu = defaultMenuLayout defaultsPlusMenu
+defaultLinkLayout = defaultMenuLayout . (defaultLinks ++)
-  where 
-    defaultsPlusMenu = (++) <$> defaultLinks <*> menu
 
-defaultMenuLayout :: (Maybe (UserId, User) -> [MenuTypes]) 
+defaultMenuLayout :: [MenuTypes] -> Widget -> Handler Html
-                          -> Widget -> Handler Html
 defaultMenuLayout menu widget = do
     master <- getYesod
     mmsgs <- getMessages
 
-    muser <- maybeAuthPair
     mcurrentRoute <- getCurrentRoute
 
     -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
     (title, parents) <- breadcrumbs
 
-    let menuItems = menu muser
+    menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
-    let navbarLeftMenuItems  = [x | NavbarLeft  x <- menuItems]
-    let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
-    let navbarLeftFilteredMenuItems  = [x | x <- navbarLeftMenuItems , menuItemAccessCallback x]
-    let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
 
     -- We break up the default layout into two components:
     -- default-layout is the contents of the body tag, and

src/Handler/Course.hs

@@ -60,12 +60,11 @@ getCourseListTermR tidini = do
               |]
           )  
         ]
-  allowedNew <- isAuthorized CourseEditR False
+  let pageLinks = 
-  let pageLinks muser = 
         [ NavbarLeft $ MenuItem
           { menuItemLabel = "Neuer Kurs"
           , menuItemRoute = CourseEditR
-          , menuItemAccessCallback = Authorized == allowedNew
+          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseEditR False
           }
         ] 
   defaultLinkLayout pageLinks $ do

src/Handler/Utils/StudyFeatures.hs

@@ -8,8 +8,6 @@ module Handler.Utils.StudyFeatures
 
 import Import.NoFoundation hiding (try, (<|>))
 
-import Data.Bifunctor
-
 import Text.Parsec
 import Text.Parsec.Text
 

templates/default-layout.hamlet

@@ -11,14 +11,23 @@
 
         <div #navbar .collapse.navbar-collapse>
             <ul .nav.navbar-nav>
-                $forall MenuItem label route _ <- navbarLeftFilteredMenuItems
+                $forall menuType <- menuTypes
-                    <li :Just route == mcurrentRoute:.active>
+                  $case menuType
-                        <a href="@{route}">#{label}
+                    $of NavbarLeft (MenuItem label route _)
+                      <li :Just route == mcurrentRoute:.active>
+                        <a href=@{route}>#{label}
+                    $of NavbarExtra (MenuItem label route _)
+                      <li :Just route == mcurrentRoute:.active>
+                        <a href=@{route}>#{label}
+                    $of _
 
             <ul .nav.navbar-nav.navbar-right>
-                $forall MenuItem label route _ <- navbarRightFilteredMenuItems
+                $forall menuType <- menuTypes
-                    <li :Just route == mcurrentRoute:.active>
+                  $case menuType
-                        <a href="@{route}">#{label}
+                    $of NavbarRight (MenuItem label route _)
+                      <li :Just route == mcurrentRoute:.active>
+                        <a href=@{route}>#{label}
+                    $of _
 
 <!-- Page Contents -->