somewhat functioning control room

tbh i've kinda lost track at what has all been changed in this, but the
control room form handling now works, and i can write announcements into
the database. Now on to making it do useful things!

8 files changed, 118 insertions, 36 deletions

diff --git a/lib/API.hs b/lib/API.hs
index e491812..9ed2846 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -69,7 +69,7 @@ type AdminAPI =
 -- documented, which would be silly and way to verbose.
 type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
-  :<|> "control" :> ControlRoomAPI
+  :<|> "cr" :> ControlRoomAPI
 
 
 -- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index cf4c939..539f69f 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -211,6 +211,8 @@ data Trip (deep :: Depth) (shape :: Depth)= Trip
   , tripStops     :: Optional deep (Vector (Stop deep))
   } deriving Generic
 
+tripForgetShape :: Trip Deep Deep -> Trip Deep Shallow
+tripForgetShape trip = trip { tripShape = shapeId (tripShape trip) }
 
 deriving instance Show (Trip Shallow Shallow)
 deriving instance Show (Trip Deep Deep)
diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs
index 26be845..918c942 100644
--- a/lib/Lucid/Forms.hs
+++ b/lib/Lucid/Forms.hs
@@ -11,7 +11,12 @@
 {-# LANGUAGE TypeOperators       #-}
 
 
-module Lucid.Forms (GToHtmlForm(..), GToHtmlFormInput(..), ToHtmlForm(..), ToHtmlFormInput(..)) where
+module Lucid.Forms ( GToHtmlForm(..)
+                   , GToHtmlFormInput(..)
+                   , ToHtmlForm(..)
+                   , ToHtmlFormInput(..)
+                   , HtmlFormOptions(..)
+                   ) where
 
 import           Data.Maybe           (maybeToList)
 import           Data.Proxy           (Proxy (..))
@@ -21,10 +26,11 @@ import           Data.Time            (Day)
 import           GHC.Generics         (C1, D1, Generic (Rep), K1, Meta (..),
                                        Rec0, S1, U1, type (:*:), type (:+:))
 import           GHC.TypeLits         (KnownSymbol, symbolVal)
-import           Lucid                (Html, ToHtml (toHtml), action_, div_,
-                                       for_, form_, id_, input_, label_,
+import           Lucid                (Html, HtmlT, ToHtml (toHtml), action_,
+                                       div_, for_, form_, id_, input_, label_,
                                        method_, name_, placeholder_, type_,
                                        value_)
+import           Lucid.Base           (relaxHtmlT)
 import           Text.ProtocolBuffers (Default (defaultValue))
 
 class GToHtmlFormInput a where
@@ -57,6 +63,10 @@ instance ToHtmlFormInput Text where
   toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name]
 instance ToHtmlFormInput Day where
   toFormInput name _ = input_ [type_ "text", name_ name]
+instance ToHtmlFormInput Bool where
+  toFormInput name _ = input_ [type_ "checkbox", name_ name]
+instance ToHtmlFormInput (Maybe Bool) where
+  toFormInput name _ = input_ [type_ "checkbox", name_ name]
 
 
 -- | generic conversion of record data types to input forms
@@ -82,14 +92,14 @@ instance GToHtmlForm a => GToHtmlForm (C1 r a) where
 
 -- | class for things which can be entered via html forms
 class ToHtmlForm a where
-  toHtmlForm :: Proxy a -> Html ()
-  default toHtmlForm :: (GToHtmlForm (Rep a)) => Proxy a -> Html ()
-  toHtmlForm = genericToHtmlForm defaultOptions
+  toHtmlForm :: Monad m => HtmlFormOptions -> Proxy a -> HtmlT m ()
+  default toHtmlForm :: (GToHtmlForm (Rep a), Monad m) => HtmlFormOptions -> Proxy a -> HtmlT m ()
+  toHtmlForm options = relaxHtmlT . genericToHtmlForm options
 
 data HtmlFormOptions = HtmlFormOptions
-  { htmlFormAction           :: Maybe Text
-  , htmlFormMethod           :: Text
-  , htmlFormSubmitButtonText :: Text
+  { formAction           :: Maybe Text
+  , formMethod           :: Text
+  , formSubmitButtonText :: Text
   }
 
 defaultOptions ::HtmlFormOptions
@@ -100,6 +110,6 @@ instance Default HtmlFormOptions where
 
 genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
 genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
-  form_ ((method_ htmlFormMethod) : maybeToList (fmap action_ htmlFormAction)) $ do
+  form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do
     gtoHtmlForm (Proxy @(Rep a _))
-    input_ [type_ "submit", value_ htmlFormSubmitButtonText]
+    input_ [type_ "submit", value_ formSubmitButtonText]
diff --git a/lib/Persist.hs b/lib/Persist.hs
index c44ae3b..f2377b6 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -68,7 +68,7 @@ RunningTrip sql=tt_tracker_token
   expires UTCTime
   blocked Bool
   tripNumber Text
-  trainset Text Maybe
+  vehicle Text Maybe
   deriving Eq Show Generic
 
 TripPing json sql=tt_trip_ping
diff --git a/lib/Server.hs b/lib/Server.hs
index 544b6ae..cc86cd2 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -65,7 +65,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
   :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
   gtfsRealtimeServer gtfs dbpool
   :<|> adminServer gtfs dbpool)
-  :<|> controlRoomServer
+  :<|> controlRoomServer gtfs dbpool
   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
index edfdeb3..7a5bdb2 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
@@ -10,52 +11,120 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 
-module Server.ControlRoom where
+module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
 
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
+import qualified Data.Map                    as M
 import           Data.Swagger                (ToSchema (..))
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
-import           Lucid                       (Html, ToHtml (toHtml), action_,
-                                              div_, for_, form_, id_, input_,
-                                              label_, method_, name_,
+import           Lucid                       (Html, HtmlT, ToHtml (toHtml), a_,
+                                              action_, div_, for_, form_, h1_,
+                                              h2_, href_, id_, input_, label_,
+                                              li_, main_, method_, name_, ol_,
                                               placeholder_, type_, value_)
-import           Servant                     (Capture, FormUrlEncoded, Get,
-                                              JSON, NoContent, PlainText, Post,
-                                              QueryParam, ReqBody,
+import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
+                                              Get, JSON, NoContent, PlainText,
+                                              Post, Proxy (Proxy), QueryParam,
+                                              ReqBody, err404, err302,
+                                              errHeaders, throwError,
                                               type (:<|>) (..), type (:>))
 import           Servant.HTML.Lucid          (HTML)
 import           Web.FormUrlEncoded          (ToForm)
 import           Web.Internal.FormUrlEncoded (Form)
 
-import           GTFS                        (CalendarDate,
-                                              CalendarExceptionType, TripID)
+import           Control.Monad               (forM_)
+import           Control.Monad.Extra         (maybeM, whenM)
+import           Data.Functor                ((<&>))
+import           Data.Map                    (Map)
+import           Data.Pool                   (Pool)
+import           Data.Time                   (getCurrentTime, utctDay)
+import           Data.Time.Calendar          (Day)
+import           Data.Time.Format.ISO8601    (iso8601Show)
+import           Database.Persist            (insert)
+import           Database.Persist.Sql        (SqlBackend)
+import           GHC.Generics                (Generic)
 import           Lucid.Forms                 (ToHtmlForm (..),
-                                              ToHtmlFormInput (..))
+                                              ToHtmlFormInput (..), formAction)
+import           Persist                     (Announcement (..), Key (..),
+                                              runSql)
 import           Server.Util                 (Service)
+import           Text.ProtocolBuffers        (Default (defaultValue))
+import           Web.FormUrlEncoded          (FromForm)
 
-data TripList = TripList
-  { tripListHeader :: Text
-  , tripListType   :: Text
-  , tripListTrips  :: [TripID]
-  }
+import           GTFS
 
 type ControlRoomAPI =
-  Get '[HTML] TripList
+  "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
+  :<|> "trip" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] (Day, Trip Deep Deep)
   :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
+  :<|> ControlRoomCranks
 
-controlRoomServer :: Service ControlRoomAPI
-controlRoomServer =
-  (pure (TripList "hallo" "welt" []))
+-- | train infra seems to involve turning lots of cranks, so here have some!
+type ControlRoomCranks =
+  "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+  :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
+  :<|> "train" :> "date" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+  :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+  :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+  :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+
+data TrainAnnounceF = TrainAnnounceF
+  { taMsg     :: Text
+  , taHeader  :: Text
+  , taLogTime :: Maybe Bool
+  } deriving (Generic, ToHtmlForm, FromForm)
+
+controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
+controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
   :<|> (\text -> do
            liftIO $ putStrLn (show text)
            pure "hello"
        )
+  :<|> controlRoomCranks dbpool
+  where handleTrip trip day = case M.lookup trip trips of
+          Just res -> pure (day, res) -- TODO: can't just assume it runs that day …
+          Nothing  -> throwError err404
+        handleTimetable maybeDay = do
+          -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
+          day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+          pure $ (day, tripsOnDay gtfs day)
+
+controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
+controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
+  where handleAnnounce tripID day TrainAnnounceF{..} = do
+          now <- liftIO $ getCurrentTime
+          AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
+            { announcementTrip = tripID
+            , announcementMessage = taMsg
+            , announcementHeader = taHeader
+            , announcementDay = day
+            , announcementUrl = Nothing
+            , announcementAnnouncedAt =
+              fmap (const now) taLogTime
+            }
+          throwError $ err302 { errHeaders = [("Location", "/cr/main")] }
 
 
 instance ToHtmlFormInput CalendarExceptionType
 instance ToHtmlForm CalendarDate
 
-instance ToHtml TripList where
-  toHtml _ = div_ "todo"
 
+instance ToHtml (Day, Trip Deep Deep) where
+  toHtml (day, Trip{..}) = crPage tripTripID $ do
+    h2_ "Stops"
+    ol_ $ forM_ tripStops $ \Stop{..} -> do
+      div_ (toHtml (stationName stopStation))
+    toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
+      (Proxy @TrainAnnounceF)
+
+instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
+  toHtml (day, trips) = crPage ("trips on " <> T.pack (iso8601Show day)) $ do
+    ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
+      a_ [href_ ("/cr/trip/"<>tripTripID<>"/"<>T.pack (iso8601Show day))] (toHtml tripTripID)
+
+-- | control room page
+crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
+crPage title content = do
+  h1_ (toHtml title)
+  main_ content
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index e3a07cb..d771736 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -123,7 +123,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
                   (dFeedEntity (toUtf8 . T.pack . show $ key))
                   { FE.vehicle = Just $ VehiclePosition
                     { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
-                    , VP.vehicle = case runningTripTrainset of
+                    , VP.vehicle = case runningTripVehicle of
                         Nothing -> Nothing
                         Just trainset -> Just $ VehicleDescriptor
                              { VD.id = Nothing
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 91b8adf..253999b 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -103,6 +103,7 @@ library
                    , PersistOrphans
                    , Persist
                    , API
+    other-modules: Server.Util
     default-language: Haskell2010
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables