module Eventful.Serializer
(
Serializer (..)
, simpleSerializer
, composeSerializers
, idSerializer
, traverseSerializer
, jsonSerializer
, jsonTextSerializer
, dynamicSerializer
, EventSumType (..)
, eventSumTypeSerializer
) where
import Control.Applicative ((<|>))
import Data.Aeson
import Data.Dynamic
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Typeable (typeOf)
import GHC.Generics
data Serializer a b =
Serializer
{ serialize :: a -> b
, deserialize :: b -> Maybe a
, deserializeEither :: b -> Either String a
}
simpleSerializer
:: (a -> b)
-> (b -> Maybe a)
-> Serializer a b
simpleSerializer serialize' deserialize' =
Serializer
{ serialize = serialize'
, deserialize = deserialize'
, deserializeEither = maybe (Left "Serializable: Failed to deserialize") Right . deserialize'
}
composeSerializers :: Serializer a b -> Serializer b c -> Serializer a c
composeSerializers serializer1 serializer2 = Serializer serialize' deserialize' deserializeEither'
where
serialize' = serialize serializer2 . serialize serializer1
deserialize' x = deserialize serializer2 x >>= deserialize serializer1
deserializeEither' x = deserializeEither serializer2 x >>= deserializeEither serializer1
idSerializer :: Serializer a a
idSerializer = simpleSerializer id Just
traverseSerializer
:: (Traversable t)
=> Serializer a b
-> Serializer (t a) (t b)
traverseSerializer Serializer{..} =
Serializer serialize' deserialize' deserializeEither'
where
serialize' = fmap serialize
deserialize' = traverse deserialize
deserializeEither' = traverse deserializeEither
jsonSerializer :: (ToJSON a, FromJSON a) => Serializer a Value
jsonSerializer =
Serializer
{ serialize = toJSON
, deserialize = \x ->
case fromJSON x of
Success a -> Just a
Error _ -> Nothing
, deserializeEither = \x ->
case fromJSON x of
Success a -> Right a
Error e -> Left e
}
jsonTextSerializer :: (ToJSON a, FromJSON a) => Serializer a TL.Text
jsonTextSerializer =
Serializer
{ serialize = TLE.decodeUtf8 . encode
, deserialize = decode . TLE.encodeUtf8
, deserializeEither = eitherDecode . TLE.encodeUtf8
}
dynamicSerializer :: (Typeable a) => Serializer a Dynamic
dynamicSerializer = simpleSerializer toDyn fromDynamic
eventSumTypeSerializer :: (Typeable a, EventSumType a, EventSumType b) => Serializer a b
eventSumTypeSerializer = simpleSerializer serialize' deserialize'
where
serialize' event =
fromMaybe
(error $ "Failure in eventSumTypeSerializer. Can't serialize " ++ show (typeOf event))
(eventFromDyn $ eventToDyn event)
deserialize' = eventFromDyn . eventToDyn
class EventSumType a where
eventToDyn :: a -> Dynamic
eventFromDyn :: Dynamic -> Maybe a
default eventToDyn :: (Generic a, EventSumType' (Rep a)) => a -> Dynamic
eventToDyn x = eventToDyn' (from x)
default eventFromDyn :: (Generic a, EventSumType' (Rep a)) => Dynamic -> Maybe a
eventFromDyn = fmap to . eventFromDyn'
class EventSumType' f where
eventToDyn' :: f p -> Dynamic
eventFromDyn' :: Dynamic -> Maybe (f p)
instance (EventSumType' f) => EventSumType' (M1 i t f) where
eventToDyn' (M1 x) = eventToDyn' x
eventFromDyn' = fmap M1 . eventFromDyn'
instance (EventSumType' f, EventSumType' g) => EventSumType' (f :+: g) where
eventToDyn' (L1 x) = eventToDyn' x
eventToDyn' (R1 x) = eventToDyn' x
eventFromDyn' dyn = (L1 <$> eventFromDyn' dyn) <|> (R1 <$> eventFromDyn' dyn)
instance (Typeable c) => EventSumType' (K1 R c) where
eventToDyn' (K1 x) = toDyn x
eventFromDyn' dyn = K1 <$> fromDynamic dyn