From e254e7ae61ce55cde3e4dc0bae5a94e16577f7bf Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 3 Jul 2022 00:39:34 +0200 Subject: remove some unused imports --- lib/API.hs | 20 +++++------ lib/Server.hs | 41 +++++++---------------- lib/Server/GTFS_RT.hs | 91 ++++++++++++++++++++++++--------------------------- 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 } -- cgit v1.2.3