aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/API.hs20
-rw-r--r--lib/Server.hs41
-rw-r--r--lib/Server/GTFS_RT.hs91
3 files changed, 63 insertions, 89 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 8d352e1..a04e131 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -13,22 +13,22 @@ import Data.Swagger (Swagger)
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
-import GTFS
-import GTFS.Realtime.FeedEntity
-import GTFS.Realtime.FeedMessage (FeedMessage)
-import Persist
+import Data.UUID (UUID)
import Servant (Application,
FromHttpApiData (parseUrlPiece),
- Server, err401, err404, serve,
- throwError, type (:>))
-import Servant.API (Capture, FromHttpApiData, Get, JSON,
- NoContent, Post, QueryParam,
- ReqBody, type (:<|>) ((:<|>)))
+ Server, err401, err404, type (:>))
+import Servant.API (Capture, Get, JSON, NoContent, Post,
+ QueryParam, ReqBody,
+ type (:<|>) ((:<|>)))
import Servant.API.WebSocket (WebSocket)
import Servant.GTFS.Realtime (Proto)
import Servant.Swagger (HasSwagger (..))
-import Data.UUID (UUID)
+import GTFS
+import GTFS.Realtime.FeedEntity
+import GTFS.Realtime.FeedMessage (FeedMessage)
+import Persist
+
-- | The server's API (as it is actually intended).
type API = "stations" :> Get '[JSON] (Map StationID Station)
diff --git a/lib/Server.hs b/lib/Server.hs
index e84be7d..a5a5ff9 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -11,57 +11,38 @@
-- Implementation of the API. This module is the main point of the program.
module Server (application) where
-import Conduit (MonadTrans (lift), ResourceT)
import Control.Monad (forever, void, when)
import Control.Monad.Extra (maybeM, whenM)
import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Logger (NoLoggingT, logWarnN)
+import Control.Monad.Logger (logWarnN)
import Control.Monad.Reader (forM)
-import Control.Monad.Trans.Maybe (MaybeT (..))
-import Data.Aeson (FromJSON (parseJSON),
- ToJSON (toJSON), ToJSONKey,
- genericParseJSON, genericToJSON)
+import Control.Monad.Trans (lift)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as C8
import Data.Coerce (coerce)
import Data.Functor ((<&>))
-import Data.Map (Map)
import qualified Data.Map as M
import Data.Pool (Pool)
import Data.Proxy (Proxy (Proxy))
-import Data.Swagger hiding (delete, get)
+import Data.Swagger (toSchema)
import Data.Text (Text)
import Data.Time (NominalDiffTime,
UTCTime (utctDay), addUTCTime,
- dayOfWeek, diffUTCTime,
- getCurrentTime, nominalDay)
-import Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-import Data.Vector (Vector)
+ diffUTCTime, getCurrentTime,
+ nominalDay)
import qualified Data.Vector as V
import Database.Persist
-import Database.Persist.Postgresql
+import Database.Persist.Postgresql (SqlBackend, runMigration)
import Fmt ((+|), (|+))
-import GHC.Generics (Generic)
-import GTFS
import qualified Network.WebSockets as WS
-import Servant (Application,
- FromHttpApiData (parseUrlPiece),
- Server, err401, err404, serve,
- throwError)
-import Servant.API (Capture, FromHttpApiData, Get,
- JSON, NoContent (..), Post,
- ReqBody, type (:<|>) ((:<|>)))
-import Servant.Docs (DocCapture (..),
- DocQueryParam (..),
- ParamKind (..), ToCapture (..),
- ToParam (..))
-import Servant.Server (Handler, ServerT, hoistServer)
+import Servant (Application, err401, err404,
+ serve, throwError)
+import Servant.API (NoContent (..), (:<|>) (..))
+import Servant.Server (Handler, hoistServer)
import Servant.Swagger (toSwagger)
-import Web.PathPieces (PathPiece)
import API
+import GTFS
import Persist
import Server.GTFS_RT (gtfsRealtimeServer)
import Server.Util (Service, ServiceM, runService)
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 85ea8cd..e3a07cb 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -3,32 +3,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
module Server.GTFS_RT (gtfsRealtimeServer) where
-import qualified Data.Sequence as Seq
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Time.Clock.System (SystemTime (systemSeconds),
- getSystemTime,
- utcToSystemTime)
-import GTFS.Realtime.Alert as AL (Alert (..))
-import GTFS.Realtime.Alert.Cause (Cause (CONSTRUCTION))
-import GTFS.Realtime.Alert.Effect (Effect (DETOUR))
-import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel (WARNING))
-import GTFS.Realtime.EntitySelector as ES (EntitySelector (..))
-import GTFS.Realtime.FeedEntity as FE (FeedEntity (..))
-import GTFS.Realtime.FeedHeader (FeedHeader (FeedHeader))
-import GTFS.Realtime.FeedHeader.Incrementality (Incrementality (FULL_DATASET))
-import GTFS.Realtime.FeedMessage as FM (FeedMessage (..))
-import GTFS.Realtime.TimeRange (TimeRange (TimeRange))
-import GTFS.Realtime.TranslatedString (TranslatedString (TranslatedString))
-import GTFS.Realtime.TranslatedString.Translation (Translation (Translation))
-import GTFS.Realtime.TripDescriptor as TD (TripDescriptor (..))
import Prelude hiding (id)
-import Text.ProtocolBuffers (Utf8 (Utf8),
- defaultValue)
-import Text.ProtocolBuffers.WireMessage (zzEncode64)
import API (GtfsRealtimeAPI)
import Control.Monad (forM)
@@ -38,12 +16,16 @@ import Data.Functor ((<&>))
import Data.Maybe (catMaybes)
import Data.Pool (Pool)
import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
-import Data.Time (Day)
import Data.Time.Calendar (Day, toGregorian)
import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time.Clock.System (SystemTime (systemSeconds),
+ getSystemTime,
+ utcToSystemTime)
import qualified Data.UUID as UUID
import Data.Word (Word64)
import Database.Persist (Entity (Entity),
@@ -52,18 +34,29 @@ import Database.Persist (Entity (Entity),
import Database.Persist.Postgresql (SqlBackend)
import GHC.Float (double2Float)
import GTFS (GTFS, TripID)
+import GTFS.Realtime.Alert as AL (Alert (..))
+import GTFS.Realtime.Alert.SeverityLevel (SeverityLevel (WARNING))
+import GTFS.Realtime.EntitySelector as ES (EntitySelector (..))
+import GTFS.Realtime.FeedEntity as FE (FeedEntity (..))
+import GTFS.Realtime.FeedHeader (FeedHeader (FeedHeader))
+import GTFS.Realtime.FeedHeader.Incrementality (Incrementality (FULL_DATASET))
+import GTFS.Realtime.FeedMessage as FM (FeedMessage (..))
import GTFS.Realtime.Position as POS (Position (..))
+import GTFS.Realtime.TimeRange (TimeRange (TimeRange))
+import GTFS.Realtime.TranslatedString (TranslatedString (TranslatedString))
+import GTFS.Realtime.TranslatedString.Translation (Translation (Translation))
+import GTFS.Realtime.TripDescriptor as TD (TripDescriptor (..))
import GTFS.Realtime.VehicleDescriptor as VD (VehicleDescriptor (..))
import GTFS.Realtime.VehiclePosition as VP (VehiclePosition (..))
import Persist (Announcement (..),
- EntityField (TripPingToken),
+ EntityField (..),
Key (..),
RunningTrip (..),
TripPing (..),
runSql)
import Servant.API ((:<|>) (..))
-import Servant.Server (Handler (Handler),
- Server)
+import Text.ProtocolBuffers (Utf8 (Utf8),
+ defaultValue)
import Server.Util (Service)
@@ -95,28 +88,28 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
(dFeedEntity (uuidUtf8 uuid))
- { alert =
- (Just $ Alert
- { active_period = [TimeRange Nothing Nothing defaultValue]
+ { alert = Just $ Alert
+ { active_period = [TimeRange Nothing Nothing defaultValue]
-- TODO: is this time range reasonable, needed, etc.?
- , informed_entity =
- [dEntitySelector
- { ES.trip =
- Just (dTripDescriptor announcementTrip (Just announcementDay))
- }
- ]
- , cause = Nothing
- , effect = Nothing
- , url = fmap (lang "de" . toUtf8) announcementUrl
- , header_text = Just $ lang "de" (toUtf8 announcementHeader)
- , description_text = Just $ lang "de" (toUtf8 announcementMessage)
- , tts_header_text = Nothing
- , tts_description_text = Nothing
- , severity_level = Nothing
- , image = Nothing
- , image_alternative_text = Nothing
- , AL.ext'field = defaultValue
- }) }
+ , informed_entity =
+ [dEntitySelector
+ { ES.trip =
+ Just (dTripDescriptor announcementTrip (Just announcementDay))
+ }
+ ]
+ , cause = Nothing
+ , effect = Nothing
+ , url = fmap (lang "de" . toUtf8) announcementUrl
+ , header_text = Just $ lang "de" (toUtf8 announcementHeader)
+ , description_text = Just $ lang "de" (toUtf8 announcementMessage)
+ , tts_header_text = Nothing
+ , tts_description_text = Nothing
+ , severity_level = Nothing
+ , image = Nothing
+ , image_alternative_text = Nothing
+ , AL.ext'field = defaultValue
+ }
+ }
handleTripUpdates = runSql dbpool $ do
error "unimplemented!"
-- TODO: how to propagate delay values to next stops?
@@ -125,7 +118,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
(running :: [Entity RunningTrip]) <- selectList [] []
pings <- forM running $ \(Entity key entity) -> do
selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
- dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings
+ dFeedMessage $ Seq.fromList $ mkPosition <$> catMaybes pings
where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
(dFeedEntity (toUtf8 . T.pack . show $ key))
{ FE.vehicle = Just $ VehiclePosition
@@ -134,7 +127,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
Nothing -> Nothing
Just trainset -> Just $ VehicleDescriptor
{ VD.id = Nothing
- , VD.label = (Just (toUtf8 trainset))
+ , VD.label = Just (toUtf8 trainset)
, VD.license_plate = Nothing
, VD.ext'field = defaultValue
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 20:26:06 +0000