From 198290cf11d859aa7f10e9377db8b65646340bca Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 3 Jul 2022 22:41:46 +0200 Subject: barebones webform API & frontend --- lib/API.hs | 37 ++++++++++++++++++--------------- lib/GTFS.hs | 10 ++++++++- lib/Server.hs | 2 ++ lib/Server/ControlRoom.hs | 53 +++++++++++++++++++++++++++++++++++++++++++++++ todo.org | 16 ++++++++++++++ tracktrain.cabal | 4 ++++ 6 files changed, 104 insertions(+), 18 deletions(-) create mode 100644 lib/Server/ControlRoom.hs diff --git a/lib/API.hs b/lib/API.hs index a04e131..f95132a 100644 --- a/lib/API.hs +++ b/lib/API.hs @@ -7,27 +7,29 @@ -- Haskell type. All other descriptions of the API are generated from this one. module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import Data.Swagger (Swagger) -import Data.Swagger.ParamSchema (ToParamSchema (..)) -import Data.Text (Text) -import Data.Time (Day, UTCTime) -import Data.UUID (UUID) -import Servant (Application, - FromHttpApiData (parseUrlPiece), - 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.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Swagger (Swagger) +import Data.Swagger.ParamSchema (ToParamSchema (..)) +import Data.Text (Text) +import Data.Time (Day, UTCTime) +import Data.UUID (UUID) +import Servant (Application, FormUrlEncoded, + FromHttpApiData (parseUrlPiece), + Server, err401, err404, type (:>)) +import Servant.API (Capture, Get, JSON, NoContent, + PlainText, Post, QueryParam, + ReqBody, type (:<|>) ((:<|>))) +import Servant.API.WebSocket (WebSocket) +import Servant.GTFS.Realtime (Proto) +import Servant.Swagger (HasSwagger (..)) +import Web.Internal.FormUrlEncoded (Form) import GTFS import GTFS.Realtime.FeedEntity -import GTFS.Realtime.FeedMessage (FeedMessage) +import GTFS.Realtime.FeedMessage (FeedMessage) import Persist +import Server.ControlRoom -- | The server's API (as it is actually intended). @@ -45,6 +47,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "gtfs" :> GtfsRealtimeAPI -- TODO: this should be behind auth / OpenID or something :<|> "admin" :> AdminAPI + :<|> "control" :> ControlRoomAPI -- | The API used for publishing gtfs realtime updates type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage diff --git a/lib/GTFS.hs b/lib/GTFS.hs index 68d92dc..cf4c939 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -19,7 +19,6 @@ -- (i.e. parsing, querying, Aeson instances, etc.) module GTFS where - import qualified Codec.Archive.Zip as Zip import Control.Monad.ST (runST) import Data.Aeson (FromJSON, @@ -48,6 +47,8 @@ import qualified Data.Vector.Algorithms.Intro as V import Fmt ((+|), (|+)) import GHC.Generics (Generic) import Text.Regex.TDFA ((=~)) +import Web.Internal.FormUrlEncoded (FromForm (..)) +import Web.Internal.HttpApiData (FromHttpApiData (..)) -- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions) import Control.Lens import Data.Char (toLower) @@ -178,6 +179,12 @@ data Calendar = Calendar data CalendarExceptionType = ServiceAdded | ServiceRemoved deriving (Show, Eq, Generic, ToJSON, FromJSON) +instance FromHttpApiData CalendarExceptionType where + parseUrlPiece = \case + "added" -> Right ServiceAdded + "removed" -> Right ServiceRemoved + unknown -> Left ("unknown CalendarExceptionType: "<>unknown) + data CalendarDate = CalendarDate { caldateServiceId :: Text , caldateDate :: Day @@ -188,6 +195,7 @@ instance FromJSON CalendarDate where parseJSON = genericParseJSON (aesonOptions "caldate") instance ToJSON CalendarDate where toJSON = genericToJSON (aesonOptions "caldate") +instance FromForm CalendarDate data Trip (deep :: Depth) (shape :: Depth)= Trip { tripRoute :: Text diff --git a/lib/Server.hs b/lib/Server.hs index a5a5ff9..539e3ce 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -44,6 +44,7 @@ import Servant.Swagger (toSwagger) import API import GTFS import Persist +import Server.ControlRoom import Server.GTFS_RT (gtfsRealtimeServer) import Server.Util (Service, ServiceM, runService) @@ -64,6 +65,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool :<|> adminServer gtfs dbpool + :<|> controlRoomServer where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs new file mode 100644 index 0000000..6f5999f --- /dev/null +++ b/lib/Server/ControlRoom.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Server.ControlRoom where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Swagger (ToSchema (..)) +import Data.Text (Text) +import GTFS +import Lucid +import Servant +import Servant.API (Capture, Get, JSON, NoContent, + PlainText, Post, QueryParam, + ReqBody, type (:<|>) ((:<|>))) +import Servant.HTML.Lucid (HTML) +import Server.Util +import Web.Internal.FormUrlEncoded (Form) + +data TripList = TripList + { tripListHeader :: Text + , tripListType :: Text + , tripListTrips :: [TripID] + } + +type ControlRoomAPI = + Get '[HTML] TripList + :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text + +controlRoomServer :: Service ControlRoomAPI +controlRoomServer = + (pure (TripList "hallo" "welt" [])) + :<|> (\text -> do + liftIO $ putStrLn (show text) + pure "hello" + ) + +instance ToHtml TripList where + toHtml TripList{..} = form_ [action_ "./irgendwo", method_ "post"] $ do + input_ [type_ "text", name_ "caldateServiceId"] + input_ [type_ "text", name_ "caldateDate"] + input_ [type_ "text", name_ "caldateExceptionType"] + input_ [type_ "submit", value_ "hallo!"] + +instance ToSchema Form where + declareNamedSchema _ = undefined +instance ToSchema TripList where + declareNamedSchema _ = undefined +instance ToSchema CalendarDate where + declareNamedSchema _ = undefined diff --git a/todo.org b/todo.org index be21561..f4285ed 100644 --- a/todo.org +++ b/todo.org @@ -14,7 +14,23 @@ ** TODO implement trip updates * TODO frontend stuff ("leitstelle") ** TODO write a webform API +- cancel trip +- add announcement to trip +- add trip +- add delay (only "now", not per-station?) +- edit trip metainfo +- add extra train number not in gtfs (optional) +- ** TODO static pages frontend +needed pages: + - auth (openID?) + - trips, filterable by: everything, currently running + - actions: cancel trip, add trip date + - single trip view + - actions: add announcement, cancel + - self-reload page to keep up to date? + - potentially more (e.g. accessability info for gtfs-rt) + - (optional) add extraordinary trip ** TODO auth (openID? How to test?) ** TODO dynamic content via logging/monitoring etc. * TODO find out if we need to support VDV standards diff --git a/tracktrain.cabal b/tracktrain.cabal index fe8ba49..7f89cb9 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -77,6 +77,8 @@ library , servant-swagger , servant-docs , servant-websockets + , servant-lucid + , lucid , websockets , lens , persistent @@ -86,6 +88,7 @@ library , unliftio-core , conduit , path-pieces + , http-api-data , either , resource-pool , transformers @@ -95,6 +98,7 @@ library exposed-modules: GTFS , Server , Server.GTFS_RT + , Server.ControlRoom , PersistOrphans , Persist , API -- cgit v1.2.3