diff --git a/fill-db.hs b/fill-db.hs index 4cc894464..66118aba6 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -1,13 +1,16 @@ #!/usr/bin/env stack --- stack runghc +-- stack runghc --package uniworx {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} import "uniworx" Import import "uniworx" Application (db) +import Database.Persist.Sql (toSqlKey) + import Data.Time main :: IO () @@ -15,10 +18,12 @@ main = db $ do defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings now <- liftIO getCurrentTime let + insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r) + insert' = fmap (either entityKey id) . insertBy summer2017 = TermIdentifier 2017 Summer winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer - gkleen <- insert User + gkleen <- insert' User { userPlugin = "LDAP" , userIdent = "G.Kleen@campus.lmu.de" , userMatrikelnummer = Nothing @@ -26,7 +31,7 @@ main = db $ do , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 } - fhamann <- insert User + fhamann <- insert' User { userPlugin = "LDAP" , userIdent = "felix.hamann@campus.lmu.de" , userMatrikelnummer = Nothing @@ -34,7 +39,7 @@ main = db $ do , userDisplayName = "Felix Hamann" , userMaxFavourites = defaultFavourites } - jost <- insert User + jost <- insert' User { userPlugin = "LDAP" , userIdent = "jost@tcs.ifi.lmu.de" , userMatrikelnummer = Nothing @@ -42,7 +47,7 @@ main = db $ do , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 } - void . insert $ Term + void . repsert (TermKey summer2017) $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 , termEnd = fromGregorian 2017 07 14 @@ -51,7 +56,7 @@ main = db $ do , termLectureEnd = fromGregorian 2018 07 14 , termActive = False } - void . insert $ Term + void . repsert (TermKey winter2017) $ Term { termName = winter2017 , termStart = fromGregorian 2017 10 16 , termEnd = fromGregorian 2018 02 10 @@ -60,7 +65,7 @@ main = db $ do , termLectureEnd = fromGregorian 2018 02 10 , termActive = True } - void . insert $ Term + void . repsert (TermKey summer2018) $ Term { termName = summer2018 , termStart = fromGregorian 2018 04 09 , termEnd = fromGregorian 2018 07 14 @@ -69,22 +74,28 @@ main = db $ do , termLectureEnd = fromGregorian 2018 07 14 , termActive = True } - ifi <- insert $ School "Institut für Informatik" "IfI" - mi <- insert $ School "Institut für Mathematik" "MI" - void . insert $ UserAdmin gkleen ifi - void . insert $ UserAdmin gkleen mi - void . insert $ UserAdmin fhamann ifi - void . insert $ UserAdmin jost ifi - void . insert $ UserAdmin jost mi - void . insert $ UserLecturer gkleen ifi - void . insert $ UserLecturer fhamann ifi - void . insert $ UserLecturer jost ifi - sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) - sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" ) - sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik") - sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik") + ifi <- insert' $ School "Institut für Informatik" "IfI" + mi <- insert' $ School "Institut für Mathematik" "MI" + void . insert' $ UserAdmin gkleen ifi + void . insert' $ UserAdmin gkleen mi + void . insert' $ UserAdmin fhamann ifi + void . insert' $ UserAdmin jost ifi + void . insert' $ UserAdmin jost mi + void . insert' $ UserLecturer gkleen ifi + void . insert' $ UserLecturer fhamann ifi + void . insert' $ UserLecturer jost ifi + let + sdBsc = StudyDegreeKey' 82 + sdMst = StudyDegreeKey' 88 + repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) + repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) + let + sdInf = StudyTermsKey' 79 + sdMath = StudyTermsKey' 105 + repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatik") + repsert sdMath $ StudyTerms 105 (Just "M" ) (Just "Mathematik") -- FFP - ffp <- insert Course + ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -100,15 +111,15 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit jost now ffp - void . insert $ DegreeCourse ffp sdBsc sdInf - void . insert $ DegreeCourse ffp sdMst sdInf - void . insert $ Lecturer jost ffp - void . insert $ Lecturer gkleen ffp - insert_ $ Corrector gkleen ffp (ByProportion 1) - sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + void . insert' $ DegreeCourse ffp sdBsc sdInf + void . insert' $ DegreeCourse ffp sdMst sdInf + void . insert' $ Lecturer jost ffp + void . insert' $ Lecturer gkleen ffp + void . insert' $ Corrector gkleen ffp (ByProportion 1) + sheetkey <- insert' $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing insert_ $ SheetEdit gkleen now sheetkey -- EIP - eip <- insert Course + eip <- insert' Course { courseName = "Einführung in die Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -124,10 +135,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now eip - void . insert $ DegreeCourse eip sdBsc sdInf - void . insert $ Lecturer fhamann eip + void . insert' $ DegreeCourse eip sdBsc sdInf + void . insert' $ Lecturer fhamann eip -- interaction design - ixd <- insert Course + ixd <- insert' Course { courseName = "Interaction Design (User Experience Design I & II)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -143,10 +154,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ixd - void . insert $ DegreeCourse ixd sdBsc sdInf - void . insert $ Lecturer fhamann ixd + void . insert' $ DegreeCourse ixd sdBsc sdInf + void . insert' $ Lecturer fhamann ixd -- concept development - ux3 <- insert Course + ux3 <- insert' Course { courseName = "Concept Development (User Experience Design III)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -162,10 +173,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ux3 - void . insert $ DegreeCourse ux3 sdBsc sdInf - void . insert $ Lecturer fhamann ux3 + void . insert' $ DegreeCourse ux3 sdBsc sdInf + void . insert' $ Lecturer fhamann ux3 -- promo - pmo <- insert Course + pmo <- insert' Course { courseName = "Programmierung und Modellierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -181,10 +192,10 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit jost now pmo - void . insert $ DegreeCourse pmo sdBsc sdInf - void . insert $ Lecturer jost pmo + void . insert' $ DegreeCourse pmo sdBsc sdInf + void . insert' $ Lecturer jost pmo -- datenbanksysteme - dbs <- insert Course + dbs <- insert' Course { courseName = "Datenbanksysteme" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -200,7 +211,7 @@ main = db $ do , courseMaterialFree = True } insert_ $ CourseEdit gkleen now dbs - void . insert $ DegreeCourse dbs sdBsc sdInf - void . insert $ DegreeCourse dbs sdBsc sdMath - void . insert $ Lecturer gkleen dbs - void . insert $ Lecturer jost dbs + void . insert' $ DegreeCourse dbs sdBsc sdInf + void . insert' $ DegreeCourse dbs sdBsc sdMath + void . insert' $ Lecturer gkleen dbs + void . insert' $ Lecturer jost dbs diff --git a/ghci.sh b/ghci.sh index 64adc58eb..1c0ac289f 100755 --- a/ghci.sh +++ b/ghci.sh @@ -5,4 +5,4 @@ export DETAILED_LOGGING=true export LOG_ALL=true export DUMMY_LOGIN=true -exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only +exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only uniworx diff --git a/models b/models index 0d4793d28..708d933f8 100644 --- a/models +++ b/models @@ -9,6 +9,7 @@ User UserAdmin user UserId school SchoolId + UniqueUserAdmin school user UserLecturer user UserId school SchoolId diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b54eb4601..ca925fafb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -167,7 +167,8 @@ instance PersistField Value where toPersistValue = PersistDbSpecific . toStrict . encode fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t - fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific" + fromPersistValue (PersistByteString t) = first pack . eitherDecode $ fromStrict t + fromPersistValue v = Left $ "JSON values must be converted from PersistDbSpecific (got: " ++ tshow v ++ ")" instance PersistFieldSql Value where sqlType _ = SqlOther "json" diff --git a/src/Notifications.hs b/src/Notifications.hs index 003b0f4a8..7dd63ad3f 100644 --- a/src/Notifications.hs +++ b/src/Notifications.hs @@ -45,7 +45,7 @@ handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" handleQueueException (QNLocked qnId lInstance lTime) = $(logDebugS) "Notifications" $ "Saw locked QueuedNotification: " ++ tshow (qnId, lInstance, lTime) handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedNotificationCreated ] .| C.mapM_ cmdSend - handleCmd (NCtlSend qnId) = handle handleQueueException $ do + handleCmd (NCtlSend qnId) = handle handleQueueException . (`finally` qnUnlock qnId) $ do qn@QueuedNotification{..} <- qnLock qnId let @@ -56,8 +56,6 @@ handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" runDB $ delete qnId - - qnLock :: QueuedNotificationId -> Handler QueuedNotification qnLock qnId = runDB $ do rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" [] @@ -70,6 +68,12 @@ qnLock qnId = runDB $ do , QueuedNotificationLockTime =. Just now ] +qnUnlock :: QueuedNotificationId -> Handler () +qnUnlock qnId = runDB $ update qnId [ QueuedNotificationLockInstance =. Nothing + , QueuedNotificationLockTime =. Nothing + ] + + cmdSend :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => QueuedNotificationId -> m ()