diff options
| author | stuebinm | 2022-08-28 21:33:33 +0200 |
|---|---|---|
| committer | stuebinm | 2022-08-28 21:34:54 +0200 |
| commit | f7066888652ed3326017adf2eb6786a21043ebf5 (patch) | |
| tree | 82b14b74bd352b553eb4036f48b15d3a2c4cae37 /lib/Server | |
| parent | 1b2e30c134c996e82c282b21099f21501dd966ac (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.hs | 5 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 4 |
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)) |