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

Fix database representation of term for correct sorting

Browse Source
This commit is contained in:
Gregor Kleen 2018-06-29 16:13:36 +02:00
parent b334df4939
commit d33956dfaa
2 changed files with 19 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
fill-db.hs
View File

@ -95,7 +95,6 @@ main = db $ do
, courseTerm = TermKey summer2018 , courseTerm = TermKey summer2018
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 20 , courseCapacity = Just 20
, courseHasRegistration = True
, courseRegisterFrom = Just now , courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
@ -122,7 +121,6 @@ main = db $ do
, courseTerm = TermKey summer2017 , courseTerm = TermKey summer2017
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 20 , courseCapacity = Just 20
, courseHasRegistration = False
, courseRegisterFrom = Nothing , courseRegisterFrom = Nothing
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
@ -141,7 +139,6 @@ main = db $ do
, courseTerm = TermKey summer2018 , courseTerm = TermKey summer2018
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 20 , courseCapacity = Just 20
, courseHasRegistration = True
, courseRegisterFrom = Just now , courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
@ -160,7 +157,6 @@ main = db $ do
, courseTerm = TermKey winter2017 , courseTerm = TermKey winter2017
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 30 , courseCapacity = Just 30
, courseHasRegistration = False
, courseRegisterFrom = Nothing , courseRegisterFrom = Nothing
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
@ -179,7 +175,6 @@ main = db $ do
, courseTerm = TermKey summer2017 , courseTerm = TermKey summer2017
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 50 , courseCapacity = Just 50
, courseHasRegistration = False
, courseRegisterFrom = Nothing , courseRegisterFrom = Nothing
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
@ -198,7 +193,6 @@ main = db $ do
, courseTerm = TermKey summer2018 , courseTerm = TermKey summer2018
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 50 , courseCapacity = Just 50
, courseHasRegistration = False
, courseRegisterFrom = Nothing , courseRegisterFrom = Nothing
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing

22
src/Model/Types.hs
View File

@ -161,14 +161,30 @@ termFromText t
, Right season <- seasonFromChar s , Right season <- seasonFromChar s
= Right TermIdentifier{..} = Right TermIdentifier{..}
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
termToRational :: TermIdentifier -> Rational
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
where
seasonOffset
| Summer <- season = 0
| Winter <- season = 0.5
termFromRational :: Rational -> TermIdentifier
termFromRational n = TermIdentifier{..}
where
year = floor n
remainder = n - (fromInteger $ floor n)
season
| remainder == 0 = Summer
| otherwise = Winter
instance PersistField TermIdentifier where instance PersistField TermIdentifier where
toPersistValue = PersistText . termToText toPersistValue = PersistRational . termToRational
fromPersistValue (PersistText t) = termFromText t fromPersistValue (PersistRational t) = Right $ termFromRational t
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
instance PersistFieldSql TermIdentifier where instance PersistFieldSql TermIdentifier where
sqlType _ = SqlString sqlType _ = SqlNumeric 5 1
instance ToHttpApiData TermIdentifier where instance ToHttpApiData TermIdentifier where
toUrlPiece = termToText toUrlPiece = termToText