1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
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, 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, 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 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 (..), formAction)
import Persist (Announcement (..), Key (..),
runSql)
import Server.Util (Service)
import Text.ProtocolBuffers (Default (defaultValue))
import Web.FormUrlEncoded (FromForm)
import GTFS
type ControlRoomAPI =
"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
-- | 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 (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
|
