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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | The sole authorative definition of this server's API, given as a Servant-style
-- Haskell type. All other descriptions of the API are generated from this one.
module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where
import Data.Map (Map)
import Data.Proxy (Proxy (..))
import Data.Swagger (Swagger, ToSchema (..),
genericDeclareNamedSchema)
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
import Data.UUID (UUID)
import Servant (Application, FormUrlEncoded,
FromHttpApiData (parseUrlPiece),
Server, err401, err404, type (:>))
import Servant.API (Capture, Get, JSON, NoContent,
PlainText, Post, QueryParam, Raw,
ReqBody, type (:<|>) ((:<|>)))
import Servant.API.WebSocket (WebSocket)
import Servant.GTFS.Realtime (Proto)
import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
import Data.Aeson (FromJSON (..), genericParseJSON)
import GHC.Generics (Generic)
import GTFS
import GTFS.Realtime.FeedEntity
import GTFS.Realtime.FeedMessage (FeedMessage)
import Persist
newtype RegisterJson = RegisterJson
{ registerAgent :: Text }
deriving (Show, Generic)
instance FromJSON RegisterJson where
parseJSON = genericParseJSON (aesonOptions "register")
instance ToSchema RegisterJson where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
-- | The server's API (as it is actually intended).
type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
:<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
:<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
-- TODO: perhaps a websocket instead?
:<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] NoContent
:<|> "train" :> "ping" :> "ws" :> WebSocket
-- debug things
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
:<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
:<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
:<|> "gtfs" :> GtfsRealtimeAPI
-- | The API used for publishing gtfs realtime updates
type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
:<|> "tripupdates" :> Get '[Proto] FeedMessage
:<|> "vehiclepositions" :> Get '[Proto] FeedMessage
-- | The server's API with an additional debug route for accessing the specification
-- itself. Split from API to prevent the API documenting the format in which it is
-- documented, which would be silly and way to verbose.
type CompleteAPI =
"api" :> "openapi" :> Get '[JSON] Swagger
:<|> "api" :> API
:<|> Raw -- hook for yesod frontend
-- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
instance HasSwagger WebSocket where
toSwagger _ = toSwagger (Proxy @(Post '[JSON] NoContent))
|
