diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 37 | ||||
| -rw-r--r-- | lib/GTFS.hs | 10 | ||||
| -rw-r--r-- | lib/Server.hs | 2 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 53 |
4 files changed, 84 insertions, 18 deletions
@@ -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 |