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
131
132
133
134
135
136
137
138
139
140
141
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE UndecidableInstances #-}
-- | 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(..), Metrics(..), SentPing(..)) where
import Data.Map (Map)
import Data.Proxy (Proxy (..))
import Data.Swagger (MimeList (MimeList),
NamedSchema (..), Operation (..),
PathItem (_pathItemGet),
Scheme (Wss), Swagger,
SwaggerType (SwaggerObject),
ToSchema (..), _swaggerPaths,
genericDeclareNamedSchema, type_)
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
import Data.UUID (UUID)
import Servant (Application, FormUrlEncoded,
FromHttpApiData (parseUrlPiece),
MimeRender (..),
MimeUnrender (..), Server, err401,
err404, type (:>))
import Servant.API (Accept, Capture, Get, JSON,
MimeRender, MimeUnrender,
NoContent, OctetStream, PlainText,
Post, QueryParam, Raw, ReqBody,
type (:<|>) (..))
import Servant.API.WebSocket (WebSocket)
import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
import Control.Lens (At (at), (&), (?~))
import Data.Aeson (FromJSON (..), Value,
genericParseJSON)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.HashMap.Strict.InsOrd (singleton)
import Data.ProtoLens (Message (messageName),
encodeMessage)
import GHC.Generics (Generic)
import GTFS (Depth (Deep), GTFSFile (..),
StationID, Trip, TripId,
aesonOptions, swaggerOptions)
import Network.HTTP.Media ((//))
import Persist
import Prometheus
import Proto.GtfsRealtime (FeedMessage)
import Servant.API.ContentTypes (Accept (..))
-- | a bare ping as sent by a tracker device
data SentPing = SentPing
{ sentPingToken :: TrackerId
, sentPingGeopos :: Geopos
, sentPingTimestamp :: UTCTime
} deriving (Generic)
instance FromJSON SentPing where
parseJSON = genericParseJSON (aesonOptions "sentPing")
-- | tracktrain's API
type API =
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
"tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
:<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor)
:<|> "tracker" :> "ping" :> "ws" :> WebSocket
:<|> "ticker" :> "current" :> Get '[JSON] Value
:<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
:<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
:<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile
:<|> "gtfs" :> GtfsRealtimeAPI
type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
:<|> "tripupdates" :> Get '[Proto] FeedMessage
:<|> "vehiclepositions" :> Get '[Proto] FeedMessage
type CompleteAPI =
"api" :> "openapi" :> Get '[JSON] Swagger
:<|> "api" :> API
:<|> "metrics" :> Get '[PlainText] Text
:<|> "assets" :> Raw
:<|> Raw -- hook for yesod frontend
data Metrics = Metrics
{ metricsWSGauge :: Gauge }
instance MimeRender OctetStream GTFSFile where
mimeRender p (GTFSFile bytes) = mimeRender p bytes
newtype RegisterJson = RegisterJson
{ registerAgent :: Text }
deriving (Show, Generic)
instance FromJSON RegisterJson where
parseJSON = genericParseJSON (aesonOptions "register")
instance ToSchema RegisterJson where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
instance ToSchema Value where
declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
& type_ ?~ SwaggerObject
instance ToSchema SentPing where
declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing")
-- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
instance HasSwagger WebSocket where
toSwagger _ = mempty
{ _swaggerPaths = singleton "/" $ mempty
{ _pathItemGet = Just $ mempty
{ _operationSummary = Just "this is a websocket endpoint!"
, _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many trainPings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)."
, _operationSchemes = Just [ Wss ]
, _operationConsumes = Just $ MimeList [ "application/json" ]
, _operationProduces = Just $ MimeList [ "application/json" ]
}
}
}
-- | A servant encoding for protobuf-encoded messages
data Proto
instance Accept Proto where
contentType _ = "application" // "octet-stream"
instance Message msg => MimeRender Proto msg where
mimeRender _ = LB.fromStrict . encodeMessage
-- | Not an ideal instance, hides fields of the protobuf message
instance {-# OVERLAPPABLE #-} Message msg => ToSchema msg where
declareNamedSchema proxy =
pure (NamedSchema (Just (messageName proxy)) mempty)
|
