{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}

module Eventium.Serializer
  ( -- * Class
    Serializer (..),
    simpleSerializer,
    composeSerializers,

    -- * Common serializers
    idSerializer,
    traverseSerializer,
    jsonSerializer,
    jsonTextSerializer,
    dynamicSerializer,

    -- * Sum types
    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

-- | A 'Serializer' describes the injective conversion between types @a@ and
-- @b@. In plain English, this means that you can go from @a@ to @b@, and you
-- can 'Maybe' go from @b@ back to @a@. This is often used to serialize events
-- to an event store, and then deserialize them back.
data Serializer a b
  = Serializer
  { forall a b. Serializer a b -> a -> b
serialize :: a -> b,
    forall a b. Serializer a b -> b -> Maybe a
deserialize :: b -> Maybe a,
    -- | Deserialize with additional information on failure
    forall a b. Serializer a b -> b -> Either String a
deserializeEither :: b -> Either String a
  }

-- | Simple constructor to just use 'deserialize' to construct
-- 'deserializeEither'.
simpleSerializer ::
  (a -> b) ->
  (b -> Maybe a) ->
  Serializer a b
simpleSerializer :: forall a b. (a -> b) -> (b -> Maybe a) -> Serializer a b
simpleSerializer a -> b
serialize' b -> Maybe a
deserialize' =
  Serializer
    { serialize :: a -> b
serialize = a -> b
serialize',
      deserialize :: b -> Maybe a
deserialize = b -> Maybe a
deserialize',
      deserializeEither :: b -> Either String a
deserializeEither = Either String a
-> (a -> Either String a) -> Maybe a -> Either String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String a
forall a b. a -> Either a b
Left String
"Serializable: Failed to deserialize") a -> Either String a
forall a b. b -> Either a b
Right (Maybe a -> Either String a)
-> (b -> Maybe a) -> b -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe a
deserialize'
    }

-- | Apply an intermediate 'Serializer' to a serializer to go from type @a@ to
-- @c@ with @b@ in the middle. Note that with deserializing, if the conversion
-- from @c@ to @b@ or from @b@ to @a@ fails, the whole deserialization fails.
composeSerializers :: Serializer a b -> Serializer b c -> Serializer a c
composeSerializers :: forall a b c. Serializer a b -> Serializer b c -> Serializer a c
composeSerializers Serializer a b
serializer1 Serializer b c
serializer2 = (a -> c)
-> (c -> Maybe a) -> (c -> Either String a) -> Serializer a c
forall a b.
(a -> b)
-> (b -> Maybe a) -> (b -> Either String a) -> Serializer a b
Serializer a -> c
serialize' c -> Maybe a
deserialize' c -> Either String a
deserializeEither'
  where
    serialize' :: a -> c
serialize' = Serializer b c -> b -> c
forall a b. Serializer a b -> a -> b
serialize Serializer b c
serializer2 (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Serializer a b -> a -> b
forall a b. Serializer a b -> a -> b
serialize Serializer a b
serializer1
    deserialize' :: c -> Maybe a
deserialize' c
x = Serializer b c -> c -> Maybe b
forall a b. Serializer a b -> b -> Maybe a
deserialize Serializer b c
serializer2 c
x Maybe b -> (b -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Serializer a b -> b -> Maybe a
forall a b. Serializer a b -> b -> Maybe a
deserialize Serializer a b
serializer1
    deserializeEither' :: c -> Either String a
deserializeEither' c
x = Serializer b c -> c -> Either String b
forall a b. Serializer a b -> b -> Either String a
deserializeEither Serializer b c
serializer2 c
x Either String b -> (b -> Either String a) -> Either String a
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Serializer a b -> b -> Either String a
forall a b. Serializer a b -> b -> Either String a
deserializeEither Serializer a b
serializer1

-- | Simple "serializer" using 'id'. Useful for when an API requires a
-- serializer but you don't need to actually change types.
idSerializer :: Serializer a a
idSerializer :: forall a. Serializer a a
idSerializer = (a -> a) -> (a -> Maybe a) -> Serializer a a
forall a b. (a -> b) -> (b -> Maybe a) -> Serializer a b
simpleSerializer a -> a
forall a. a -> a
id a -> Maybe a
forall a. a -> Maybe a
Just

-- | Uses 'Traversable' to wrap a 'Serializer'.
traverseSerializer ::
  (Traversable t) =>
  Serializer a b ->
  Serializer (t a) (t b)
traverseSerializer :: forall (t :: * -> *) a b.
Traversable t =>
Serializer a b -> Serializer (t a) (t b)
traverseSerializer Serializer {a -> b
b -> Maybe a
b -> Either String a
serialize :: forall a b. Serializer a b -> a -> b
deserialize :: forall a b. Serializer a b -> b -> Maybe a
deserializeEither :: forall a b. Serializer a b -> b -> Either String a
serialize :: a -> b
deserialize :: b -> Maybe a
deserializeEither :: b -> Either String a
..} =
  (t a -> t b)
-> (t b -> Maybe (t a))
-> (t b -> Either String (t a))
-> Serializer (t a) (t b)
forall a b.
(a -> b)
-> (b -> Maybe a) -> (b -> Either String a) -> Serializer a b
Serializer t a -> t b
serialize' t b -> Maybe (t a)
deserialize' t b -> Either String (t a)
deserializeEither'
  where
    serialize' :: t a -> t b
serialize' = (a -> b) -> t a -> t b
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
serialize
    deserialize' :: t b -> Maybe (t a)
deserialize' = (b -> Maybe a) -> t b -> Maybe (t a)
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) -> t a -> f (t b)
traverse b -> Maybe a
deserialize
    deserializeEither' :: t b -> Either String (t a)
deserializeEither' = (b -> Either String a) -> t b -> Either String (t a)
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) -> t a -> f (t b)
traverse b -> Either String a
deserializeEither

-- | A 'Serializer' for aeson 'Value's.
jsonSerializer :: (ToJSON a, FromJSON a) => Serializer a Value
jsonSerializer :: forall a. (ToJSON a, FromJSON a) => Serializer a Value
jsonSerializer =
  Serializer
    { serialize :: a -> Value
serialize = a -> Value
forall a. ToJSON a => a -> Value
toJSON,
      deserialize :: Value -> Maybe a
deserialize = \Value
x ->
        case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
x of
          Success a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
          Error String
_ -> Maybe a
forall a. Maybe a
Nothing,
      deserializeEither :: Value -> Either String a
deserializeEither = \Value
x ->
        case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
x of
          Success a
a -> a -> Either String a
forall a b. b -> Either a b
Right a
a
          Error String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e
    }

-- | A 'Serializer' to convert JSON to/from lazy text. Useful for Sql event
-- stores that store JSON values as text.
jsonTextSerializer :: (ToJSON a, FromJSON a) => Serializer a TL.Text
jsonTextSerializer :: forall a. (ToJSON a, FromJSON a) => Serializer a Text
jsonTextSerializer =
  Serializer
    { serialize :: a -> Text
serialize = ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode,
      deserialize :: Text -> Maybe a
deserialize = ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe a) -> (Text -> ByteString) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8,
      deserializeEither :: Text -> Either String a
deserializeEither = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> (Text -> ByteString) -> Text -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
    }

-- | A 'Serializer' for 'Dynamic' values using 'toDyn' and 'fromDynamic'.
dynamicSerializer :: (Typeable a) => Serializer a Dynamic
dynamicSerializer :: forall a. Typeable a => Serializer a Dynamic
dynamicSerializer = (a -> Dynamic) -> (Dynamic -> Maybe a) -> Serializer a Dynamic
forall a b. (a -> b) -> (b -> Maybe a) -> Serializer a b
simpleSerializer a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic

-- | A 'Serializer' from one 'EventSumType' instance to another. WARNING: If
-- not all events in the source 'EventSumType' are in the @serialized@
-- 'EventSumType', then this function will be partial!
eventSumTypeSerializer :: (Typeable a, EventSumType a, EventSumType b) => Serializer a b
eventSumTypeSerializer :: forall a b.
(Typeable a, EventSumType a, EventSumType b) =>
Serializer a b
eventSumTypeSerializer = (a -> b) -> (b -> Maybe a) -> Serializer a b
forall a b. (a -> b) -> (b -> Maybe a) -> Serializer a b
simpleSerializer a -> b
forall {a} {a}.
(Typeable a, EventSumType a, EventSumType a) =>
a -> a
serialize' b -> Maybe a
deserialize'
  where
    serialize' :: a -> a
serialize' a
event =
      a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe
        (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Failure in eventSumTypeSerializer. Can't serialize " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
event))
        (Dynamic -> Maybe a
forall a. EventSumType a => Dynamic -> Maybe a
eventFromDyn (Dynamic -> Maybe a) -> Dynamic -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> Dynamic
forall a. EventSumType a => a -> Dynamic
eventToDyn a
event)
    deserialize' :: b -> Maybe a
deserialize' = Dynamic -> Maybe a
forall a. EventSumType a => Dynamic -> Maybe a
eventFromDyn (Dynamic -> Maybe a) -> (b -> Dynamic) -> b -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Dynamic
forall a. EventSumType a => a -> Dynamic
eventToDyn

-- | This is a type class for serializing sum types of events to 'Dynamic'
-- without the associated constructor. This is useful when transforming between
-- two sum types of events. A common pattern is to put all the events in an
-- application in one big event sum type, and then have a smaller sum type for
-- each 'Projection'. Then, you can use 'eventSumTypeSerializer' to transform
-- between the two.
--
-- It is meant to be derived with 'Generic'. For example:
--
-- @
--    data EventA = EventA deriving (Show)
--    data EventB = EventB deriving (Show)
--    data EventC = EventC deriving (Show)
--
--    data AllEvents
--      = AllEventsEventA EventA
--      | AllEventsEventB EventB
--      | AllEventsEventC EventC
--      deriving (Show, Generic)
--
--    instance EventSumType AllEvents
--
--    data MyEvents
--      = MyEventsEventA EventA
--      | MyEventsEventB EventB
--      deriving (Show, Generic)
--
--    instance EventSumType MyEvents
-- @
--
-- Now we can serialize to 'Dynamic' without a constructor tag:
--
-- >>> eventToDyn (MyEventsEventA EventA)
-- <<EventA>>
--
-- We can also go from a 'MyEvents' value to an 'AllEvents' value:
--
-- >>> eventFromDyn (eventToDyn (MyEventsEventA EventA)) :: Maybe AllEvents
-- Just (AllEventsEventA EventA)
class EventSumType a where
  -- | Convert an event to a 'Dynamic' without the constructor tag
  eventToDyn :: a -> Dynamic

  -- | Go from a 'Dynamic' to an event with the constructor tag. Note, this
  -- function is @O(n)@ to the number of constructors.
  eventFromDyn :: Dynamic -> Maybe a

  default eventToDyn :: (Generic a, EventSumType' (Rep a)) => a -> Dynamic
  eventToDyn a
x = Rep a Any -> Dynamic
forall p. Rep a p -> Dynamic
forall (f :: * -> *) p. EventSumType' f => f p -> Dynamic
eventToDyn' (a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x)

  default eventFromDyn :: (Generic a, EventSumType' (Rep a)) => Dynamic -> Maybe a
  eventFromDyn = (Rep a Any -> a) -> Maybe (Rep a Any) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Maybe (Rep a Any) -> Maybe a)
-> (Dynamic -> Maybe (Rep a Any)) -> Dynamic -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Maybe (Rep a Any)
forall p. Dynamic -> Maybe (Rep a p)
forall (f :: * -> *) p. EventSumType' f => Dynamic -> Maybe (f p)
eventFromDyn'

-- Auxiliary type class for 'EventSumType' Generic fun
class EventSumType' f where
  eventToDyn' :: f p -> Dynamic
  eventFromDyn' :: Dynamic -> Maybe (f p)

-- M1 is the top-level metadata. We don't need the metadata so we just pass on
-- through.
instance (EventSumType' f) => EventSumType' (M1 i t f) where
  eventToDyn' :: forall p. M1 i t f p -> Dynamic
eventToDyn' (M1 f p
x) = f p -> Dynamic
forall p. f p -> Dynamic
forall (f :: * -> *) p. EventSumType' f => f p -> Dynamic
eventToDyn' f p
x
  eventFromDyn' :: forall p. Dynamic -> Maybe (M1 i t f p)
eventFromDyn' = (f p -> M1 i t f p) -> Maybe (f p) -> Maybe (M1 i t f p)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 i t f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe (f p) -> Maybe (M1 i t f p))
-> (Dynamic -> Maybe (f p)) -> Dynamic -> Maybe (M1 i t f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Maybe (f p)
forall p. Dynamic -> Maybe (f p)
forall (f :: * -> *) p. EventSumType' f => Dynamic -> Maybe (f p)
eventFromDyn'

-- The :+: operator is for when a type has multiple constructors. When
-- serializing, we just pass on through. When deserializing, we try the first
-- constructor, and if that fails then the second.
instance (EventSumType' f, EventSumType' g) => EventSumType' (f :+: g) where
  eventToDyn' :: forall p. (:+:) f g p -> Dynamic
eventToDyn' (L1 f p
x) = f p -> Dynamic
forall p. f p -> Dynamic
forall (f :: * -> *) p. EventSumType' f => f p -> Dynamic
eventToDyn' f p
x
  eventToDyn' (R1 g p
x) = g p -> Dynamic
forall p. g p -> Dynamic
forall (f :: * -> *) p. EventSumType' f => f p -> Dynamic
eventToDyn' g p
x
  eventFromDyn' :: forall p. Dynamic -> Maybe ((:+:) f g p)
eventFromDyn' Dynamic
dyn = (f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> Maybe (f p) -> Maybe ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe (f p)
forall p. Dynamic -> Maybe (f p)
forall (f :: * -> *) p. EventSumType' f => Dynamic -> Maybe (f p)
eventFromDyn' Dynamic
dyn) Maybe ((:+:) f g p) -> Maybe ((:+:) f g p) -> Maybe ((:+:) f g p)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> Maybe (g p) -> Maybe ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe (g p)
forall p. Dynamic -> Maybe (g p)
forall (f :: * -> *) p. EventSumType' f => Dynamic -> Maybe (f p)
eventFromDyn' Dynamic
dyn)

-- K1 R represents an actual constructor. This is where we do the actual
-- conversion to/from 'Dynamic'.
instance (Typeable c) => EventSumType' (K1 R c) where
  eventToDyn' :: forall p. K1 R c p -> Dynamic
eventToDyn' (K1 c
x) = c -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn c
x
  eventFromDyn' :: forall p. Dynamic -> Maybe (K1 R c p)
eventFromDyn' Dynamic
dyn = c -> K1 R c p
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 R c p) -> Maybe c -> Maybe (K1 R c p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe c
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn