barebones webform API & frontend

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