diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 70 |
1 files changed, 8 insertions, 62 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 1aaf630..6c293f0 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -3,9 +3,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedLists #-} -- Implementation of the API. This module is the main point of the program. @@ -13,7 +13,7 @@ module Server (application) where import Conduit (MonadTrans (lift), ResourceT) import Control.Concurrent.STM import Control.Monad (when) -import Control.Monad.Extra (whenM, maybeM) +import Control.Monad.Extra (maybeM, whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger.CallStack (NoLoggingT) import Control.Monad.Reader (forM) @@ -58,27 +58,10 @@ import Servant.Docs (DocCapture (..), import Servant.Server (Handler) import Servant.Swagger (toSwagger) import Web.PathPieces (PathPiece) -import Text.ProtocolBuffers (defaultValue) -import qualified Data.Sequence as Seq -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Time.Clock.System (SystemTime(systemSeconds), getSystemTime) -import Text.ProtocolBuffers.WireMessage (zzEncode64) - -import GTFS.Realtime.FeedMessage (FeedMessage(..)) -import GTFS.Realtime.FeedEntity ( FeedEntity(FeedEntity) ) -import GTFS.Realtime.FeedHeader (FeedHeader(FeedHeader)) -import GTFS.Realtime.FeedHeader.Incrementality (Incrementality(FULL_DATASET)) import API import Persist -import GTFS.Realtime.Alert (Alert(Alert)) -import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel(WARNING)) -import GTFS.Realtime.Alert.Cause (Cause(CONSTRUCTION)) -import GTFS.Realtime.Alert.Effect (Effect(DETOUR)) -import GTFS.Realtime.TranslatedString (TranslatedString(TranslatedString)) -import GTFS.Realtime.TranslatedString.Translation (Translation(Translation)) -import GTFS.Realtime.TimeRange (TimeRange(TimeRange)) -import GTFS.Realtime.EntitySelector (EntitySelector(EntitySelector)) +import Server.GTFSRT (gtfsRealtimeServer) application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do @@ -94,7 +77,8 @@ doMigration pool = runSql pool $ server :: GTFS -> Pool SqlBackend -> Server CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer + :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool + :<|> adminServer gtfs dbpool where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) @@ -125,47 +109,9 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime pure (M.fromList pairs) handleDebugAPI = pure $ toSwagger (Proxy @API) -gtfsRealtimeServer :: Server GtfsRealtimeAPI -gtfsRealtimeServer = handleServiceAlerts :<|> handleDummy :<|> handleDummy - where handleDummy = do - pure $ FeedEntity - "1234" - Nothing - Nothing - Nothing - Nothing - Nothing - defaultValue - handleServiceAlerts = do - now <- liftIO getSystemTime <&> systemSeconds - pure $ FeedMessage - (FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue) - (Seq.fromList - [FeedEntity - "0" - Nothing - Nothing - Nothing - (Just $ Alert - [TimeRange (Just $ fromIntegral (now - 1000)) Nothing defaultValue] - [EntitySelector Nothing (Just "Passau - Freyung") Nothing Nothing Nothing Nothing defaultValue] - (Just CONSTRUCTION) - (Just DETOUR) - (lang "de" "https://ilztalbahn.eu") - (lang "de" "Da liegt ein Baum auf der Strecke") - (lang "de" "Leider liegt ein Baum auf der Strecke. Solange fährt hier nix.") - Nothing - Nothing - (Just WARNING) - Nothing - Nothing - defaultValue - ) - Nothing - defaultValue - ]) - defaultValue - lang code msg = Just $ TranslatedString [Translation msg (Just code) defaultValue] defaultValue + +adminServer :: GTFS -> Pool SqlBackend -> Server AdminAPI +adminServer = undefined -- TODO: proper debug logging for expired tokens |