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 let
sdInf = StudyTermsKey' 79 sdInf = StudyTermsKey' 79
sdMath = StudyTermsKey' 105 sdMath = StudyTermsKey' 105
repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatik") repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik")
repsert sdMath $ StudyTerms 105 (Just "M" ) (Just "Mathematik") repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
-- FFP -- FFP
ffp <- insert' Course ffp <- insert' Course
{ courseName = "Fortgeschrittene Funktionale Programmierung" { courseName = "Fortgeschrittene Funktionale Programmierung"
@ -207,7 +207,7 @@ fillDb = do
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 20 , courseCapacity = Just 20
, courseRegisterFrom = Just now , courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) , courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
@ -217,11 +217,11 @@ fillDb = do
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
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 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 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 insert_ $ SheetEdit gkleen now sheetkey
-- EIP -- EIP
eip <- insert' Course eip <- insert' Course
@ -251,7 +251,7 @@ fillDb = do
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 20 , courseCapacity = Just 20
, courseRegisterFrom = Just now , courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) , courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
@ -305,6 +305,7 @@ fillDb = do
, sheetVisibleFrom = Just now , sheetVisibleFrom = Just now
, sheetActiveFrom = now , sheetActiveFrom = now
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
, sheetSubmissionMode = CorrectorSubmissions
, sheetUploadMode = Upload True , sheetUploadMode = Upload True
, sheetHintFrom = Nothing , sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing , sheetSolutionFrom = Nothing

2
src/Model/Types.hs
View File

@ -514,7 +514,7 @@ instance Default NotificationSettings where
NTSubmissionRatedGraded -> True NTSubmissionRatedGraded -> True
NTSubmissionRated -> False NTSubmissionRated -> False
NTSheetActive -> True NTSheetActive -> True
NTSheetInactive -> True NTSheetInactive -> False
instance ToJSON NotificationSettings where instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF 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 Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf) 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 :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
setSerializable act = setSerializable' (0 :: Integer) setSerializable act = setSerializable' (0 :: Integer)
where where
@ -24,7 +26,14 @@ setSerializable act = setSerializable' (0 :: Integer)
setSerializable' (min 10 -> logBackoff) = setSerializable' (min 10 -> logBackoff) =
handleIf handleIf
(\e -> sqlErrorHint e == "The transaction might succeed if retried.") (\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\e -> $logWarnS "Sql" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff)) (\e -> do
let
delay :: NominalDiffTime
delay = 1e-3 * 2 ^ logBackoff
$logWarnS "Sql" $ tshow (delay, e)
threadDelay . round $ delay * 1e6
setSerializable' (succ logBackoff)
)
act' act'