{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Lighthouse.Protocol
    ( -- * Client -> server messages
      ClientRequest(..)
    , ClientMessage (..)
    , encodeRequest
     -- * Server -> client messages
    , ServerEvent (..), InputEvent (..), Input (..)
    , ServerMessage (..)
    , decodeEvent
    ) where

import Control.Monad ((<=<))
import qualified Data.ByteString.Lazy as BL
import Data.Either (fromRight)
import qualified Data.MessagePack as MP
import qualified Data.Text as T
import qualified Data.Vector as V
import Lighthouse.Display
import Lighthouse.Options (Authentication (..))
import Lighthouse.Utils.General (maybeToRight, rightToMaybe)
import Lighthouse.Utils.MessagePack
import Lighthouse.Utils.Serializable

-- Client -> server messages

-- | High-level client -> server message structure.
data ClientRequest = DisplayRequest { ClientRequest -> Display
crDisplay :: Display }
                   | StreamRequest
    deriving (Int -> ClientRequest -> ShowS
[ClientRequest] -> ShowS
ClientRequest -> String
(Int -> ClientRequest -> ShowS)
-> (ClientRequest -> String)
-> ([ClientRequest] -> ShowS)
-> Show ClientRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientRequest -> ShowS
showsPrec :: Int -> ClientRequest -> ShowS
$cshow :: ClientRequest -> String
show :: ClientRequest -> String
$cshowList :: [ClientRequest] -> ShowS
showList :: [ClientRequest] -> ShowS
Show, ClientRequest -> ClientRequest -> Bool
(ClientRequest -> ClientRequest -> Bool)
-> (ClientRequest -> ClientRequest -> Bool) -> Eq ClientRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientRequest -> ClientRequest -> Bool
== :: ClientRequest -> ClientRequest -> Bool
$c/= :: ClientRequest -> ClientRequest -> Bool
/= :: ClientRequest -> ClientRequest -> Bool
Eq)

-- | Low-level client -> server message structure.
data ClientMessage = ClientMessage
    { ClientMessage -> Int
cRequestId :: Int
    , ClientMessage -> Text
cVerb :: T.Text
    , ClientMessage -> [Text]
cPath :: [T.Text]
    , ClientMessage -> Authentication
cAuthentication :: Authentication
    , ClientMessage -> Object
cPayload :: MP.Object
    }
    deriving (Int -> ClientMessage -> ShowS
[ClientMessage] -> ShowS
ClientMessage -> String
(Int -> ClientMessage -> ShowS)
-> (ClientMessage -> String)
-> ([ClientMessage] -> ShowS)
-> Show ClientMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientMessage -> ShowS
showsPrec :: Int -> ClientMessage -> ShowS
$cshow :: ClientMessage -> String
show :: ClientMessage -> String
$cshowList :: [ClientMessage] -> ShowS
showList :: [ClientMessage] -> ShowS
Show, ClientMessage -> ClientMessage -> Bool
(ClientMessage -> ClientMessage -> Bool)
-> (ClientMessage -> ClientMessage -> Bool) -> Eq ClientMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientMessage -> ClientMessage -> Bool
== :: ClientMessage -> ClientMessage -> Bool
$c/= :: ClientMessage -> ClientMessage -> Bool
/= :: ClientMessage -> ClientMessage -> Bool
Eq)

-- | Encodes a ClientRequest to a ClientMessage.
encodeRequest :: Int -> Authentication -> ClientRequest -> ClientMessage
encodeRequest :: Int -> Authentication -> ClientRequest -> ClientMessage
encodeRequest Int
reqId auth :: Authentication
auth@Authentication {Text
authUsername :: Text
authToken :: Text
authUsername :: Authentication -> Text
authToken :: Authentication -> Text
..} (DisplayRequest Display
disp) = ClientMessage
    { cRequestId :: Int
cRequestId = Int
reqId
    , cVerb :: Text
cVerb = Text
"PUT"
    , cPath :: [Text]
cPath = [Text
"user", Text
authUsername, Text
"model"]
    , cAuthentication :: Authentication
cAuthentication = Authentication
auth
    , cPayload :: Object
cPayload = Display -> Object
forall a. MPSerializable a => a -> Object
mpSerialize Display
disp
    }
encodeRequest Int
reqId auth :: Authentication
auth@Authentication {Text
authUsername :: Authentication -> Text
authToken :: Authentication -> Text
authUsername :: Text
authToken :: Text
..} ClientRequest
StreamRequest = ClientMessage
    { cRequestId :: Int
cRequestId = Int
reqId
    , cVerb :: Text
cVerb = Text
"STREAM"
    , cPath :: [Text]
cPath = [Text
"user", Text
authUsername, Text
"model"]
    , cAuthentication :: Authentication
cAuthentication = Authentication
auth
    , cPayload :: Object
cPayload = Object
MP.ObjectNil
    }

instance MPSerializable ClientMessage where
    mpSerialize :: ClientMessage -> Object
mpSerialize ClientMessage {Int
[Text]
Text
Authentication
Object
cRequestId :: ClientMessage -> Int
cVerb :: ClientMessage -> Text
cPath :: ClientMessage -> [Text]
cAuthentication :: ClientMessage -> Authentication
cPayload :: ClientMessage -> Object
cRequestId :: Int
cVerb :: Text
cPath :: [Text]
cAuthentication :: Authentication
cPayload :: Object
..} = [(Text, Object)] -> Object
mpMap
        [ (Text
"REID", Int -> Object
mpInt Int
cRequestId)
        , (Text
"VERB", Text -> Object
mpStr Text
cVerb)
        , (Text
"PATH", [Object] -> Object
mpArray (Text -> Object
mpStr (Text -> Object) -> [Text] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
cPath))
        , (Text
"AUTH", [(Text, Object)] -> Object
mpMap [(Text
"USER", Text -> Object
mpStr Text
authUsername), (Text
"TOKEN", Text -> Object
mpStr Text
authToken)])
        , (Text
"META", [(Text, Object)] -> Object
mpMap [])
        , (Text
"PAYL", Object
cPayload)
        ]
        where Authentication {Text
authUsername :: Authentication -> Text
authToken :: Authentication -> Text
authUsername :: Text
authToken :: Text
..} = Authentication
cAuthentication

instance MPSerializable Display where
    mpSerialize :: Display -> Object
mpSerialize = ByteString -> Object
MP.ObjectBin (ByteString -> Object)
-> (Display -> ByteString) -> Display -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Display -> ByteString) -> Display -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> ByteString
forall t. Serializable t => t -> ByteString
serialize

instance Serializable ClientMessage where
    serialize :: ClientMessage -> ByteString
serialize = Object -> ByteString
forall a. MessagePack a => a -> ByteString
MP.pack (Object -> ByteString)
-> (ClientMessage -> Object) -> ClientMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage -> Object
forall a. MPSerializable a => a -> Object
mpSerialize

-- Server -> client messages

-- | High-level server -> client message structure.
data ServerEvent = ServerErrorEvent { ServerEvent -> Int
seCode :: Int, ServerEvent -> [Text]
seWarnings :: [T.Text], ServerEvent -> Maybe Text
seError :: Maybe T.Text }
                 | ServerInputEvent { ServerEvent -> InputEvent
seEvent :: InputEvent }
                 | ServerUnknownEvent { ServerEvent -> Object
sePayload :: MP.Object }
    deriving (Int -> ServerEvent -> ShowS
[ServerEvent] -> ShowS
ServerEvent -> String
(Int -> ServerEvent -> ShowS)
-> (ServerEvent -> String)
-> ([ServerEvent] -> ShowS)
-> Show ServerEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerEvent -> ShowS
showsPrec :: Int -> ServerEvent -> ShowS
$cshow :: ServerEvent -> String
show :: ServerEvent -> String
$cshowList :: [ServerEvent] -> ShowS
showList :: [ServerEvent] -> ShowS
Show, ServerEvent -> ServerEvent -> Bool
(ServerEvent -> ServerEvent -> Bool)
-> (ServerEvent -> ServerEvent -> Bool) -> Eq ServerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerEvent -> ServerEvent -> Bool
== :: ServerEvent -> ServerEvent -> Bool
$c/= :: ServerEvent -> ServerEvent -> Bool
/= :: ServerEvent -> ServerEvent -> Bool
Eq)

-- | A key event emitted via the web interface.
data InputEvent = InputEvent
    { InputEvent -> Int
keSource :: Int
    , InputEvent -> Input
keInput :: Input
    , InputEvent -> Bool
keIsDown :: Bool
    }
    deriving (Int -> InputEvent -> ShowS
[InputEvent] -> ShowS
InputEvent -> String
(Int -> InputEvent -> ShowS)
-> (InputEvent -> String)
-> ([InputEvent] -> ShowS)
-> Show InputEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InputEvent -> ShowS
showsPrec :: Int -> InputEvent -> ShowS
$cshow :: InputEvent -> String
show :: InputEvent -> String
$cshowList :: [InputEvent] -> ShowS
showList :: [InputEvent] -> ShowS
Show, InputEvent -> InputEvent -> Bool
(InputEvent -> InputEvent -> Bool)
-> (InputEvent -> InputEvent -> Bool) -> Eq InputEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputEvent -> InputEvent -> Bool
== :: InputEvent -> InputEvent -> Bool
$c/= :: InputEvent -> InputEvent -> Bool
/= :: InputEvent -> InputEvent -> Bool
Eq)

-- | An input via the web interface.
data Input = KeyInput { Input -> Int
iKey :: Int }
           | ControllerInput { Input -> Int
iButton :: Int }
    deriving (Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Input -> ShowS
showsPrec :: Int -> Input -> ShowS
$cshow :: Input -> String
show :: Input -> String
$cshowList :: [Input] -> ShowS
showList :: [Input] -> ShowS
Show, Input -> Input -> Bool
(Input -> Input -> Bool) -> (Input -> Input -> Bool) -> Eq Input
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
/= :: Input -> Input -> Bool
Eq)

-- | Low-level server -> client message structure.
data ServerMessage = ServerMessage
    { ServerMessage -> Int
sRNum :: Int
    , ServerMessage -> Maybe Int
sReqId :: Maybe Int
    , ServerMessage -> [Text]
sWarnings :: [T.Text]
    , ServerMessage -> Maybe Text
sResponse :: Maybe T.Text
    , ServerMessage -> Maybe Object
sPayload :: Maybe MP.Object
    }
    deriving (Int -> ServerMessage -> ShowS
[ServerMessage] -> ShowS
ServerMessage -> String
(Int -> ServerMessage -> ShowS)
-> (ServerMessage -> String)
-> ([ServerMessage] -> ShowS)
-> Show ServerMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerMessage -> ShowS
showsPrec :: Int -> ServerMessage -> ShowS
$cshow :: ServerMessage -> String
show :: ServerMessage -> String
$cshowList :: [ServerMessage] -> ShowS
showList :: [ServerMessage] -> ShowS
Show, ServerMessage -> ServerMessage -> Bool
(ServerMessage -> ServerMessage -> Bool)
-> (ServerMessage -> ServerMessage -> Bool) -> Eq ServerMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerMessage -> ServerMessage -> Bool
== :: ServerMessage -> ServerMessage -> Bool
$c/= :: ServerMessage -> ServerMessage -> Bool
/= :: ServerMessage -> ServerMessage -> Bool
Eq)

-- | Decodes a ServerMessage to a ServerEvent.
decodeEvent :: ServerMessage -> Either T.Text ServerEvent
decodeEvent :: ServerMessage -> Either Text ServerEvent
decodeEvent ServerMessage {Int
[Text]
Maybe Int
Maybe Text
Maybe Object
sRNum :: ServerMessage -> Int
sReqId :: ServerMessage -> Maybe Int
sWarnings :: ServerMessage -> [Text]
sResponse :: ServerMessage -> Maybe Text
sPayload :: ServerMessage -> Maybe Object
sRNum :: Int
sReqId :: Maybe Int
sWarnings :: [Text]
sResponse :: Maybe Text
sPayload :: Maybe Object
..} = case Int
sRNum of
    Int
200 -> do
        Object
payload <- Text -> Maybe Object -> Either Text Object
forall b a. b -> Maybe a -> Either b a
maybeToRight Text
"Could not decode as input, no payload" Maybe Object
sPayload
        ServerEvent -> Either Text ServerEvent
forall a b. b -> Either a b
Right (ServerEvent -> Either Text ServerEvent)
-> ServerEvent -> Either Text ServerEvent
forall a b. (a -> b) -> a -> b
$ ServerEvent -> Either Text ServerEvent -> ServerEvent
forall b a. b -> Either a b -> b
fromRight (Object -> ServerEvent
ServerUnknownEvent Object
payload) (Either Text ServerEvent -> ServerEvent)
-> Either Text ServerEvent -> ServerEvent
forall a b. (a -> b) -> a -> b
$ InputEvent -> ServerEvent
ServerInputEvent (InputEvent -> ServerEvent)
-> Either Text InputEvent -> Either Text ServerEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text InputEvent
forall a. MPDeserializable a => Object -> Either Text a
mpDeserialize Object
payload
    Int
_   -> ServerEvent -> Either Text ServerEvent
forall a b. b -> Either a b
Right (ServerEvent -> Either Text ServerEvent)
-> ServerEvent -> Either Text ServerEvent
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> Maybe Text -> ServerEvent
ServerErrorEvent Int
sRNum [Text]
sWarnings Maybe Text
sResponse

instance MPDeserializable ServerMessage where
    mpDeserialize :: Object -> Either Text ServerMessage
mpDeserialize (MP.ObjectMap Vector (Object, Object)
vm) = do
        let m :: [(Object, Object)]
m = Vector (Object, Object) -> [(Object, Object)]
forall a. Vector a -> [a]
V.toList Vector (Object, Object)
vm
        Int
rnum <- Object -> Either Text Int
mpUnInt (Object -> Either Text Int)
-> Either Text Object -> Either Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"RNUM" [(Object, Object)]
m
        ServerMessage -> Either Text ServerMessage
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerMessage
            { sRNum :: Int
sRNum = Int
rnum
            , sReqId :: Maybe Int
sReqId = Either Text Int -> Maybe Int
forall a b. Either a b -> Maybe b
rightToMaybe (Object -> Either Text Int
mpUnInt (Object -> Either Text Int)
-> Either Text Object -> Either Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"REOD" [(Object, Object)]
m)
            , sResponse :: Maybe Text
sResponse = Either Text Text -> Maybe Text
forall a b. Either a b -> Maybe b
rightToMaybe (Object -> Either Text Text
mpUnStr (Object -> Either Text Text)
-> Either Text Object -> Either Text Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"RESPONSE" [(Object, Object)]
m)
            , sWarnings :: [Text]
sWarnings = [Text] -> Either Text [Text] -> [Text]
forall b a. b -> Either a b -> b
fromRight [] ((Object -> Either Text Text) -> [Object] -> Either Text [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Object -> Either Text Text
mpUnStr (Either Text [Object] -> [Object]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Object -> Either Text [Object]
mpUnArray (Object -> Either Text [Object])
-> Either Text Object -> Either Text [Object]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"WARNINGS" [(Object, Object)]
m)))
            , sPayload :: Maybe Object
sPayload = Either Text Object -> Maybe Object
forall a b. Either a b -> Maybe b
rightToMaybe (Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"PAYL" [(Object, Object)]
m)
            }
    mpDeserialize Object
o = Text -> Either Text ServerMessage
forall a b. a -> Either a b
Left (Text -> Either Text ServerMessage)
-> Text -> Either Text ServerMessage
forall a b. (a -> b) -> a -> b
$ Text
"Could not deserialize as server message (not a map): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Object -> String
forall a. Show a => a -> String
show Object
o)

instance MPDeserializable InputEvent where
    mpDeserialize :: Object -> Either Text InputEvent
mpDeserialize (MP.ObjectMap Vector (Object, Object)
vo) = do
        let o :: [(Object, Object)]
o = Vector (Object, Object) -> [(Object, Object)]
forall a. Vector a -> [a]
V.toList Vector (Object, Object)
vo
        Int
src <- Object -> Either Text Int
mpUnInt (Object -> Either Text Int)
-> Either Text Object -> Either Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"src" [(Object, Object)]
o
        let key :: Either Text Int
key = Object -> Either Text Int
mpUnInt (Object -> Either Text Int)
-> Either Text Object -> Either Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"key" [(Object, Object)]
o
            btn :: Either Text Int
btn = Object -> Either Text Int
mpUnInt (Object -> Either Text Int)
-> Either Text Object -> Either Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"btn" [(Object, Object)]
o
        Input
input <- (Int -> Input
KeyInput (Int -> Input) -> Either Text Int -> Either Text Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Int
key) Either Text Input -> Either Text Input -> Either Text Input
forall a. Semigroup a => a -> a -> a
<> (Int -> Input
ControllerInput (Int -> Input) -> Either Text Int -> Either Text Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Int
btn)
        Bool
dwn <- Object -> Either Text Bool
mpUnBool (Object -> Either Text Bool)
-> Either Text Object -> Either Text Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
"dwn" [(Object, Object)]
o
        InputEvent -> Either Text InputEvent
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return InputEvent
            { keSource :: Int
keSource = Int
src
            , keInput :: Input
keInput = Input
input
            , keIsDown :: Bool
keIsDown = Bool
dwn
            }
    mpDeserialize Object
o = Text -> Either Text InputEvent
forall a b. a -> Either a b
Left (Text -> Either Text InputEvent) -> Text -> Either Text InputEvent
forall a b. (a -> b) -> a -> b
$ Text
"Could not deserialize as input event (not a map): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Object -> String
forall a. Show a => a -> String
show Object
o)

instance Deserializable ServerMessage where
    deserialize :: ByteString -> Either Text ServerMessage
deserialize = Object -> Either Text ServerMessage
forall a. MPDeserializable a => Object -> Either Text a
mpDeserialize (Object -> Either Text ServerMessage)
-> (ByteString -> Either Text Object)
-> ByteString
-> Either Text ServerMessage
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Text -> Maybe Object -> Either Text Object
forall b a. b -> Maybe a -> Either b a
maybeToRight Text
errMsg (Maybe Object -> Either Text Object)
-> (ByteString -> Maybe Object) -> ByteString -> Either Text Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Object
forall a. MessagePack a => ByteString -> Maybe a
MP.unpack)
        where errMsg :: Text
errMsg = Text
"Could not deserialize server message as MessagePack object"