fraport/fradrive-old
Archived
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 #!/usr/bin/env stack
-- stack runghc -- stack runghc --package uniworx
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
import "uniworx" Import import "uniworx" Import
import "uniworx" Application (db) import "uniworx" Application (db)
import Database.Persist.Sql (toSqlKey)
import Data.Time import Data.Time
main :: IO () main :: IO ()
@ -15,10 +18,12 @@ main = db $ do
defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
insert' = fmap (either entityKey id) . insertBy
summer2017 = TermIdentifier 2017 Summer summer2017 = TermIdentifier 2017 Summer
winter2017 = TermIdentifier 2017 Winter winter2017 = TermIdentifier 2017 Winter
summer2018 = TermIdentifier 2018 Summer summer2018 = TermIdentifier 2018 Summer
gkleen <- insert User gkleen <- insert' User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
, userIdent = "G.Kleen@campus.lmu.de" , userIdent = "G.Kleen@campus.lmu.de"
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
@ -26,7 +31,7 @@ main = db $ do
, userDisplayName = "Gregor Kleen" , userDisplayName = "Gregor Kleen"
, userMaxFavourites = 6 , userMaxFavourites = 6
} }
fhamann <- insert User fhamann <- insert' User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
, userIdent = "felix.hamann@campus.lmu.de" , userIdent = "felix.hamann@campus.lmu.de"
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
@ -34,7 +39,7 @@ main = db $ do
, userDisplayName = "Felix Hamann" , userDisplayName = "Felix Hamann"
, userMaxFavourites = defaultFavourites , userMaxFavourites = defaultFavourites
} }
jost <- insert User jost <- insert' User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
, userIdent = "jost@tcs.ifi.lmu.de" , userIdent = "jost@tcs.ifi.lmu.de"
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
@ -42,7 +47,7 @@ main = db $ do
, userDisplayName = "Steffen Jost" , userDisplayName = "Steffen Jost"
, userMaxFavourites = 14 , userMaxFavourites = 14
} }
void . insert $ Term void . repsert (TermKey summer2017) $ Term
{ termName = summer2017 { termName = summer2017
, termStart = fromGregorian 2017 04 09 , termStart = fromGregorian 2017 04 09
, termEnd = fromGregorian 2017 07 14 , termEnd = fromGregorian 2017 07 14
@ -51,7 +56,7 @@ main = db $ do
, termLectureEnd = fromGregorian 2018 07 14 , termLectureEnd = fromGregorian 2018 07 14
, termActive = False , termActive = False
} }
void . insert $ Term void . repsert (TermKey winter2017) $ Term
{ termName = winter2017 { termName = winter2017
, termStart = fromGregorian 2017 10 16 , termStart = fromGregorian 2017 10 16
, termEnd = fromGregorian 2018 02 10 , termEnd = fromGregorian 2018 02 10
@ -60,7 +65,7 @@ main = db $ do
, termLectureEnd = fromGregorian 2018 02 10 , termLectureEnd = fromGregorian 2018 02 10
, termActive = True , termActive = True
} }
void . insert $ Term void . repsert (TermKey summer2018) $ Term
{ termName = summer2018 { termName = summer2018
, termStart = fromGregorian 2018 04 09 , termStart = fromGregorian 2018 04 09
, termEnd = fromGregorian 2018 07 14 , termEnd = fromGregorian 2018 07 14
@ -69,22 +74,28 @@ main = db $ do
, termLectureEnd = fromGregorian 2018 07 14 , termLectureEnd = fromGregorian 2018 07 14
, termActive = True , termActive = True
} }
ifi <- insert $ School "Institut für Informatik" "IfI" ifi <- insert' $ School "Institut für Informatik" "IfI"
mi <- insert $ School "Institut für Mathematik" "MI" mi <- insert' $ School "Institut für Mathematik" "MI"
void . insert $ UserAdmin gkleen ifi void . insert' $ UserAdmin gkleen ifi
void . insert $ UserAdmin gkleen mi void . insert' $ UserAdmin gkleen mi
void . insert $ UserAdmin fhamann ifi void . insert' $ UserAdmin fhamann ifi
void . insert $ UserAdmin jost ifi void . insert' $ UserAdmin jost ifi
void . insert $ UserAdmin jost mi void . insert' $ UserAdmin jost mi
void . insert $ UserLecturer gkleen ifi void . insert' $ UserLecturer gkleen ifi
void . insert $ UserLecturer fhamann ifi void . insert' $ UserLecturer fhamann ifi
void . insert $ UserLecturer jost ifi void . insert' $ UserLecturer jost ifi
sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) let
sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" ) sdBsc = StudyDegreeKey' 82
sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik") sdMst = StudyDegreeKey' 88
sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik") 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
ffp <- insert Course ffp <- insert' Course
{ courseName = "Fortgeschrittene Funktionale Programmierung" { courseName = "Fortgeschrittene Funktionale Programmierung"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -100,15 +111,15 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit jost now ffp insert_ $ CourseEdit jost now ffp
void . insert $ DegreeCourse ffp sdBsc sdInf void . insert' $ DegreeCourse ffp sdBsc sdInf
void . insert $ DegreeCourse ffp sdMst sdInf void . insert' $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp void . insert' $ Lecturer jost ffp
void . insert $ Lecturer gkleen ffp void . insert' $ Lecturer gkleen ffp
insert_ $ Corrector gkleen ffp (ByProportion 1) void . insert' $ Corrector gkleen ffp (ByProportion 1)
sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing sheetkey <- insert' $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
insert_ $ SheetEdit gkleen now sheetkey insert_ $ SheetEdit gkleen now sheetkey
-- EIP -- EIP
eip <- insert Course eip <- insert' Course
{ courseName = "Einführung in die Programmierung" { courseName = "Einführung in die Programmierung"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -124,10 +135,10 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit fhamann now eip insert_ $ CourseEdit fhamann now eip
void . insert $ DegreeCourse eip sdBsc sdInf void . insert' $ DegreeCourse eip sdBsc sdInf
void . insert $ Lecturer fhamann eip void . insert' $ Lecturer fhamann eip
-- interaction design -- interaction design
ixd <- insert Course ixd <- insert' Course
{ courseName = "Interaction Design (User Experience Design I & II)" { courseName = "Interaction Design (User Experience Design I & II)"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -143,10 +154,10 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit fhamann now ixd insert_ $ CourseEdit fhamann now ixd
void . insert $ DegreeCourse ixd sdBsc sdInf void . insert' $ DegreeCourse ixd sdBsc sdInf
void . insert $ Lecturer fhamann ixd void . insert' $ Lecturer fhamann ixd
-- concept development -- concept development
ux3 <- insert Course ux3 <- insert' Course
{ courseName = "Concept Development (User Experience Design III)" { courseName = "Concept Development (User Experience Design III)"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -162,10 +173,10 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit fhamann now ux3 insert_ $ CourseEdit fhamann now ux3
void . insert $ DegreeCourse ux3 sdBsc sdInf void . insert' $ DegreeCourse ux3 sdBsc sdInf
void . insert $ Lecturer fhamann ux3 void . insert' $ Lecturer fhamann ux3
-- promo -- promo
pmo <- insert Course pmo <- insert' Course
{ courseName = "Programmierung und Modellierung" { courseName = "Programmierung und Modellierung"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -181,10 +192,10 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit jost now pmo insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf void . insert' $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo void . insert' $ Lecturer jost pmo
-- datenbanksysteme -- datenbanksysteme
dbs <- insert Course dbs <- insert' Course
{ courseName = "Datenbanksysteme" { courseName = "Datenbanksysteme"
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
@ -200,7 +211,7 @@ main = db $ do
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit gkleen now dbs insert_ $ CourseEdit gkleen now dbs
void . insert $ DegreeCourse dbs sdBsc sdInf void . insert' $ DegreeCourse dbs sdBsc sdInf
void . insert $ DegreeCourse dbs sdBsc sdMath void . insert' $ DegreeCourse dbs sdBsc sdMath
void . insert $ Lecturer gkleen dbs void . insert' $ Lecturer gkleen dbs
void . insert $ Lecturer jost dbs void . insert' $ Lecturer jost dbs

2
ghci.sh
View File

@ -5,4 +5,4 @@ export DETAILED_LOGGING=true
export LOG_ALL=true export LOG_ALL=true
export DUMMY_LOGIN=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 UserAdmin
user UserId user UserId
school SchoolId school SchoolId
UniqueUserAdmin school user
UserLecturer UserLecturer
user UserId user UserId
school SchoolId school SchoolId

3
src/Model/Types.hs
View File

@ -167,7 +167,8 @@ instance PersistField Value where
toPersistValue = PersistDbSpecific . toStrict . encode toPersistValue = PersistDbSpecific . toStrict . encode
fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t 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 instance PersistFieldSql Value where
sqlType _ = SqlOther "json" 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) 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 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 qn@QueuedNotification{..} <- qnLock qnId
let let
@ -56,8 +56,6 @@ handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications"
runDB $ delete qnId runDB $ delete qnId
qnLock :: QueuedNotificationId -> Handler QueuedNotification qnLock :: QueuedNotificationId -> Handler QueuedNotification
qnLock qnId = runDB $ do qnLock qnId = runDB $ do
rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" [] rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" []
@ -70,6 +68,12 @@ qnLock qnId = runDB $ do
, QueuedNotificationLockTime =. Just now , QueuedNotificationLockTime =. Just now
] ]
qnUnlock :: QueuedNotificationId -> Handler ()
qnUnlock qnId = runDB $ update qnId [ QueuedNotificationLockInstance =. Nothing
, QueuedNotificationLockTime =. Nothing
]
cmdSend :: ( MonadHandler m cmdSend :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
) => QueuedNotificationId -> m () ) => QueuedNotificationId -> m ()