From ddbbd02dc816c076faaa9141b3aa4853da83749f Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 14 Aug 2022 19:30:44 +0200 Subject: control room: translations & form input still basic, but works pretty well overall --- lib/Server/ControlRoom.hs | 348 +++++++++++++++++++++------------------------- lib/Server/Util.hs | 5 +- 2 files changed, 157 insertions(+), 196 deletions(-) (limited to 'lib/Server') 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| -

Trips on #{iso8601Show day} +

Trains on #{iso8601Show day}
    $forall Trip{..} <- trips
  1. #{tripTripID} : #{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| -

    #{tripTripID} on #{iso8601Show day} -

    Announcements +

    #{tripTripID} _{Msgon} #{iso8601Show day} +

    _{MsgAnnouncements}
      $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns -
    • #{announcementHeader}: #{announcementMessage} delete +
    • #{announcementHeader}: #{announcementMessage} delete $if null anns -
    • (none) -
    • Add Announcement -

      Stops +
    • (_{MsgNone}) +

      _{MsgNewAnnouncement} +
      + ^{widget} +