{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Hercules.Agent.WorkerProtocol.Orphans where

import Control.Monad.Fail (fail)
import qualified Data.Aeson as A
import Data.Binary (Binary (get, put))
import Hercules.API.Id (Id (..))
import Hercules.CNix.Expr (ViaJSON (ViaJSON))
import Protolude hiding (get, put)

-- | Orphan
instance Binary (Id (a :: k)) where
  put :: Id a -> Put
put (Id UUID
uuid) = UUID -> Put
forall t. Binary t => t -> Put
put UUID
uuid
  get :: Get (Id a)
get = UUID -> Id a
forall k (a :: k). UUID -> Id a
Id (UUID -> Id a) -> Get UUID -> Get (Id a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get UUID
forall t. Binary t => Get t
get

-- | Orphan
instance (A.ToJSON a, A.FromJSON a) => Binary (ViaJSON a) where
  put :: ViaJSON a -> Put
put (ViaJSON a
a) = ByteString -> Put
forall t. Binary t => t -> Put
put (a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
a)
  get :: Get (ViaJSON a)
get = do
    ByteString
bs <- Get ByteString
forall t. Binary t => Get t
get
    case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
bs of
      Left String
s -> String -> Get (ViaJSON a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
      Right a
r -> ViaJSON a -> Get (ViaJSON a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ViaJSON a
forall a. a -> ViaJSON a
ViaJSON a
r)