Favourites working now (without PageActions).

.gitignore

@@ -25,6 +25,7 @@ uniworx.nix
 .gup/
 .dbsettings.yml
 *.kate-swp
+.kateproject
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig

.kateproject

@@ -1,4 +0,0 @@
-{
-  "name": "ReWorX"
-, "files": [ { "git": 1, "filters": ["*.hs", "*.hamlet", "*.lucius", "*.cassius", "*.julius"], "recursive": 1 } ]
-}

fill-db.hs

@@ -12,6 +12,7 @@ import Data.Time
 
 main :: IO ()
 main = db $ do
+  defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings
   now <- liftIO getCurrentTime
   let
     summer2017 = TermIdentifier 2017 Summer
@@ -23,6 +24,7 @@ main = db $ do
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
+    , userMaxFavourites = 6
     }
   fhamann <- insert User
     { userPlugin = "LDAP"
@@ -30,6 +32,7 @@ main = db $ do
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
+    , userMaxFavourites = defaultFavourites
     }
   jost <- insert User
     { userPlugin = "LDAP"
@@ -37,6 +40,7 @@ main = db $ do
     , userMatrikelnummer = Nothing
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
+    , userMaxFavourites = 14
     }
   void . insert $ Term
     { termName     = summer2017
@@ -91,6 +95,9 @@ main = db $ do
     , courseHasRegistration = True
     , courseRegisterFrom = Just now
     , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit jost now ffp
   void . insert $ DegreeCourse ffp sdBsc sdInf
@@ -112,6 +119,9 @@ main = db $ do
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now eip
   void . insert $ DegreeCourse eip sdBsc sdInf
@@ -128,6 +138,9 @@ main = db $ do
     , courseHasRegistration = True
     , courseRegisterFrom = Just now
     , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ixd
   void . insert $ DegreeCourse ixd sdBsc sdInf
@@ -144,6 +157,9 @@ main = db $ do
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ux3
   void . insert $ DegreeCourse ux3 sdBsc sdInf
@@ -160,6 +176,9 @@ main = db $ do
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
@@ -176,6 +195,9 @@ main = db $ do
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
     }
   insert_ $ CourseEdit gkleen now dbs
   void . insert $ DegreeCourse dbs sdBsc sdInf

models

@@ -58,10 +58,13 @@ Course
     termId       TermId
     schoolId     SchoolId    
     capacity     Int Maybe    
-    hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+    hasRegistration  Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
-    registerFrom UTCTime Maybe
+    registerFrom     UTCTime Maybe
-    registerTo   UTCTime Maybe
+    registerTo       UTCTime Maybe
-    CourseTermShort termId shorthand
+    deregisterUntil  UTCTime Maybe
+    registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
+    materialFree     Bool default=true
+    CourseTermShort  termId shorthand
 CourseEdit
     user         UserId
     time         UTCTime

run.sh

@@ -0,0 +1 @@
+start.sh

src/Foundation.hs

@@ -47,6 +47,8 @@ import qualified Data.Text.Encoding as Text
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 
+import qualified Database.Esqueleto as E
+
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
@@ -153,16 +155,17 @@ instance Yesod UniWorX where
         case route of
           CourseR tid csh _  | "updateFavourite" `elem` attrs -> do
             uid <- MaybeT maybeAuthId
+            $(logDebug) "Favourites save"
             now <- liftIO $ getCurrentTime
             void . lift . runDB . runMaybeT $ do
               cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
               user <- MaybeT $ get uid
-              -- update Favorites
+              -- update Favourites
               lift $ upsertBy
                       (UniqueCourseFavourite uid cid)
                       (CourseFavourite uid now cid)
                       [CourseFavouriteTime =. now]
-              -- prune Favorites to user-defined size
+              -- prune Favourites to user-defined size
               oldFavs <- lift $ selectKeysList
                                   [ CourseFavouriteUser ==. uid]
                                   [ Desc CourseFavouriteTime
@@ -340,7 +343,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
   breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
 
-  breadcrumb HomeR = return ("ReWorX", Nothing)
+  breadcrumb HomeR = return ("UniworkY", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)
@@ -404,7 +407,7 @@ defaultLinkLayout = defaultMenuLayout . (defaultLinks ++)
 defaultMenuLayout :: [MenuTypes] -> Widget -> Handler Html
 defaultMenuLayout menu widget = do
     master <- getYesod
-    mmsgs <- getMessages
+    mmsgs  <- getMessages
 
     mcurrentRoute <- getCurrentRoute
 
@@ -413,6 +416,17 @@ defaultMenuLayout menu widget = do
 
     menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
 
+    -- Lookup Favourites if possible
+    favourites <- do
+      muid <- maybeAuthId
+      case muid of
+        Nothing    -> return []
+        (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
+          E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
+          E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
+          E.orderBy [ E.asc $ course E.^. CourseShorthand ]
+          return course
+
     -- 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

src/Handler/Course.hs

@@ -189,6 +189,9 @@ courseEditHandler course = do
             , courseHasRegistration = cfHasReg   res
             , courseRegisterFrom    = cfRegFrom  res
             , courseRegisterTo      = cfRegTo    res
+            , courseDeregisterUntil = Nothing -- TODO
+            , courseRegisterSecret  = Nothing -- TODO
+            , courseMaterialFree    = True    -- TODO
             }
           case insertOkay of
             (Just cid) -> do
@@ -232,16 +235,19 @@ courseEditHandler course = do
 --                   , CourseChanged      =. now
 --                   ]
                 _updOkay <- replace cid (  -- TODO replaceUnique requires Eq?!
-                    Course { courseName            = cfName     res
+                    Course  {  courseName            = cfName     res
-                           , courseDescription     = cfDesc     res
+                            ,  courseDescription     = cfDesc     res
-                           , courseLinkExternal    = cfLink     res
+                            ,  courseLinkExternal    = cfLink     res
-                           , courseShorthand       = cfShort    res
+                            ,  courseShorthand       = cfShort    res
-                           , courseTermId          = cfTerm     res
+                            ,  courseTermId          = cfTerm     res
-                           , courseSchoolId        = cfSchool   res
+                            ,  courseSchoolId        = cfSchool   res
-                           , courseCapacity        = cfCapacity res
+                            ,  courseCapacity        = cfCapacity res
-                           , courseHasRegistration = cfHasReg   res
+                            ,  courseHasRegistration = cfHasReg   res
-                           , courseRegisterFrom    = cfRegFrom  res
+                            ,  courseRegisterFrom    = cfRegFrom  res
-                           , courseRegisterTo      = cfRegTo    res
+                            ,  courseRegisterTo      = cfRegTo    res
+                            ,  courseDeregisterUntil = Nothing -- TODO
+                            ,  courseRegisterSecret  = Nothing -- TODO
+                            ,  courseMaterialFree    = True    -- TODO
                     }
                   )
                 insert_ $ CourseEdit aid now cid

src/Handler/Home.hs

@@ -43,7 +43,7 @@ getHomeR :: Handler Html
 getHomeR = do
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
   defaultLayout $ do
-    setTitle "Willkommen zum ReWorX Test!"
+    setTitle "Willkommen zum UniworkY Test!"
     $(widgetFile "home")
 
 

templates/home.hamlet

@@ -1,5 +1,5 @@
 <div .container>
-  <h1>ReWorX - Demo
+  <h1>UniworkY - Demo
   <h3>
     Testumgebung für die Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
   <p>

templates/widgets/asidenav.hamlet

@@ -17,6 +17,12 @@ $newline never
       <h3 .asidenav__box-title>
         WiSe 17/18
       <ul .asidenav__list>
+        $forall (Entity _ Course{..}) <- favourites
+          <li .asidenav__list-item>
+            <a .asidenav__link-wrapper href=@{CourseR courseTermId courseShorthand CourseShowR}>
+              <div .asidenav__link-triple>#{courseShorthand}
+              <div .asidenav__link-label>#{courseName}
+
         <li .asidenav__list-item>
           <a .asidenav__link-wrapper href="/course/S2018/ixd/show">
             <div .asidenav__link-triple>IXD