{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-}
module Lighthouse.Utils.MessagePack
    ( -- * Convenience functions for construction
      mpStr, mpInt, mpBool, mpMap, mpArray, mpBin, mpNil
      -- * Convenience functions for deconstruction
    , mpUnStr, mpUnInt, mpUnBool, mpUnArray, mpUnMap, mpLookup
      -- * Conversions to and from MessagePack
    , MPSerializable (..), MPDeserializable (..)
    ) where

import qualified Data.ByteString.Lazy as BL
import qualified Data.MessagePack as MP
import qualified Data.Text as T
import qualified Data.Vector as V
import Lighthouse.Utils.General ((<.$>), maybeToRight)

-- | Creates a MessagePack string.
mpStr :: T.Text -> MP.Object
mpStr :: Text -> Object
mpStr = Text -> Object
MP.ObjectStr

-- | Creates a MessagePack integer.
mpInt :: Int -> MP.Object
mpInt :: Int -> Object
mpInt = Int -> Object
MP.ObjectInt

-- | Creates a MessagePack boolean.
mpBool :: Bool -> MP.Object
mpBool :: Bool -> Object
mpBool = Bool -> Object
MP.ObjectBool

-- | Creates a MessagePack map.
mpMap :: [(T.Text, MP.Object)] -> MP.Object
mpMap :: [(Text, Object)] -> Object
mpMap = Vector (Object, Object) -> Object
MP.ObjectMap (Vector (Object, Object) -> Object)
-> ([(Text, Object)] -> Vector (Object, Object))
-> [(Text, Object)]
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Object, Object)] -> Vector (Object, Object)
forall a. [a] -> Vector a
V.fromList ([(Object, Object)] -> Vector (Object, Object))
-> ([(Text, Object)] -> [(Object, Object)])
-> [(Text, Object)]
-> Vector (Object, Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> Object
MP.ObjectStr (Text -> Object) -> (Text, Object) -> (Object, Object)
forall a b c. (a -> b) -> (a, c) -> (b, c)
<.$>) ((Text, Object) -> (Object, Object))
-> [(Text, Object)] -> [(Object, Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

-- | Creates a MessagePack array.
mpArray :: [MP.Object] -> MP.Object
mpArray :: [Object] -> Object
mpArray = Vector Object -> Object
MP.ObjectArray (Vector Object -> Object)
-> ([Object] -> Vector Object) -> [Object] -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Object] -> Vector Object
forall a. [a] -> Vector a
V.fromList

-- | Creates a MessagePack binary.
mpBin :: BL.ByteString -> MP.Object
mpBin :: ByteString -> Object
mpBin = ByteString -> Object
MP.ObjectBin (ByteString -> Object)
-> (ByteString -> ByteString) -> ByteString -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict

-- | Creates a MessagePack nil.
mpNil :: MP.Object
mpNil :: Object
mpNil = Object
MP.ObjectNil

-- | Deconstructs a MessagePack string.
mpUnStr :: MP.Object -> Either T.Text T.Text
mpUnStr :: Object -> Either Text Text
mpUnStr (MP.ObjectStr Text
t) = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
t
mpUnStr Object
o = Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Could not deconstruct " 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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as string"

-- | Deconstructs a MessagePack integer.
mpUnInt :: MP.Object -> Either T.Text Int
mpUnInt :: Object -> Either Text Int
mpUnInt (MP.ObjectInt Int
n) = Int -> Either Text Int
forall a b. b -> Either a b
Right Int
n
mpUnInt Object
o = Text -> Either Text Int
forall a b. a -> Either a b
Left (Text -> Either Text Int) -> Text -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text
"Could not deconstruct " 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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as int"

-- | Deconstructs a MessagePack boolean.
mpUnBool :: MP.Object -> Either T.Text Bool
mpUnBool :: Object -> Either Text Bool
mpUnBool (MP.ObjectBool Bool
b) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
b
mpUnBool Object
o = Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ Text
"Could not deconstruct " 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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as bool"

-- | Deconstructs a MessagePack array.
mpUnArray :: MP.Object -> Either T.Text [MP.Object]
mpUnArray :: Object -> Either Text [Object]
mpUnArray (MP.ObjectArray Vector Object
v) = [Object] -> Either Text [Object]
forall a b. b -> Either a b
Right ([Object] -> Either Text [Object])
-> [Object] -> Either Text [Object]
forall a b. (a -> b) -> a -> b
$ Vector Object -> [Object]
forall a. Vector a -> [a]
V.toList Vector Object
v
mpUnArray Object
o = Text -> Either Text [Object]
forall a b. a -> Either a b
Left (Text -> Either Text [Object]) -> Text -> Either Text [Object]
forall a b. (a -> b) -> a -> b
$ Text
"Could not deconstruct " 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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as array"

-- | Deconstructs a MessagePack map.
mpUnMap :: MP.Object -> Either T.Text [(MP.Object, MP.Object)]
mpUnMap :: Object -> Either Text [(Object, Object)]
mpUnMap (MP.ObjectMap Vector (Object, Object)
v) = [(Object, Object)] -> Either Text [(Object, Object)]
forall a b. b -> Either a b
Right ([(Object, Object)] -> Either Text [(Object, Object)])
-> [(Object, Object)] -> Either Text [(Object, Object)]
forall a b. (a -> b) -> a -> b
$ Vector (Object, Object) -> [(Object, Object)]
forall a. Vector a -> [a]
V.toList Vector (Object, Object)
v
mpUnMap Object
o = Text -> Either Text [(Object, Object)]
forall a b. a -> Either a b
Left (Text -> Either Text [(Object, Object)])
-> Text -> Either Text [(Object, Object)]
forall a b. (a -> b) -> a -> b
$ Text
"Could not deconstruct " 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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as map"

-- | Looks up a key in a deconstructed MessagePack map.
mpLookup :: T.Text -> [(MP.Object, MP.Object)] -> Either T.Text MP.Object
mpLookup :: Text -> [(Object, Object)] -> Either Text Object
mpLookup Text
key [(Object, Object)]
m = Text -> Maybe Object -> Either Text Object
forall b a. b -> Maybe a -> Either b a
maybeToRight Text
errMsg (Maybe Object -> Either Text Object)
-> Maybe Object -> Either Text Object
forall a b. (a -> b) -> a -> b
$ Object -> [(Object, Object)] -> Maybe Object
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> Object
mpStr Text
key) [(Object, Object)]
m
    where errMsg :: Text
errMsg = Text
"Could not find key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([(Object, Object)] -> String
forall a. Show a => a -> String
show [(Object, Object)]
m)

class MPSerializable a where
    -- | Converts to a MessagePack representation.
    mpSerialize :: a -> MP.Object

instance MPSerializable MP.Object where
    mpSerialize :: Object -> Object
mpSerialize = Object -> Object
forall a. a -> a
id

class MPDeserializable a where
    -- | Converts from a MessagePack representation.
    mpDeserialize :: MP.Object -> Either T.Text a

instance MPDeserializable () where
    mpDeserialize :: Object -> Either Text ()
mpDeserialize Object
_ = () -> Either Text ()
forall a b. b -> Either a b
Right () -- we don't care about the result

instance MPDeserializable MP.Object where
    mpDeserialize :: Object -> Either Text Object
mpDeserialize = Object -> Either Text Object
forall a b. b -> Either a b
Right

instance MPDeserializable a => MPDeserializable [a] where
    mpDeserialize :: Object -> Either Text [a]
mpDeserialize (MP.ObjectArray Vector Object
a) = (Object -> Either Text a) -> [Object] -> Either Text [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Object -> Either Text a
forall a. MPDeserializable a => Object -> Either Text a
mpDeserialize ([Object] -> Either Text [a]) -> [Object] -> Either Text [a]
forall a b. (a -> b) -> a -> b
$ Vector Object -> [Object]
forall a. Vector a -> [a]
V.toList Vector Object
a
    mpDeserialize Object
o = Text -> Either Text [a]
forall a b. a -> Either a b
Left (Text -> Either Text [a]) -> Text -> Either Text [a]
forall a b. (a -> b) -> a -> b
$ Text
"Could not deserialize as array: " 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)