RPCStorage.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module RPC2.Storage where

import HBS2.Actors.Peer.Types
import HBS2.Prelude.Plated
import HBS2.Data.Types.Refs (HashRef(..),RefAlias(..))
import HBS2.Storage

import HBS2.Net.Proto.Service

import RPC2.Types

import Data.Functor
import Data.ByteString.Lazy ( ByteString )
import Control.Monad.Reader

data RpcStorageHasBlock
data RpcStorageGetBlock
data RpcStorageEnqueueBlock
data RpcStoragePutBlock
data RpcStorageGetChunk
data RpcStorageGetRef
data RpcStorageUpdateRef
data RpcStorageDelRef

type StorageAPI = '[ RpcStorageHasBlock
                   , RpcStorageHasBlock
                   , RpcStorageGetBlock
                   , RpcStorageEnqueueBlock
                   , RpcStoragePutBlock
                   , RpcStorageGetChunk
                   , RpcStorageGetRef
                   , RpcStorageUpdateRef
                   , RpcStorageDelRef
                   ]

instance Monad m => HasRpcContext AnyStorage (ReaderT AnyStorage m) where
  getRpcContext = ask

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageHasBlock where
  type instance Input RpcStorageHasBlock = HashRef
  type instance Output RpcStorageHasBlock = Maybe Integer

  handleMethod href = do
    sto <- getRpcContext @AnyStorage
    liftIO $ hasBlock sto (fromHashRef href)

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetBlock where
  type instance Input RpcStorageGetBlock = HashRef
  type instance Output RpcStorageGetBlock = Maybe ByteString

  handleMethod href = do
    sto <- getRpcContext @AnyStorage
    liftIO $ getBlock sto (fromHashRef href)

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageEnqueueBlock where
  type instance Input RpcStorageEnqueueBlock = ByteString
  type instance Output RpcStorageEnqueueBlock = Maybe HashRef

  handleMethod lbs = do
    sto <- getRpcContext @AnyStorage
    liftIO $ enqueueBlock sto lbs <&> fmap HashRef

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStoragePutBlock where
  type instance Input RpcStoragePutBlock = ByteString
  type instance Output RpcStoragePutBlock = Maybe HashRef

  handleMethod lbs = do
    sto <- getRpcContext @AnyStorage
    liftIO $ putBlock sto lbs <&> fmap HashRef

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetChunk where
  type instance Input RpcStorageGetChunk = (HashRef, Offset, Size)
  type instance Output RpcStorageGetChunk = Maybe ByteString

  handleMethod (h,o,s) = do
    sto <- getRpcContext @AnyStorage
    liftIO $ getChunk sto (fromHashRef h) o s

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetRef where
  type instance Input RpcStorageGetRef = RefAlias
  type instance Output RpcStorageGetRef = Maybe HashRef

  handleMethod ref = do
    sto <- getRpcContext @AnyStorage
    liftIO $ getRef sto ref <&> fmap HashRef

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageUpdateRef where
  type instance Input RpcStorageUpdateRef = (RefAlias, HashRef)
  type instance Output RpcStorageUpdateRef = ()

  handleMethod (ref, val) = do
    sto <- getRpcContext @AnyStorage
    liftIO $ updateRef sto ref (fromHashRef val)

instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageDelRef where
  type instance Input RpcStorageDelRef = RefAlias
  type instance Output RpcStorageDelRef = ()

  handleMethod ref = do
    sto <- getRpcContext @AnyStorage
    liftIO $ delRef sto ref