fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix DB interaction

Browse Source
This commit is contained in:
Gregor Kleen 2018-02-19 12:54:43 +01:00 committed by Gregor Kleen
parent 93c96ae620
commit 544eadca85
5 changed files with 67 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
fill-db.hs
View File

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

2
ghci.sh
View File

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

1
models
View File

@ -9,6 +9,7 @@ User
UserAdmin
user UserId
school SchoolId
UniqueUserAdmin school user
UserLecturer
user UserId
school SchoolId

3
src/Model/Types.hs
View File

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

10
src/Notifications.hs
View File

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