aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/ControlRoom.hs
diff options
context:
space:
mode:
authorstuebinm2022-08-14 19:30:44 +0200
committerstuebinm2022-08-14 19:30:44 +0200
commitddbbd02dc816c076faaa9141b3aa4853da83749f (patch)
tree2a20abdfac9577feedb522bd77ef6e8a10e5a0f4 /lib/Server/ControlRoom.hs
parentce14bc010a8f97cd3bab6f5cbd998f614b811546 (diff)
control room: translations & form input
still basic, but works pretty well overall
Diffstat (limited to 'lib/Server/ControlRoom.hs')
-rw-r--r--lib/Server/ControlRoom.hs348
1 files changed, 156 insertions, 192 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 0971e79..0e3f01e 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,89 +1,98 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
module Server.ControlRoom (ControlRoom(..)) where
-import Control.Monad (unless, when)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.Map as M
-import Data.Swagger (ToSchema (..))
-import Data.Text (Text)
-import qualified Data.Text as T
-import Web.FormUrlEncoded (ToForm)
-import Web.Internal.FormUrlEncoded (Form)
-
-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 Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import Database.Persist (Entity (..), delete, entityVal,
- get, insert, selectList, (==.))
-import Database.Persist.Sql (SqlBackend, PersistFieldSql,
- runSqlPool)
-import GHC.Generics (Generic)
-import Persist (AmendmentStatus,
- Announcement (..),
- EntityField (..), Key (..),
- ScheduleAmendment (ScheduleAmendment),
- runSql)
-import Server.Util (Service, redirect)
-import Text.ProtocolBuffers (Default (defaultValue))
-import Web.FormUrlEncoded (FromForm)
-import Fmt ((+|), (|+))
-import Yesod
-import Data.List (lookup)
-import Text.Read (readMaybe)
-import Text.Blaze.Html (ToMarkup(..))
-import qualified Data.Vector as V
+import Control.Monad (forM_)
+import Control.Monad.Extra (maybeM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.ByteString.Char8 as C8
+import Data.Functor ((<&>))
+import Data.List (lookup)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Pool (Pool)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (getCurrentTime, utctDay)
+import Data.Time.Calendar (Day)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import Database.Persist (Entity (..), delete, entityVal, get,
+ insert, selectList, (==.))
+import Database.Persist.Sql (PersistFieldSql, SqlBackend,
+ runSqlPool)
+import Fmt ((+|), (|+))
+import GHC.Generics (Generic)
+import Persist (AmendmentStatus, Announcement (..),
+ EntityField (..), Key (..),
+ ScheduleAmendment (ScheduleAmendment),
+ runSql)
+import Server.Util (Service)
+import Text.Blaze.Html (ToMarkup (..))
+import Text.ProtocolBuffers (Default (defaultValue))
+import Text.Read (readMaybe)
+import Yesod
+import Yesod.Form
import GTFS
data ControlRoom = ControlRoom
{ getBaseurl :: Text
- , getGtfs :: GTFS
- , getPool :: Pool SqlBackend
+ , getGtfs :: GTFS
+ , getPool :: Pool SqlBackend
}
+mkMessage "ControlRoom" "messages" "en"
+
mkYesod "ControlRoom" [parseRoutes|
-/main MainR GET
-/train/#TripID/#Day TrainViewR GET
+/ RootR GET
+/trains TrainsR GET
+/train/id/#TripID/#Day TrainViewR GET
+/train/announce/#TripID/#Day AnnounceR POST
+/train/del-announce/#UUID DelAnnounceR GET
+/trips TripsViewR GET
+/trip/#TripID TripViewR GET
|]
instance Yesod ControlRoom where
approot = ApprootMaster (\cr -> getBaseurl cr)
+instance RenderMessage ControlRoom FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
-- which backend we're using and how to run an action.
instance YesodPersist ControlRoom where
type YesodPersistBackend ControlRoom = SqlBackend
-
runDB action = do
pool <- getYesod <&> getPool
runSqlPool action pool
-getMainR :: Handler Html
-getMainR = do
+
+
+getRootR :: Handler Html
+getRootR = redirect (TrainsR)
+
+getTrainsR :: Handler Html
+getTrainsR = do
req <- getRequest
let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
@@ -91,30 +100,34 @@ getMainR = do
gtfs <- getYesod <&> getGtfs
let trips = tripsOnDay gtfs day
defaultLayout [whamlet|
-<h1>Trips on #{iso8601Show day}
+<h1>Trains on #{iso8601Show day}
<ol>
$forall Trip{..} <- trips
<li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a>
: #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
-|] -- TODO: display stuff
+|]
getTrainViewR :: TripID -> Day -> Handler Html
getTrainViewR trip day = do
GTFS{..} <- getYesod <&> getGtfs
+ (widget, enctype) <- generateFormPost (announceForm day trip)
case M.lookup trip trips of
Nothing -> notFound
Just res@Trip{..} -> do
anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
defaultLayout [whamlet|
-<h1>#{tripTripID} on #{iso8601Show day}
-<h2>Announcements
+<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{iso8601Show day}</a>
+<h2>_{MsgAnnouncements}
<ul>
$forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
- <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a>
+ <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a>
$if null anns
- <li><em>(none)</em>
- <li><a href="">Add Announcement</a>
-<h2>Stops
+ <li><em>(_{MsgNone})</em>
+<h3>_{MsgNewAnnouncement}
+<form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ ^{widget}
+ <button>Submit
+<h2>_{MsgStops}
<ol>
$forall Stop{..} <- tripStops
<div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
@@ -124,130 +137,81 @@ getTrainViewR trip day = do
|]
+getTripsViewR :: Handler Html
+getTripsViewR = do
+ GTFS{..} <- getYesod <&> getGtfs
+ defaultLayout [whamlet|
+<h1>List of Trips
+<ul>
+ $forall Trip{..} <- trips
+ <li><a href="@{TripViewR tripTripID}">#{tripTripID}</a>
+ : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
+|]
+
+
+getTripViewR :: TripID -> Handler Html
+getTripViewR tripId = do
+ GTFS{..} <- getYesod <&> getGtfs
+ case M.lookup tripId trips of
+ Nothing -> notFound
+ Just Trip{..} -> defaultLayout [whamlet|
+<h1>Trip #{tripTripID}
+<h2>Stops
+<ol>
+ $forall Stop{..} <- tripStops
+ <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
+<h2>Dates
+<ul>
+ TODO!
+|]
+
+
+postAnnounceR :: TripID -> Day -> Handler Html
+postAnnounceR trip day = do
+ ((result, widget), enctype) <- runFormPost (announceForm day trip)
+ case result of
+ FormSuccess ann -> do
+ runDB $ insert ann
+ redirect (TrainViewR trip day)
+ _ -> defaultLayout
+ [whamlet|
+ <p>Invalid input, let's try again.
+ <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ ^{widget}
+ <button>Submit
+ |]
+
+getDelAnnounceR :: UUID -> Handler Html
+getDelAnnounceR uuid = do
+ ann <- runDB $ do
+ a <- get (AnnouncementKey uuid)
+ delete (AnnouncementKey uuid)
+ pure a
+ case ann of
+ Nothing -> notFound
+ Just Announcement{..} ->
+ redirect (TrainViewR announcementTrip announcementDay)
instance ToMarkup Time where
toMarkup time =
toMarkup (show time)
--- type ControlRoomAPI =
--- "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
--- :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
--- :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep))
--- :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep)
--- :<|> ControlRoomCranks
-
--- -- | train infra seems to involve turning lots of cranks, so here have some!
--- type ControlRoomCranks =
--- "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
--- :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent
--- :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
--- :<|> "train" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent
--- :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> 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
--- { taHeader :: Text
--- , taMsg :: Text
--- , taLogTime :: Maybe Bool
--- } deriving (Generic, ToHtmlForm, FromForm)
-
--- -- | TODO: can also be "normal"?
--- data TrainDateF = TrainDateF
--- { tdDay :: Day
--- , tdStatus :: AmendmentStatus
--- } deriving (Generic, ToHtmlForm, FromForm)
-
-
--- controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
--- controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip
--- :<|> controlRoomCranks dbpool
--- where handleTrain trip day = case M.lookup trip trips of
--- Just res -> do
--- as <- runSql dbpool
--- $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
--- pure (TrainView day res as True) -- 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)
--- handleTrips = pure trips
--- handleTrip tripId = case M.lookup tripId trips of
--- Just trip -> pure trip
--- Nothing -> throwError err404
-
--- controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
--- controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> 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
--- }
--- redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day))
--- handleAnnounceDel uuid = do
--- ann <- runSql dbpool $ do
--- a <- get (AnnouncementKey uuid)
--- delete (AnnouncementKey uuid)
--- pure a
--- case ann of
--- Nothing -> throwError err404
--- Just Announcement{..} ->
--- redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"")
--- handleDate tripId TrainDateF{..} = do
--- -- TODO: check that tripId exists
--- runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus
--- redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"")
-
-
--- instance ToHtmlFormInput CalendarExceptionType
--- instance ToHtmlForm CalendarDate
-
-
--- instance ToHtml TrainView where
--- toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do
--- unless running $ do
--- div_ [class_ "warning"] "Warning: Trip not running on this day!"
-
--- h2_ "Announcements"
--- ul_ $ do
--- unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do
--- li_ $ do
--- em_ (toHtml announcementHeader); ": "; toHtml announcementMessage
--- " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete"
--- li_ $ do
--- "Add Announcement:"
--- toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
--- (Proxy @TrainAnnounceF)
-
--- h2_ "Stops"
--- ol_ $ forM_ tripStops $ \Stop{..} -> do
--- div_ (toHtml (stationName stopStation))
-
--- h2_ "Vehicle Position"
--- div_ "todo!"
-
--- h2_ "Cancellation Status"
--- a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel"
-
-
--- instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
--- toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
--- ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
--- a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID)
--- when (null trips) $ do
--- em_ "(none)"
--- where shownDay = T.pack (iso8601Show day)
-
--- -- | control room page
--- crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
--- crPage title content = do
--- h1_ (toHtml title)
--- main_ content
+data TrainAnnounceF = TrainAnnounceF
+ { taHeader :: Text
+ , taMsg :: Text
+ , taLogTime :: Bool
+ } deriving (Show)
+
+
+
+announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm day tripId = renderDivs $ Announcement
+ <$> pure tripId
+ <*> areq textField "Header" Nothing
+ <*> areq textField "Text" Nothing
+ <*> pure day
+ <*> aopt urlField "Link" Nothing
+ <*> lift (liftIO getCurrentTime <&> Just)
+
+
+