{-# 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)