Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

routes

@@ -13,7 +13,7 @@
 /term/#TermIdentifier/edit  TermEditExistR    GET
 
 /course/                    CourseListR       GET
-!/course/edit               CourseEditR       GET POST
+!/course/new                CourseEditR       GET POST
 !/course/#TermIdentifier    CourseListTermR   GET
 /course/#TermIdentifier/#Text/edit CourseEditExistR GET
 /course/#TermIdentifier/#Text/show CourseShowR GET POST

src/Foundation.hs

@@ -68,7 +68,7 @@ data MenuItem = MenuItem
     }
 
 data MenuTypes
-    = NavbarLeft MenuItem
+    = NavbarLeft  MenuItem
     | NavbarRight MenuItem
 
 -- This is where we define all of the routes in our application. For a full
@@ -113,56 +113,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 widget = do
+    defaultLayout = defaultMenuLayout defaultLinks
-        master <- getYesod
-        mmsgs <- getMessages
-
-        muser <- maybeAuthPair
-        mcurrentRoute <- getCurrentRoute
-
-        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-        (title, parents) <- breadcrumbs
-
-        -- Define the menu items of the header.
-        let menuItems =
-                [ NavbarLeft $ MenuItem
-                    { menuItemLabel = "Home"
-                    , menuItemRoute = HomeR
-                    , menuItemAccessCallback = True
-                    }
-                , NavbarLeft $ MenuItem
-                    { menuItemLabel = "Profile"
-                    , menuItemRoute = ProfileR
-                    , menuItemAccessCallback = isJust muser
-                    }
-                , NavbarRight $ MenuItem
-                    { menuItemLabel = "Login"
-                    , menuItemRoute = AuthR LoginR
-                    , menuItemAccessCallback = isNothing muser
-                    }
-                , NavbarRight $ MenuItem
-                    { menuItemLabel = "Logout"
-                    , menuItemRoute = AuthR LogoutR
-                    , menuItemAccessCallback = isJust muser
-                    }
-                ]
-
-        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
-        -- default-layout-wrapper is the entire page. Since the final
-        -- value passed to hamletToRepHtml cannot be a widget, this allows
-        -- you to use normal widget features in default-layout.
-
-        pc <- widgetToPageContent $ do
-            addStylesheet $ StaticR css_bootstrap_css
-            $(widgetFile "default-layout")
-        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
@@ -254,6 +205,71 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)
 
+  
+defaultLinks :: Maybe (UserId, User) -> [MenuTypes]
+defaultLinks muser = -- Define the menu items of the header.
+  [ NavbarLeft $ MenuItem
+      { menuItemLabel = "Home"
+      , menuItemRoute = HomeR
+      , menuItemAccessCallback = True
+      }
+  , NavbarLeft $ MenuItem
+      { menuItemLabel = "Kurse"
+      , menuItemRoute = CourseListR
+      , menuItemAccessCallback = True
+      }                    
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Profile"
+      , menuItemRoute = ProfileR
+      , menuItemAccessCallback = isJust muser
+      }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Login"
+      , menuItemRoute = AuthR LoginR
+      , menuItemAccessCallback = isNothing muser
+      }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Logout"
+      , menuItemRoute = AuthR LogoutR
+      , menuItemAccessCallback = isJust muser
+      }
+  ]
+
+defaultLinkLayout :: (Maybe (UserId, User) -> [MenuTypes]) -> Widget -> Handler Html
+defaultLinkLayout menu = defaultMenuLayout defaultsPlusMenu
+  where 
+    defaultsPlusMenu = (++) <$> defaultLinks <*> menu
+
+defaultMenuLayout :: (Maybe (UserId, User) -> [MenuTypes]) 
+                          -> 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
+    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
+    -- default-layout-wrapper is the entire page. Since the final
+    -- value passed to hamletToRepHtml cannot be a widget, this allows
+    -- you to use normal widget features in default-layout.
+
+    pc <- widgetToPageContent $ do
+        addStylesheet $ StaticR css_bootstrap_css
+        $(widgetFile "default-layout")
+    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+  
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend

src/Handler/Course.hs

@@ -41,19 +41,37 @@ getCourseListTermR tidini = do
 --         , headed "Institut" $ [shamlet| #{course} |]
         , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom
         , headed "Ende Anmeldung"   $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo
+-- TODO        
+--         , headed "Teilnehmer" $ (\c -> do
+--               let cid = courseId c
+--               partiNum <- runDB $ count [CourseParticipantCourseId ==. cid]
+--               return $ fromString $ show partiNum
+--             )
         , headed " " $ (\c -> 
             let shd = courseShorthand c  
                 tid = unTermKey $ courseTermId c
             in do
               adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
+              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
               [whamlet| 
                 $if adminLink == Authorized
                   <a href=@{CourseEditExistR tid shd}>
                     editieren
-              |] )  
+              |]
-        ]  
+          )  
-  defaultLayout $ do
+        ]
-    setTitle "Semesterkurse"            
+  allowedNew <- isAuthorized CourseEditR False
+  let pageLinks muser = 
+        [ NavbarLeft $ MenuItem
+          { menuItemLabel = "Neuer Kurs"
+          , menuItemRoute = CourseEditR
+          , menuItemAccessCallback = Authorized == allowedNew
+          }
+        ] 
+  defaultLinkLayout pageLinks $ do
+--   defaultLayout $ do
+    setTitle "Semesterkurse"  
+    linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
     encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal courses)
 
 getCourseShowR :: TermIdentifier -> Text -> Handler Html
@@ -232,12 +250,12 @@ courseToForm cEntity = CourseForm
     course = entityVal cEntity
       
 newCourseForm :: Maybe CourseForm -> Form CourseForm
-newCourseForm template html = do       
+newCourseForm template = identForm FIDcourse $ \html -> do
     -- mopt hiddenField    
---     cidKey <- getsYesod appCryptoIDKey
+    --     cidKey <- getsYesod appCryptoIDKey
---     courseId <- runMaybeT $ do
+    --     courseId <- runMaybeT $ do
---         cid <- cfCourseId template
+    --         cid <- cfCourseId template
---         UUID.encrypt cidKey cid 
+    --         UUID.encrypt cidKey cid 
     (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
       -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
       <$> aopt hiddenField "KursId"             (cfCourseId <$> template)

src/Handler/Home.hs

@@ -15,7 +15,7 @@ import Handler.Utils
 import Data.Time
 import qualified Data.Text as T
 import Yesod.Form.Bootstrap3 
-
+ 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
 import Colonnade
@@ -33,31 +33,12 @@ instance PathPiece CreateButton where    -- for displaying the button only, not
   
 instance Button CreateButton where
   label CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"
+  label CreateInf  = "Informatik"  
   
+  cssClass CreateMath = BCInfo
+  cssClass CreateInf  = BCPrimary  
 -- END Button needed here 
 
-{-  -- Old Version
-getHomeR :: Handler Html
-getHomeR = do 
-  (crBtnWdgt, crBtnEnctype) <- generateFormPost $ buttonFormOld
-  defaultLayout $ do
-    setTitle "Willkommen zum ReWorX Test!"
-    $(widgetFile "home")
-
-  
-postHomeR :: Handler Html 
-postHomeR = do
-  ((btnResult,_), _) <- runFormPost $ buttonFormOld
-  $(logDebug) $ tshow btnResult  
-  case btnResult of 
-    (FormSuccess CreateInf)  -> setMessage "Informatik anlegen" 
-    (FormSuccess CreateMath) -> setMessage "Mathematik anlegen"
-    _other -> return ()    
-  getHomeR
-  
- -}  
-
 getHomeR :: Handler Html
 getHomeR = do 
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
@@ -70,8 +51,8 @@ postHomeR :: Handler Html
 postHomeR = do
   ((btnResult,_), _) <- runFormPost $ buttonForm  
   case btnResult of 
-    (FormSuccess CreateInf)  -> setMessage "Informatik anlegen" 
+    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt" 
-    (FormSuccess CreateMath) -> setMessage "Mathematik anlegen"
+    (FormSuccess CreateMath) -> setMessage "Knopf Mathematik erkannt"
     _other -> return ()    
   getHomeR  
   

src/Handler/Utils/Form.hs

@@ -10,9 +10,7 @@
 module Handler.Utils.Form where 
 
 import Import
--- import Data.Time
+import qualified Data.Char as Char
-import Data.Proxy
-import qualified Data.Map as Map
 import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
@@ -25,31 +23,124 @@ import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 
 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
-import Text.Blaze (Markup)
+
+------------------------------------------------
+-- Unique Form Identifiers to avoid accidents --
+------------------------------------------------
+
+data FormIdentifier = FIDcourse
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+
+identForm :: FormIdentifier -> Form a -> Form a  
+identForm fid = identifyForm (T.pack $ show fid)
+
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
 
+data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
+bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
+
 class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
   label :: a -> Widget
   label = toWidget . toPathPiece
 
+  cssClass :: a -> ButtonCssClass
+  cssClass _ = BCDefault
+  
+  
+--Some standard Buttons useful throughout  
+data StandardButton = BtnDelete | BtnAbort | BtnSave
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+     
+instance PathPiece StandardButton where    -- for displaying the button only, not really for paths
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
 
+instance Button StandardButton where
+  label BtnDelete = "Löschen"
+  label BtnAbort  = "Abbrechen"
+  label BtnSave   = "Speichern"
+  
+  cssClass BtnDelete = BCWarning
+  cssClass BtnAbort  = BCDefault
+  cssClass BtnSave   = BCPrimary
+  
+-- -- Looks like a button, but is just a link (e.g. for create course, etc.)  
+-- data LinkButton = LinkButton (Route UniWorX)
+--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
+-- 
+-- instance PathPiece LinkButton where
+--     LinkButton route = ???
+  
+linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget
+linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
+--   [whamlet|
+--     <form method=post action=@{url}>      
+--       <input type="hidden" name="_formid" value="identify-linkButton">
+--       <button .btn .#{bcc2txt cls} type=submit value="Link to @{url}">^{lbl}
+--   |] 
+  --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}> 
+  
+  
 buttonField :: Button a => a -> Field Handler a
 buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
   where 
+    fieldEnctype = UrlEncoded
+    
+    fieldView fid name attrs _val _ = 
+      [whamlet|
+        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
+      |]
+      
     fieldParse []    _ = return $ Right Nothing
     fieldParse [str] _ 
       | str == toPathPiece btn = return $ Right $ Just btn
       | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
     
-    fieldView id name attrs _val _ = 
+    
-      [whamlet|
+combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a]
-        <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{id}>^{label btn}
+combinedButtonField1 btns = traverse b2f btns
-      |]
+  where
-      
+    b2f b = aopt (buttonField b) "n/a" Nothing 
-    fieldEnctype = UrlEncoded
+
+    {-
+combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
+combinedButtonField btns inner csrf = do
+    buttonIdent <- newFormIdent
+    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing  
+    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
+    (innerRes,innerWdgt) <- inner
+    let widget = do 
+          [whamlet|
+            #{csrf}
+            ^{innerWdgt}
+            <div .btn-group>
+              $forall bView <- btnViews
+                ^{fvInput bView}
+          |]
+    let result = case (accResult result, innerRes) of
+                    (FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
+                    _ -> FormFailure ["Something went wrong"] -- TODO
+    return (result,widget)
+  where
+    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
+    accResult = Foldable.foldr accResult' FormMissing
+
+    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
+    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
+    accResult' (FormSuccess (Just x)) _ = FormSuccess x
+    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
+    accResult' (FormSuccess Nothing) x = x
+    accResult' FormMissing _ = FormMissing
+    accResult' (FormFailure errs) _ = FormFailure errs       
+    -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
 buttonForm :: (Button a) => Form a
@@ -71,56 +162,15 @@ buttonForm csrf = do
     accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
     accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
     accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Should Failure override Success?
+    accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
     accResult' (FormSuccess Nothing) x = x
     accResult' FormMissing _ = FormMissing
     accResult' (FormFailure errs) _ = FormFailure errs
 
   
-
+---------------------------------------
-
+-- Buttons (old version, deprecated) --
-  
+---------------------------------------
-buttonFormOld :: Button a => Markup -> MForm Handler (FormResult a, (a -> FieldView UniWorX))
-buttonFormOld html = do
-  let 
-    buttonValues = [minBound..maxBound] 
-    buttonMap  = Map.fromList $ zip buttonValues buttonValues
-    button b = Field parse view UrlEncoded
-      where
-        parse []    _ = return $ Right Nothing
-        parse [str] _ 
-          | str == toPathPiece b = return $ Right $ Just b
-          | otherwise = return $ Left "Wrong button value"
-        parse _ _ = return $ Left "Multiple button values"
-        
-        view id name attrs _val _ = do
-          [whamlet|
-            #{html}
-            <button .btn .btn-default type=submit name=#{name} value=#{toPathPiece b} *{attrs} ##{id}>^{label b}
-          |]
-  
-  buttonIdent <- newFormIdent
-  resultWidgetMap <- forM buttonMap $ \val -> mopt (button val) ("" { fsName = Just buttonIdent }) Nothing
-    
-  let result = accResult $ fst <$> Map.elems resultWidgetMap
-  let viewF = (Map.!) (snd <$> resultWidgetMap)
-  
-  return (result, viewF)
-  where
-    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
-    accResult = Foldable.foldr accResult' FormMissing
-
-    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous parse"]
-    accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x
-    accResult' (FormSuccess Nothing) x = x
-    accResult' FormMissing _ = FormMissing
-    accResult' (FormFailure errs) _ = FormFailure errs
-  
-----------------------------
--- Buttons (old version ) --
-----------------------------
 
 formBtnSave  :: (Text,Text,Text)
 formBtnSave   = ("save"  ,"Speichern"  ,"btn-primary")
@@ -147,8 +197,7 @@ defaultFormActions =  [ formBtnDelete
                       ]
 
 -- Post-Buttons
--- postButtonForm :: MonadHandler m => 
+postButtonForm :: Text -> Form ()
---     Text -> Text.Blaze.Internal.Markup -> MForm m (FormResult (), WidgetT (HandlerSite m) IO ())
 postButtonForm lblId = identifyForm lblId buttonF
   where
     buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps