diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 113 |
1 files changed, 65 insertions, 48 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 7802911..8a6022c 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -10,58 +10,61 @@ -- Implementation of the API. This module is the main point of the program. module Server (application) where -import Conduit (MonadTrans (lift), ResourceT) +import Conduit (MonadTrans (lift), ResourceT) import Control.Concurrent.STM -import Control.Monad (when) -import Control.Monad.Extra (maybeM, whenM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger.CallStack (NoLoggingT) -import Control.Monad.Reader (forM) -import Control.Monad.Trans.Maybe (MaybeT (..)) -import Data.Aeson (FromJSON (parseJSON), - ToJSON (toJSON), ToJSONKey, - genericParseJSON, - genericToJSON) -import qualified Data.Aeson as A -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 (get, delete) -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) -import qualified Data.Vector as V +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, + runStderrLoggingT) +import Control.Monad.Reader (forM) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Aeson (FromJSON (parseJSON), + ToJSON (toJSON), ToJSONKey, + genericParseJSON, genericToJSON) +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.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) +import qualified Data.Vector as V import Database.Persist import Database.Persist.Postgresql -import GHC.Generics (Generic) +import Fmt ((+|), (|+)) +import GHC.Generics (Generic) import GTFS -import Servant (Application, - FromHttpApiData (parseUrlPiece), - Server, err401, err404, serve, - throwError) -import Servant.API (Capture, FromHttpApiData, Get, - JSON, Post, ReqBody, - type (:<|>) ((:<|>))) -import Servant.Docs (DocCapture (..), - DocQueryParam (..), - ParamKind (..), ToCapture (..), - ToParam (..)) -import Servant.Server (Handler) -import Servant.Swagger (toSwagger) -import Web.PathPieces (PathPiece) +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) +import Servant.Swagger (toSwagger) +import Web.PathPieces (PathPiece) import API import Persist -import Server.GTFS_RT (gtfsRealtimeServer) +import Server.GTFS_RT (gtfsRealtimeServer) application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do @@ -77,7 +80,7 @@ doMigration pool = runSql pool $ server :: GTFS -> Pool SqlBackend -> Server CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool + :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool :<|> adminServer gtfs dbpool where handleStations = pure stations handleTimetable station maybeDay = do @@ -99,7 +102,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime checkTokenValid dbpool (coerce $ tripPingToken ping) -- TODO: are these always inserted in order? runSql dbpool $ insert ping - pure () + pure NoContent + handleWS conn = do + -- TODO test this!! + liftIO $ WS.forkPingThread conn 30 + forever $ do + msg <- liftIO $ WS.receiveData conn + case A.eitherDecode msg of + Left err -> runStderrLoggingT $ do + logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")") + liftIO $ WS.sendClose conn (C8.pack err) + Right ping -> do + checkTokenValid dbpool (coerce $ tripPingToken ping) + void $ runSql dbpool $ insert ping handleDebugState = do now <- liftIO getCurrentTime runSql dbpool $ do @@ -120,13 +135,15 @@ adminServer gtfs dbpool = pure uuid delAnnounce uuid = runSql dbpool $ do delete (AnnouncementKey uuid) + pure NoContent modTripDate one two tripId day = runSql dbpool $ do getBy (TripAndDay tripId day) >>= \case Just (Entity key (ScheduleAmendment _ _ status)) -> do when (status == two) $ delete key + pure NoContent Nothing -> do insert (ScheduleAmendment tripId day one) - pure () + pure NoContent extraTrip = error "unimplemented!" |