aboutsummaryrefslogtreecommitdiff
path: root/lib/API.hs
blob: 5ea1c064e3112f91ed7b90dee80fbef47aca2901 (plain)
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
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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(..), Metrics(..)) 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 (..), Server, err401,
                                              err404, type (:>))
import           Servant.API                 (Capture, Get, JSON, MimeRender,
                                              NoContent, OctetStream, 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           Control.Lens                (At (at), (&), (?~))
import           Data.Aeson                  (FromJSON (..), Value,
                                              genericParseJSON)
import           Data.ByteString             (ByteString)
import           Data.HashMap.Strict.InsOrd  (singleton)
import           GHC.Generics                (Generic)
import           GTFS
import           GTFS.Realtime.FeedEntity
import           GTFS.Realtime.FeedMessage   (FeedMessage)
import           Prometheus

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 "register")
instance ToSchema Value where
  declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
      & type_ ?~ SwaggerObject

-- | 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))
  :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
  :<|> "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] (Maybe TrainAnchor)
  :<|> "train" :> "ping" :> "ws" :> WebSocket
  :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> Capture "Day" Day :> 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.zip" :> Get '[OctetStream] GTFSFile
  :<|> "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
  :<|> "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



-- 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" ]
        }
      }
    }