better module names

1 files changed, 0 insertions, 208 deletions

diff --git a/lib/Server/GTFSRT.hs b/lib/Server/GTFSRT.hs
deleted file mode 100644
index bd285ff..0000000
--- a/lib/Server/GTFSRT.hs
+++ /dev/null
@@ -1,208 +0,0 @@
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedLists   #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE TypeApplications  #-}
-
-module Server.GTFSRT (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)
-import           Control.Monad.IO.Class                     (MonadIO (..))
-import           Data.ByteString.Lazy                       (fromStrict)
-import           Data.Functor                               ((<&>))
-import           Data.Maybe                                 (catMaybes)
-import           Data.Pool                                  (Pool)
-import           Data.Sequence                              (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 qualified Data.UUID                                  as UUID
-import           Data.Word                                  (Word64)
-import           Database.Persist                           (Entity (Entity),
-                                                             PersistQueryRead (selectFirst),
-                                                             selectList, (==.))
-import           Database.Persist.Postgresql                (SqlBackend)
-import           GHC.Float                                  (double2Float)
-import           GTFS                                       (GTFS, TripID)
-import           GTFS.Realtime.Position                     as POS (Position (..))
-import           GTFS.Realtime.VehicleDescriptor            as VD (VehicleDescriptor (..))
-import           GTFS.Realtime.VehiclePosition              as VP (VehiclePosition (..))
-import           Persist                                    (Announcement (..),
-                                                             EntityField (TripPingToken),
-                                                             Key (..),
-                                                             RunningTrip (..),
-                                                             TripPing (..),
-                                                             runSql)
-import           Servant.API                                ((:<|>) (..))
-import           Servant.Server                             (Handler (Handler),
-                                                             Server)
-
-
-uuidUtf8 :: UUID.UUID -> Utf8
-uuidUtf8 = Utf8 . fromStrict . UUID.toASCIIBytes
-
-toUtf8 :: Text -> Utf8
-toUtf8 = Utf8 . fromStrict . encodeUtf8
-
--- | formats a day in the "stupid" format used by gtfs realtime
-toStupidDate :: Day -> Utf8
-toStupidDate date = toUtf8
-  $ pad 4 year <> pad 2 month <> pad 2 day
-  where (year, month, day) = toGregorian date
-        pad len num = T.pack $ if ndigits < len
-          then replicate (len - ndigits) '0' <> show num
-          else show num
-          where ndigits = length (show num)
-
--- | basically unix timestamps, raw (because why not i guess)
-toStupidTime :: UTCTime -> Word64
-toStupidTime = fromIntegral . systemSeconds . utcToSystemTime
-
-gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Server GtfsRealtimeAPI
-gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions
-  where handleServiceAlerts = runSql dbpool $ do
-            -- TODO filter: only select current & future days
-            announcements <- selectList [] []
-            dFeedMessage $ Seq.fromList $ fmap mkAlert announcements
-            where mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
-                    (dFeedEntity (uuidUtf8 uuid))
-                    { 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
-                        }) }
-        handleTripUpdates = runSql dbpool $ do
-          -- TODO: how to propagate delay values to next stops?
-          pure undefined
-        handleVehiclePositions = runSql dbpool $ do
-          (running :: [Entity RunningTrip]) <- selectList [] []
-          pings <- forM running $ \(Entity key entity) -> do
-            selectFirst [TripPingToken ==. key] [] <&> fmap (, entity)
-          dFeedMessage $ Seq.fromList $ fmap mkPosition $ catMaybes pings
-          where mkPosition (Entity (TripPingKey key) TripPing{..}, RunningTrip{..}) =
-                  (dFeedEntity (toUtf8 . T.pack . show $ key))
-                  { FE.vehicle = Just $ VehiclePosition
-                    { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
-                    , VP.vehicle = case runningTripTrainset of
-                        Nothing -> Nothing
-                        Just trainset -> Just $ VehicleDescriptor
-                             { VD.id = Nothing
-                             , VD.label = (Just (toUtf8 trainset))
-                             , VD.license_plate = Nothing
-                             , VD.ext'field = defaultValue
-                             }
-                    , position = Just $ Position
-                      { latitude = double2Float tripPingLat
-                      , longitude = double2Float tripPingLong
-                      , odometer = Nothing
-                      , speed = Nothing
-                      , bearing = Nothing
-                      , POS.ext'field = defaultValue
-                      }
-                    -- TODO: at least one of these should probably be given
-                    , current_stop_sequence = Nothing
-                    , stop_id = Nothing
-                    , current_status = Nothing
-                    , timestamp = Just (toStupidTime tripPingTimestamp)
-                    , congestion_level = Nothing
-                    , occupancy_status = Nothing
-                    , occupancy_percentage = Nothing
-                    , multi_carriage_details = []
-                    , VP.ext'field = defaultValue
-                    }
-                  }
-
-
-lang :: Utf8 -> Utf8 -> TranslatedString
-lang code msg = TranslatedString [Translation msg (Just code) defaultValue] defaultValue
-
--- | a default FeedMessage, issued at the current system time
--- TODO: do we ever need incremental updates?
--- TODO: maybe instead use last update time?
-dFeedMessage :: MonadIO m => Seq FeedEntity -> m FeedMessage
-dFeedMessage entities = do
-  now <- liftIO getSystemTime <&> systemSeconds
-  pure $ FeedMessage
-    { header = FeedHeader "2.0" (Just FULL_DATASET) (Just $ fromIntegral now) defaultValue
-    , entity = entities
-    , FM.ext'field = defaultValue
-    }
-
--- | a dummy FeedEntity (use record updates to add meaningful values to this)
-dFeedEntity :: Utf8 -> FeedEntity
-dFeedEntity id = FeedEntity
-  { id
-  , is_deleted = Nothing
-  , trip_update = Nothing
-  , vehicle = Nothing
-  , alert = Nothing
-  , shape = Nothing
-  , FE.ext'field = defaultValue
-  }
-
-dEntitySelector :: EntitySelector
-dEntitySelector = EntitySelector
-  { agency_id = Nothing
-  , route_id = Nothing
-  , route_type = Nothing
-  , trip = Nothing
-  , stop_id = Nothing
-  , direction_id = Nothing
-  , ES.ext'field = defaultValue
-  }
-
-dTripDescriptor :: TripID -> Maybe Day -> TripDescriptor
-dTripDescriptor tripID day = TripDescriptor
-  { trip_id = Just (toUtf8 tripID)
-  , route_id = Nothing
-  , direction_id = Nothing
-  , start_time = Nothing
-  , start_date = fmap toStupidDate day
-  , schedule_relationship = Nothing
-  , TD.ext'field = defaultValue
-  }