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

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

Browse Source
This commit is contained in:
SJost 2018-10-17 13:12:49 +02:00
commit 70f77f8dee
3 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
db.hs
View File

@ -195,8 +195,8 @@ fillDb = do
let
sdInf = StudyTermsKey' 79
sdMath = StudyTermsKey' 105
repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatik")
repsert sdMath $ StudyTerms 105 (Just "M" ) (Just "Mathematik")
repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik")
repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
-- FFP
ffp <- insert' Course
{ courseName = "Fortgeschrittene Funktionale Programmierung"
@ -207,7 +207,7 @@ fillDb = do
, courseSchool = ifi
, courseCapacity = Just 20
, courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
@ -217,11 +217,11 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp
void . insert $ Lecturer gkleen ffp
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
-- EIP
eip <- insert' Course
@ -251,7 +251,7 @@ fillDb = do
, courseSchool = ifi
, courseCapacity = Just 20
, courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
@ -305,6 +305,7 @@ fillDb = do
, sheetVisibleFrom = Just now
, sheetActiveFrom = now
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
, sheetSubmissionMode = CorrectorSubmissions
, sheetUploadMode = Upload True
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing

2
src/Model/Types.hs
View File

@ -514,7 +514,7 @@ instance Default NotificationSettings where
NTSubmissionRatedGraded -> True
NTSubmissionRated -> False
NTSheetActive -> True
NTSheetInactive -> True
NTSheetInactive -> False
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

13
src/Utils/Sql.hs
View File

@ -17,6 +17,8 @@ import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf)
import Data.Time.Clock
setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
setSerializable act = setSerializable' (0 :: Integer)
where
@ -24,7 +26,14 @@ setSerializable act = setSerializable' (0 :: Integer)
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> sqlErrorHint e == "The transaction might succeed if retried.")
(\e -> $logWarnS "Sql" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff))
(\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\e -> do
let
delay :: NominalDiffTime
delay = 1e-3 * 2 ^ logBackoff
$logWarnS "Sql" $ tshow (delay, e)
threadDelay . round $ delay * 1e6
setSerializable' (succ logBackoff)
)
act'