aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
authorstuebinm2022-08-28 21:33:33 +0200
committerstuebinm2022-08-28 21:34:54 +0200
commitf7066888652ed3326017adf2eb6786a21043ebf5 (patch)
tree82b14b74bd352b553eb4036f48b15d3a2c4cae37 /lib/Server
parent1b2e30c134c996e82c282b21099f21501dd966ac (diff)
some config thingyesod
works kinda well, but doesn't complain about unknown config values in json, which is kinda hmpf tbh
Diffstat (limited to '')
-rw-r--r--lib/Server.hs5
-rw-r--r--lib/Server/ControlRoom.hs4
2 files changed, 6 insertions, 3 deletions
diff --git a/lib/Server.hs b/lib/Server.hs
index 055925f..1139ff8 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -51,10 +51,13 @@ import Server.Util (Service, ServiceM, runService,
sendErrorMsg)
import Yesod (toWaiAppPlain)
+import Conferer (fetch, mkConfig)
import Extrapolation (Extrapolator (guessAnchor),
LinearExtrapolator)
import System.IO.Unsafe
+import Config (ServerConfig)
+
application :: GTFS -> Pool SqlBackend -> IO Application
application gtfs dbpool = do
doMigration dbpool
@@ -87,7 +90,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI
Nothing -> throwError err404
handleRegister tripID RegisterJson{..} = do
today <- liftIO getCurrentTime <&> utctDay
- when (not $ runsOnDay gtfs tripID today)
+ unless (runsOnDay gtfs tripID today)
$ sendErrorMsg "this trip does not run today."
expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent)
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 3c928f1..164d8ff 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -140,7 +140,7 @@ instance YesodPersist ControlRoom where
runSqlPool action pool
getRootR :: Handler Html
-getRootR = redirect (TrainsR)
+getRootR = redirect TrainsR
getTrainsR :: Handler Html
getTrainsR = do
@@ -168,7 +168,7 @@ getTrainViewR trip day = do
Just res@Trip{..} -> do
anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] []
- lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp]
+ lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
defaultLayout $ do
mr <- getMessageRender
setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))