barebones webform API & frontend

4 files changed, 84 insertions, 18 deletions

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