aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server.hs2
-rw-r--r--lib/Server/ControlRoom.hs53
2 files changed, 55 insertions, 0 deletions
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