aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/ControlRoom.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server/Frontend/Tickets.hs (renamed from lib/Server/ControlRoom.hs)381
1 files changed, 81 insertions, 300 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/Frontend/Tickets.hs
index 5292620..43f24aa 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -1,192 +1,55 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Server.ControlRoom (ControlRoom(..)) where
-
-import Config (ServerConfig (..), UffdConfig (..))
-import Control.Monad (forM, forM_, join)
-import Control.Monad.Extra (maybeM)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as LB
-import Data.Coerce (coerce)
-import Data.Function (on, (&))
-import Data.Functor ((<&>))
-import Data.List (lookup, nubBy)
-import Data.List.NonEmpty (nonEmpty)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromJust, isJust)
-import Data.Pool (Pool)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time (UTCTime (..), addDays,
- 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 Extrapolation (Extrapolator (..),
- LinearExtrapolator (..))
-import Fmt ((+|), (|+))
-import GHC.Float (int2Double)
-import GHC.Generics (Generic)
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tickets
+ ( getTicketsR
+ , postGtfsTicketImportR
+ , getTicketViewR
+ , getTicketMapViewR
+ , getDelAnnounceR
+ , postAnnounceR
+ , getTokenBlock
+ ) where
+
+import Server.Frontend.Routes
+
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, forM_, join)
+import Control.Monad.Extra (maybeM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.List (lookup, nubBy)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), addDays,
+ 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 Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
+import Fmt ((+|), (|+))
+import GHC.Float (int2Double)
import qualified GTFS
-import Numeric (showFFloat)
+import Numeric (showFFloat)
import Persist
-import Server.Util (Service, secondsNow)
-import Text.Blaze.Html (ToMarkup (..))
-import Text.Blaze.Internal (MarkupM (Empty))
-import Text.Read (readMaybe)
-import Text.Shakespeare.Text
+import Server.Util (Service, secondsNow)
+import Text.Read (readMaybe)
import Yesod
import Yesod.Auth
-import Yesod.Auth.OAuth2.Prelude
-import Yesod.Auth.OpenId (IdentifierType (..), authOpenId)
-import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
-import Yesod.Form
-import Yesod.Orphans ()
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
-data ControlRoom = ControlRoom
- { getGtfs :: GTFS.GTFS
- , getPool :: Pool SqlBackend
- , getSettings :: ServerConfig
- }
-
-mkMessage "ControlRoom" "messages" "en"
-
-mkYesod "ControlRoom" [parseRoutes|
-/ RootR GET
-/auth AuthR Auth getAuth
-
-/tickets TicketsR GET
-/ticket/#UUID TicketViewR GET
-/ticket/map/#UUID TicketMapViewR GET
-/ticket/announce/#UUID AnnounceR POST
-/ticket/del-announce/#UUID DelAnnounceR GET
-
-/token/block/#Token TokenBlock GET
-
-/gtfs/trips GtfsTripsViewR GET
-/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
-/gtfs/import/#Day GtfsTicketImportR POST
-
-/obu OnboardUnitMenuR GET
-/obu/#UUID OnboardUnitR GET
-/tracker OnboardTrackerR GET
-|]
-
-emptyMarkup :: MarkupM a -> Bool
-emptyMarkup (Empty _) = True
-emptyMarkup _ = False
-
-instance Yesod ControlRoom where
- authRoute _ = Just $ AuthR LoginR
- isAuthorized OnboardUnitMenuR _ = pure Authorized
- isAuthorized (OnboardUnitR _) _ = pure Authorized
- isAuthorized OnboardTrackerR _ = pure Authorized
- isAuthorized (AuthR _) _ = pure Authorized
- isAuthorized _ _ = do
- UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
- if uffdConfigEnable then maybeAuthId >>= \case
- Just _ -> pure Authorized
- Nothing -> pure AuthenticationRequired
- else pure Authorized
-
-
- defaultLayout w = do
- PageContent{..} <- widgetToPageContent w
- msgs <- getMessages
-
- withUrlRenderer [hamlet|
- $newline never
- $doctype 5
- <html>
- <head>
- <title>
- $if emptyMarkup pageTitle
- Tracktrain
- $else
- #{pageTitle}
- $maybe description <- pageDescription
- <meta name="description" content="#{description}">
- ^{pageHead}
- <link rel="stylesheet" href="/assets/style.css">
- <meta name="viewport" content="width=device-width, initial-scale=1">
- <body>
- $forall (status, msg) <- msgs
- <!-- <p class="message #{status}">#{msg} -->
- ^{pageBody}
- |]
-
-
-instance RenderMessage ControlRoom FormMessage where
- renderMessage _ _ = defaultFormMessage
-
-instance YesodPersist ControlRoom where
- type YesodPersistBackend ControlRoom = SqlBackend
- runDB action = do
- pool <- getYesod <&> getPool
- runSqlPool action pool
-
-
--- this instance is only slightly cursed (it keeps login information
--- as json in a session cookie and hopes nothing will ever go wrong)
-instance YesodAuth ControlRoom where
- type AuthId ControlRoom = UffdUser
-
- authPlugins cr = case config of
- UffdConfig {..} -> if uffdConfigEnable
- then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
- else []
- where config = serverConfigLogin (getSettings cr)
-
- maybeAuthId = do
- e <- lookupSession "json"
- pure $ case e of
- Nothing -> Nothing
- Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
-
- authenticate creds = do
- forM_ (credsExtra creds) (uncurry setSession)
- -- extra <- lookupSession "extra"
- -- pure (Authenticated ( undefined))
- e <- lookupSession "json"
- case e of
- Nothing -> error "no session information"
- Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
- Nothing -> error "malformed session information"
- Just user -> pure $ Authenticated user
-
- loginDest _ = RootR
- logoutDest _ = RootR
- -- hardcode redirecting to uffd directly; showing the normal login
- -- screen is kinda pointless when there's only one option
- loginHandler = do
- redirect ("/auth/page/uffd/forward" :: Text)
- onLogout = do
- clearSession
-
-
-
-
-getRootR :: Handler Html
-getRootR = redirect TicketsR
-
getTicketsR :: Handler Html
getTicketsR = do
req <- getRequest
@@ -439,46 +302,47 @@ getTicketMapViewR ticketId = do
}
|]
+tripImportForm
+ :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+ -> Html
+ -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
+tripImportForm trips extra = do
+ forms <- forM trips $ \(trip, day) -> do
+ (aRes, aView) <- mreq checkBoxField "import" Nothing
+ let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+ pure (trip, day, dings, aView)
+ let widget = toWidget [whamlet|
+ #{extra}
+ <ol>
+ $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
+ <li>
+ ^{fvInput view}
+ <label for="^{fvId view}">
+ _{MsgTrip} #{GTFS.tripName trip}
+ : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
+ |]
-getGtfsTripsViewR :: Handler Html
-getGtfsTripsViewR = do
- GTFS.GTFS{..} <- getYesod <&> getGtfs
- defaultLayout $ do
- setTitle "List of Trips"
- [whamlet|
-<h1>List of Trips
-<section><ul>
- $forall trip@GTFS.Trip{..} <- trips
- <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
- : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
-|]
+ let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
+ sequenceA (fmap (\(_,_,res,_) -> res) forms)
+ pure (fmap catMaybes a, widget)
-getGtfsTripViewR :: GTFS.TripId -> Handler Html
-getGtfsTripViewR tripId = do
- GTFS.GTFS{..} <- getYesod <&> getGtfs
- case M.lookup tripId trips of
- Nothing -> notFound
- Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{GTFS.tripName trip}
-<section>
- <h2>_{MsgInfo}
- <p><strong>_{MsgtripId}:</strong> #{tripTripId}
- <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
- <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
-<section>
- <h2>_{MsgStops}
- <ol>
- $forall GTFS.Stop{..} <- tripStops
- <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
-<section>
- <h2>Dates
- <ul>
- TODO!
-|]
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
+ case tripHeadsign of
+ Just headsign -> headsign
+ Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+ <$> pure (TicketKey ticketId)
+ <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
+ <*> areq textField (fieldSettingsLabel MsgText) Nothing
+ <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
+ <*> lift (liftIO getCurrentTime <&> Just)
+
postAnnounceR :: UUID -> Handler Html
postAnnounceR ticketId = do
((result, widget), enctype) <- runFormPost (announceForm ticketId)
@@ -520,86 +384,3 @@ getTokenBlock token = do
Just ticket -> TicketViewR (coerce ticket)
Nothing -> RootR
Nothing -> notFound
-
-getOnboardUnitMenuR :: Handler Html
-getOnboardUnitMenuR = do
- day <- liftIO getCurrentTime <&> utctDay
-
- tickets <-
- runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
- firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
- pure (ticket, entityVal $ fromJust firstStop))
-
- defaultLayout $ do
- [whamlet|
- <h1>_{MsgOBU}
- <section>
- _{MsgChooseTrain}
- $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
- <hr>
- <a href="@{OnboardUnitR ticketId}">
- #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
- <section>
- <a href="@{OnboardTrackerR}">_{MsgStartTracking}
- |]
-
-getOnboardUnitR :: UUID -> Handler Html
-getOnboardUnitR ticketId = do
- Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
- Nothing -> notFound
- Just ticket -> pure ticket
- defaultLayout $(whamletFile "site/obu.hamlet")
-
-getOnboardTrackerR :: Handler Html
-getOnboardTrackerR = do
- defaultLayout
- $( whamletFile "site/tracker.hamlet")
-
-
-announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm ticketId = renderDivs $ Announcement
- <$> pure (TicketKey ticketId)
- <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
- <*> areq textField (fieldSettingsLabel MsgText) Nothing
- <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
- <*> lift (liftIO getCurrentTime <&> Just)
-
-
-
-tripImportForm
- :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
- -> Html
- -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
-tripImportForm trips extra = do
- forms <- forM trips $ \(trip, day) -> do
- (aRes, aView) <- mreq checkBoxField "import" Nothing
- let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
- pure (trip, day, dings, aView)
-
- let widget = toWidget [whamlet|
- #{extra}
- <ol>
- $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
- <li>
- ^{fvInput view}
- <label for="^{fvId view}">
- _{MsgTrip} #{GTFS.tripName trip}
- : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
- |]
-
- let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
- sequenceA (fmap (\(_,_,res,_) -> res) forms)
-
- pure (fmap catMaybes a, widget)
-
-
-mightbe :: Maybe Text -> Text
-mightbe (Just a) = a
-mightbe Nothing = ""
-
-
-gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
-gtfsHeadsign GTFS.Trip{..} =
- case tripHeadsign of
- Just headsign -> headsign
- Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops))