{-# LANGUAGE  OverloadedStrings
           ,  DeriveGeneric
           ,  LambdaCase
           ,  BlockArguments
           ,  ExtendedDefaultRules
#-}
{-
Module        : HGreet.Packet 
Description   : Packet data types and functions to encode these for usage with HGreet.Client
Copyright     : (c) Hazel (Vawlpe), 2022
License       : GPL-3.0-or-later
Maintainer    : vawlpe@gmail.com
Stability     : experimental
Portability   : Linux

This module provides the data types listed in greetd-ipc(7) and the functions to encode them for usage with HGreet.Client.
-}
module HGreet.Packet ( Request(..), Response(..), AuthMessageType(..), ErrorType(..)
                 , encodeRequest, decodeResponse, encodeLen, decodeLen) where

import Data.Maybe
import Data.Aeson hiding (Success, Error)
import GHC.Generics
import System.Endian
import Sound.OSC.Coding.Byte (encode_u32, encode_u32_le, decode_u32, decode_u32_le)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Sound.OSC as HGreet

-- * Packet data types.
-- ** Request packets (greetd-ipc(7) line 27)
data Request
    = CreateSession            { Request -> String
username :: String }       -- ^ Creates a session and initiates a login atempted for the given user. The session is ready to be started if a success is returned.
    | PostAuthMessageResponse  { Request -> Maybe String
respone  :: Maybe String } -- ^ Answers an authentication message. If the message was informative (info, error), then a response does not need to be set in this message. Tht session is ready to be started if a success is returned.
    | StartSession             { Request -> [String]
cmd      :: [String] }     -- ^ Requests for the session to be started using the provided command line. The session will start after the greeter process terminates.
    | CancelSession                                         -- ^ Cancel the session that is currently under configuration.
    deriving ((forall x. Request -> Rep Request x)
-> (forall x. Rep Request x -> Request) -> Generic Request
forall x. Rep Request x -> Request
forall x. Request -> Rep Request x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Request x -> Request
$cfrom :: forall x. Request -> Rep Request x
Generic, Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> String
$cshow :: Request -> String
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show, Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq)

-- ** Response packets (greetd-ipc(7) line 55)
data Response
    = Success                                                                        -- ^ Indicates that the request succeeded.
    | Error        {Response -> ErrorType
error_type         :: ErrorType,        Response -> String
description   :: String} -- ^ Indicates that the request failed.
    | AuthMessage  {Response -> AuthMessageType
auth_message_type  :: AuthMessageType,  Response -> String
auth_message  :: String} -- ^ Indicates that an authentication message needs to be answered to continue trough the authenticaltion flow. There are no limits on the number and type of messages that may be required for authentication to succeed, and a greeter should not make any assumptions about the messages. Must be answerd with either PostAuthMessageResponse or CancelSession.
    deriving ((forall x. Response -> Rep Response x)
-> (forall x. Rep Response x -> Response) -> Generic Response
forall x. Rep Response x -> Response
forall x. Response -> Rep Response x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Response x -> Response
$cfrom :: forall x. Response -> Rep Response x
Generic, Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq)

-- ** Authentication message packet type enums (greetd-ipc(7) line 76)
data AuthMessageType
    = Visible   -- ^ Indicates that the input from the user should be visible when they answer this question.
    | Secret    -- ^ Indicates that input from the user should be considered secret when they answer this question.
    | Info      -- ^ Indicates that this message is informative, not a question.
    | ErrorType -- ^ Indicates that this message is an error, not a question.
    deriving (Int -> AuthMessageType -> ShowS
[AuthMessageType] -> ShowS
AuthMessageType -> String
(Int -> AuthMessageType -> ShowS)
-> (AuthMessageType -> String)
-> ([AuthMessageType] -> ShowS)
-> Show AuthMessageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthMessageType] -> ShowS
$cshowList :: [AuthMessageType] -> ShowS
show :: AuthMessageType -> String
$cshow :: AuthMessageType -> String
showsPrec :: Int -> AuthMessageType -> ShowS
$cshowsPrec :: Int -> AuthMessageType -> ShowS
Show, AuthMessageType -> AuthMessageType -> Bool
(AuthMessageType -> AuthMessageType -> Bool)
-> (AuthMessageType -> AuthMessageType -> Bool)
-> Eq AuthMessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthMessageType -> AuthMessageType -> Bool
$c/= :: AuthMessageType -> AuthMessageType -> Bool
== :: AuthMessageType -> AuthMessageType -> Bool
$c== :: AuthMessageType -> AuthMessageType -> Bool
Eq)

-- ** Error message packet type enums (greetd-ipc(7) line 96)
data ErrorType
    = AuthError  -- ^ Indicates that authentication failed. THis is not a fatal error, and is likely caused by incorrect credentials. Handle as appropriate.
    | OtherError -- ^ A general error. See the error description for more information.
    deriving (Int -> ErrorType -> ShowS
[ErrorType] -> ShowS
ErrorType -> String
(Int -> ErrorType -> ShowS)
-> (ErrorType -> String)
-> ([ErrorType] -> ShowS)
-> Show ErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorType] -> ShowS
$cshowList :: [ErrorType] -> ShowS
show :: ErrorType -> String
$cshow :: ErrorType -> String
showsPrec :: Int -> ErrorType -> ShowS
$cshowsPrec :: Int -> ErrorType -> ShowS
Show, ErrorType -> ErrorType -> Bool
(ErrorType -> ErrorType -> Bool)
-> (ErrorType -> ErrorType -> Bool) -> Eq ErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorType -> ErrorType -> Bool
$c/= :: ErrorType -> ErrorType -> Bool
== :: ErrorType -> ErrorType -> Bool
$c== :: ErrorType -> ErrorType -> Bool
Eq)


-- * JSON encoding and decoding instances for the above data types.
-- ** toJSON encoding instances for Request packets.
instance ToJSON Request where
    toJSON :: Request -> Value
toJSON (CreateSession String
username)            = [Pair] -> Value
object [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
"create_session",              Key
"username" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
username]
    toJSON (PostAuthMessageResponse Maybe String
response)  = [Pair] -> Value
object [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
"post_auth_message_response",  Key
"response" Key -> Maybe String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe String
response]
    toJSON (StartSession [String]
cmd)                  = [Pair] -> Value
object [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
"start_session", Key
"cmd" Key -> [String] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [String]
cmd]
    toJSON Request
CancelSession                       = [Pair] -> Value
object [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
"cancel_session"]

-- ** parseJSON decoding instances for Response packets.
instance FromJSON Response where
    parseJSON :: Value -> Parser Response
parseJSON = String -> (Object -> Parser Response) -> Value -> Parser Response
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Response" ((Object -> Parser Response) -> Value -> Parser Response)
-> (Object -> Parser Response) -> Value -> Parser Response
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
        Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type" Parser Value -> (Value -> Parser Response) -> Parser Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> (Text -> Parser Response) -> Value -> Parser Response
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"type" \case
            Text
"success"       -> Response -> Parser Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
            Text
"error"         -> ErrorType -> String -> Response
Error        (ErrorType -> String -> Response)
-> Parser ErrorType -> Parser (String -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser ErrorType
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error_type"         Parser (String -> Response) -> Parser String -> Parser Response
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"description"
            Text
"auth_message"  -> AuthMessageType -> String -> Response
AuthMessage  (AuthMessageType -> String -> Response)
-> Parser AuthMessageType -> Parser (String -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser AuthMessageType
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"auth_message_type"  Parser (String -> Response) -> Parser String -> Parser Response
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"auth_message"
            Text
_               -> String -> Parser Response
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid response type"  

-- ** parseJSON decoding instances for AuthMessageType packets.
instance FromJSON AuthMessageType where
    parseJSON :: Value -> Parser AuthMessageType
parseJSON = String
-> (Text -> Parser AuthMessageType)
-> Value
-> Parser AuthMessageType
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"AuthMessageType" \case
        Text
"visible" -> AuthMessageType -> Parser AuthMessageType
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMessageType
Visible
        Text
"secret"  -> AuthMessageType -> Parser AuthMessageType
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMessageType
Secret
        Text
"info"    -> AuthMessageType -> Parser AuthMessageType
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMessageType
Info
        Text
"error"   -> AuthMessageType -> Parser AuthMessageType
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMessageType
ErrorType
        Text
_         -> String -> Parser AuthMessageType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid auth message type"

-- ** parseJSON decoding instances for ErrorType packets.
instance FromJSON ErrorType where
    parseJSON :: Value -> Parser ErrorType
parseJSON = String -> (Text -> Parser ErrorType) -> Value -> Parser ErrorType
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ErrorType" \case
        Text
"auth_error"  -> ErrorType -> Parser ErrorType
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorType
AuthError
        Text
"error"       -> ErrorType -> Parser ErrorType
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorType
OtherError
        Text
_             -> String -> Parser ErrorType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid error type"


-- * Encoding/Decoding functions for packets.
-- | Encode a Request packet as a UTF-8 JSON ByteString to be sent to the greetd socket.
encodeRequest :: Request      -- ^ Raw Request packet to encode.
              -> B.ByteString -- ^ Encoded Request packet.
encodeRequest :: Request -> ByteString
encodeRequest Request
request = ByteString -> ByteString
BL.toStrict ByteString
packet where
    encodedRequest :: ByteString
encodedRequest = Request -> ByteString
forall a. ToJSON a => a -> ByteString
encode Request
request
    encodedLength :: ByteString
encodedLength  = Int -> ByteString
encodeLen  (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
encodedRequest
    packet :: ByteString
packet         = ByteString
encodedLength ByteString -> ByteString -> ByteString
`BL.append` ByteString
encodedRequest

-- | Decode a Response packet from a ByteString received from the greetd socket.
decodeResponse :: B.ByteString -- ^ Encoded Response packet.
               -> Response     -- ^ Decoded raw Response packet.
decodeResponse :: ByteString -> Response
decodeResponse = Maybe Response -> Response
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Response -> Response)
-> (ByteString -> Maybe Response) -> ByteString -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Response
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe Response)
-> (ByteString -> ByteString) -> ByteString -> Maybe Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict

-- | Encode a length as a 32-bit integer in native byte order encapsulated in a Lazy ByteString.
encodeLen :: Int -> BL.ByteString
encodeLen :: Int -> ByteString
encodeLen = case Endianness
getSystemEndianness of
    Endianness
BigEndian     -> Int -> ByteString
encode_u32
    Endianness
LittleEndian  -> Int -> ByteString
encode_u32_le

-- | Decode a length as a 32-bit integer in native byte order from a Lazy ByteString.
decodeLen :: BL.ByteString -> Int
decodeLen :: ByteString -> Int
decodeLen = case Endianness
getSystemEndianness of
    Endianness
BigEndian     -> ByteString -> Int
decode_u32
    Endianness
LittleEndian  -> ByteString -> Int
decode_u32_le