some config thingyesod

works kinda well, but doesn't complain about unknown config values in
json, which is kinda hmpf tbh

6 files changed, 64 insertions, 29 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 35bdee7..4a72d6c 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -34,7 +34,7 @@ import           GTFS.Realtime.FeedEntity
 import           GTFS.Realtime.FeedMessage   (FeedMessage)
 import           Persist
 
-data RegisterJson = RegisterJson
+newtype RegisterJson = RegisterJson
   { registerAgent :: Text }
   deriving (Show, Generic)
 
diff --git a/lib/Config.hs b/lib/Config.hs
new file mode 100644
index 0000000..c76261e
--- /dev/null
+++ b/lib/Config.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveGeneric #-}
+-- |
+
+module Config where
+import           Conferer                 (DefaultConfig (configDef),
+                                           FromConfig)
+import           Conferer.FromConfig.Warp ()
+import           Data.ByteString          (ByteString)
+import           Data.Text                (Text)
+import           GHC.Generics             (Generic)
+import           Network.Wai.Handler.Warp (Settings)
+
+data ServerConfig = ServerConfig
+  { serverConfigWarp         :: Settings
+  , serverConfigDbString     :: ByteString
+  , serverConfigGtfs         :: FilePath
+  , serverConfigZoneinfoPath :: FilePath
+  } deriving Generic
+
+instance FromConfig ServerConfig
+
+instance DefaultConfig ServerConfig where
+  configDef = ServerConfig
+    { serverConfigWarp = configDef
+    , serverConfigDbString = ""
+    , serverConfigGtfs = "./gtfs.zip"
+    , serverConfigZoneinfoPath = "/etc/zoneinfo/"
+    }
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 9b3f89f..4b427d0 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -50,7 +50,7 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $
   print (observedProgress, expectedProgress)
   pure $ round $ (expectedProgress - observedProgress) * int2Double expectedTravelTime
   where closestPoint =
-            minimumBy (compare `on` (euclid (trainPingLat, trainPingLong))) line
+            minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line
         nextStop = snd $
             minimumBy (compare `on` fst)
             $ V.filter (\(dist,_) -> dist > 0)
@@ -64,8 +64,8 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $
             toSeconds (stopArrival nextStop) tzseries trainPingTimestamp
             - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp
         expectedProgress =
-            (int2Double ((utcToSeconds trainPingTimestamp runningDay)
-                         - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp))
+            int2Double (utcToSeconds trainPingTimestamp runningDay
+                         - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp)
             / int2Double expectedTravelTime
             -- where crop a
             --         | a < 0 = 0
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 2047d56..9eed8b5 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -1,19 +1,18 @@
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE NamedFieldPuns             #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE StandaloneKindSignatures   #-}
-{-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE DeriveAnyClass           #-}
+{-# LANGUAGE DeriveGeneric            #-}
+{-# LANGUAGE DerivingStrategies       #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE RecordWildCards          #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TupleSections            #-}
+{-# LANGUAGE TypeApplications         #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE UndecidableInstances     #-}
 
 -- | All kinds of stuff that has to deal with GTFS directly
 -- (i.e. parsing, querying, Aeson instances, etc.)
@@ -467,7 +466,7 @@ data GTFS = GTFS
 
 loadRawGtfs :: FilePath -> IO RawGTFS
 loadRawGtfs path = do
-    zip <- Zip.toArchive <$> LB.readFile "./gtfs.zip"
+    zip <- Zip.toArchive <$> LB.readFile path
     RawGTFS
       <$> decodeTable' "stops.txt" zip
       <*> decodeTable' "stop_times.txt" zip
@@ -490,8 +489,13 @@ loadRawGtfs path = do
           Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip"
           Just a  -> pure a
 
-loadGtfs :: FilePath -> IO GTFS
-loadGtfs path = do
+-- | load a gtfs file "the complicated way", creating data structures much nicer
+-- to work with than the raw representation of GTFS.
+--
+-- Note that this additionally needs a path to the machine's timezone info
+-- (usually /etc/zoneinfo or /usr/shared/zoneinfo)
+loadGtfs :: FilePath -> FilePath -> IO GTFS
+loadGtfs path zoneinforoot = do
     shallow@RawGTFS{..} <- loadRawGtfs path
     -- TODO: sort these according to sequence numbers
     let shapes =
@@ -500,9 +504,9 @@ loadGtfs path = do
           (fromMaybe mempty rawShapePoints)
     -- all agencies must have the same timezone, so just take the first's
     let tzname = agencyTimezone $ V.head rawAgencies
-    tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname)
+    tzseries <- getTimeZoneSeriesFromOlsonFile (zoneinforoot<>T.unpack tzname)
     let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies
-    routes' <- V.mapM (\raw -> pushRoute agencies' raw) rawRoutes
+    routes' <- V.mapM (pushRoute agencies') rawRoutes
       <&> mapFromVector routeId
     stops' <- V.mapM (pushStop tzseries tzname rawStations) rawStops
     trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips
@@ -573,7 +577,7 @@ loadGtfs path = do
 
 
       sortShapePoint :: ShapePoint -> Map Text Shape -> Map Text Shape
-      sortShapePoint ShapePoint{..} shapes = M.alter appendPoint shapePtId shapes
+      sortShapePoint ShapePoint{..} = M.alter appendPoint shapePtId
         where
           point = (shapePtLat, shapePtLong)
           appendPoint = \case
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))