Typelevel dialog server spec

2023-08-10 23:31:43 +04:00 · 2023-08-10 23:31:43 +04:00 · 08c95bc9a9
parent b22dc35283
commit 08c95bc9a9
12 changed files with 754 additions and 144 deletions
--- a/.hlint.yaml
+++ b/.hlint.yaml
@ -0,0 +1,6 @@
+- ignore: {name: "Use infix"} # 2 hints
+- ignore: {name: "Use let"} # 4 hints
+- ignore: {name: "Use newtype instead of data"} # 4 hints
+- ignore: {name: "Use print"} # 1 hint
+- ignore: {name: "Redundant bracket Found"} # 1 hint
+- ignore: {name: "Redundant $"} # 1 hint
--- a/hbs2-core/hbs2-core.cabal
+++ b/hbs2-core/hbs2-core.cabal
@ -20,6 +20,7 @@ common shared-properties
  ghc-options:
        -Wall
        -fno-warn-type-defaults
+        -- -fprint-potential-instances
        -- -prof -fprof-auto
        -- -fno-warn-unused-matches
        -- -fno-warn-unused-do-bind
@ -40,6 +41,7 @@ common shared-properties
                     , ConstraintKinds
                     , DataKinds
                     , DeriveDataTypeable
+                     , DeriveFunctor
                     , DeriveGeneric
                     , DerivingStrategies
                     , DerivingVia
@ -139,6 +141,7 @@ library
                    , cache
                    , cborg
                    , clock
+                    , constraints
                    , containers
                    , cryptonite
                    , data-default
--- a/hbs2-core/lib/HBS2/Actors/Peer.hs
+++ b/hbs2-core/lib/HBS2/Actors/Peer.hs
@ -168,6 +168,7 @@ newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
                                       , MonadReader (PeerEnv e)
                                       , MonadIO
                                       , MonadUnliftIO
+                                       , MonadTrans
                                       )


@ -191,10 +192,10 @@ makeLenses 'PeerEnv
 makeLenses 'ResponseEnv


-runResponseM :: forall e m . (Monad m)
+runResponseM :: forall e m a . (Monad m)
             => Peer e
-             -> ResponseM e m ()
-             -> m ()
+             -> ResponseM e m a
+             -> m a

 runResponseM peer f = runReaderT (fromResponse f) (ResponseEnv peer)

--- a/hbs2-core/lib/HBS2/Net/Dialog/Client.hs
+++ b/hbs2-core/lib/HBS2/Net/Dialog/Client.hs
@ -96,10 +96,11 @@ dQuery' par dcli peer rq go =

    processResponseHeader rhxs@(rh, xs) = case ((responseStatusCode . respStatus) rh) of
        Success200 -> Left (Just rhxs, RequestDone)
+        SuccessNoContent204 -> Left (Just rhxs, RequestDone)
        SuccessMore -> Right rhxs
-        r@BadRequest400 -> Left (Nothing, (RequestFailure r xs))
-        r@Forbidden403 -> Left (Nothing, (RequestFailure r xs))
-        r@NotFound404 -> Left (Nothing, (RequestFailure r xs))
+        BadRequest400 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
+        Forbidden403 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
+        NotFound404 -> Left (Nothing, (RequestFailure (respStatus rh) xs))

    rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)

--- a/hbs2-core/lib/HBS2/Net/Dialog/Core.hs
+++ b/hbs2-core/lib/HBS2/Net/Dialog/Core.hs
@ -1,55 +1,73 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- {-# LANGUAGE ConstraintKinds       #-}
 -- {-# LANGUAGE OverloadedLists #-}
-- {-# LANGUAGE UndecidableInstances #-}
+
+-- {-# LANGUAGE CPP                   #-}
+-- {-# LANGUAGE DataKinds             #-}
+-- {-# LANGUAGE FlexibleContexts      #-}
+-- {-# LANGUAGE FlexibleInstances     #-}
+-- {-# LANGUAGE MultiParamTypeClasses #-}
+-- {-# LANGUAGE OverloadedStrings     #-}
+-- {-# LANGUAGE RankNTypes            #-}
+-- {-# LANGUAGE ScopedTypeVariables   #-}
+-- {-# LANGUAGE TupleSections         #-}
+-- {-# LANGUAGE TypeApplications      #-}
+-- {-# LANGUAGE TypeFamilies          #-}
+
+
 module HBS2.Net.Dialog.Core where

-- import Data.ByteString.Builder as Builder
-- import Data.ByteString.Builder.Internal as Builder
-- import GHC.IsList
 import Codec.Serialise
 import Control.Arrow
 import Control.Monad
 import Control.Monad.Error.Class
-import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT)
+import Control.Monad.Except (Except, ExceptT(..), runExcept, runExceptT)
 import Control.Monad.IO.Class
 import Control.Monad.State.Class as State
-import Control.Monad.State.Strict (evalStateT)
+import Control.Monad.State.Strict as StateStrict (evalState, evalStateT, runStateT, StateT(..))
 import Control.Monad.Trans.Class
-import Control.Monad.Writer qualified as W
 import Data.Binary.Get as Get
 import Data.Binary.Put as Put
 import Data.Bits
 import Data.Bool
-import Data.ByteArray (ByteArrayAccess)
-import Data.ByteArray.Sized as BAS
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
+import Data.ByteString.Base16 qualified as B16
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as BSL
-import Data.Foldable
+import Data.Constraint (Dict(..))
 import Data.Foldable as F
 import Data.Function
-import Data.Generics.Labels
-import Data.Generics.Product.Fields
+import Data.Functor
+import Data.Generics.Labels ()
+import Data.Generics.Product.Fields ()
+import Data.Generics.Sum.Constructors
+import Data.Kind
 import Data.List qualified as List
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict as Map
 import Data.Maybe
+import Data.Proxy
 import Data.String.Conversions as X (cs)
 import Data.Text (Text)
+import Data.Typeable
 import Data.Word
-import GHC.Exts
-import GHC.Generics (Generic)
+import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..))
+import GHC.Generics qualified as Generics
+import GHC.TypeLits
 import Lens.Micro.Platform
-import Numeric.Natural
+import Streaming
 import System.Random.MWC
-import UnliftIO.Exception
 import UnliftIO.STM

-- import Prettyprinter
-- import HBS2.Base58
-import Data.ByteString.Base16 qualified as B16
-
 import HBS2.Net.Dialog.Helpers.List

 type Frames = Frames' ByteString
@ -90,8 +108,8 @@ encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
            let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs

            putWord8 $ n1
-                & (bool (sbit 7) id (List.null xs))
-                & (bool (sbit 6) id (List.null ns))
+                & bool (sbit 7) id (List.null xs)
+                & bool (sbit 6) id (List.null ns)

            forM_ (markMore ns) \(n, isMoreBytesInSize) -> do
                putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize
@ -122,14 +140,14 @@ decodeFrames = \case

              j <- getWord8

-              size <-
+              bsize <-
                  flip fix (6, j) \fu (b, j') -> do
                      let n = (fromIntegral . clearLeftBits (8-b)) j'
-                      if (tbit b j')
+                      if tbit b j'
                            then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8)
                            else pure n

-              bs <- getByteString size
+              bs <- getByteString bsize

              let moreFrames = tbit 7 j

@ -197,7 +215,7 @@ instance Serialise CallerID

 newCallerID :: forall m. MonadIO m => m CallerID
 newCallerID = liftIO $ withSystemRandomST \g ->
-    CallerID <$> (uniformM g) <*> (uniformM g)
+    CallerID <$> uniformM g <*> uniformM g

 ---

@ -244,7 +262,7 @@ data RequestResult
  = RequestDone
  -- | RequestSuccessIncomplete
  | RequestTimeout
-  | RequestFailure ResponseStatusCode Frames
+  | RequestFailure ResponseStatus Frames
  | RequestErrorBadResponse BadResponse Frames
  deriving stock (Generic, Eq, Show)

@ -259,7 +277,7 @@ data BadResponse
 setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m ()
 setupCallerEnv env callerID repHandleEnv =
    (atomically . modifyTVar' (unCallerEnv env))
-        (at callerID .~ Just repHandleEnv)
+        (at callerID ?~ repHandleEnv)

 clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m ()
 clearCallerEnv env callerID =
@ -268,14 +286,14 @@ clearCallerEnv env callerID =

 findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m'))
 findCallerHandler CallerEnv{..} callerID =
-    (atomically (readTVar unCallerEnv)) <&> (preview (ix callerID))
+    readTVarIO unCallerEnv <&> preview (ix callerID)

 ---

 setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
 setupRepHandler RequestResponseEnv{..} requestID useResponse =
    (atomically . modifyTVar' unRequestResponseEnv)
-        (at requestID .~ Just useResponse)
+        (at requestID ?~ useResponse)

 clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m ()
 clearRepHandler RequestResponseEnv{..} requestID =
@ -284,7 +302,7 @@ clearRepHandler RequestResponseEnv{..} requestID =

 findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m'))
 findRepHandler RequestResponseEnv{..} requestID =
-    (atomically (readTVar unRequestResponseEnv)) <&> (preview (ix requestID))
+    readTVarIO unRequestResponseEnv <&> preview (ix requestID)

 ---

@ -300,25 +318,106 @@ data DialogRequestEnv m p pd = DialogRequestEnv

 ---

-newtype DialogRequestRouter m = DialogRequestRouter
-  { unDialogRequestRouter ::
-        Map [ByteString]  -- path
+-- type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+type DApp m = Frames -> (Frames -> m ()) -> m ()

-        -- handler :: Input -> m (Either ErrorMessage (HowToReply -> ResponseContinuation))
-            (Frames -> Either Text ((Frames -> m ()) -> m ()))
-  }
+mkDApp ::
+    forall spec ctx m io.
+    ( Monad m
+    , Monad io
+    , HasHandler m (NamedSpec spec) ctx
+    , HasHandler io (NamedSpec spec) ctx
+    )
+    => Proxy (NamedSpec spec)
+    -> Ctx ctx
+    -> (forall x. m x -> DialHandlerT io x)
+    -> spec (ModeServerT m)
+    -> DApp io
+mkDApp p ctx ntToDialHandlerTn hd = routeDialogRequest rr
+  where
+    rr :: DialogRequestRouter io
+    rr = route p ctx
+        $ hoistDialogWithContext p (Proxy @ctx) ntToDialHandlerTn
+          hd

-  deriving (Semigroup, Monoid)
+type DialogReplyHandler m = (Frames -> m ()) -> m ()
+
+type DialogRequestRouter (m :: Type -> Type) =
+     DialogRequestRoutes (DialogReplyHandler m)
+
+data DialogRequestRoutes (h :: Type)
+  = DialogRequestPaths (Map ByteString (DialogRequestRoutes h))
+  | DialogRequestPreparse (Frames -> Either Text (DialogRequestRoutes h, Frames))
+  | DialogRequestEndpoint h
+  deriving (Generic, Functor)
+
+instance Semigroup (DialogRequestRoutes h) where
+  (<>) a b = case (a, b) of
+      (DialogRequestPaths p1, DialogRequestPaths p2) ->
+          DialogRequestPaths (p1 <> p2)
+      _ -> b
+
+-- instance Monoid (DialogRequestRoutes h) where
+--   mempty = DialogRequestPaths mempty

 dialogRequestRoutes
    :: ListBuilder
-          ([ByteString], Frames -> Either Text ((Frames -> m ()) -> m ()))
+          ([ByteString], Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
    -> DialogRequestRouter m
-dialogRequestRoutes = DialogRequestRouter . Map.fromList . buildList
+dialogRequestRoutes = List.foldl1' (<>)
+      . fmap toPaths
+      . over (traverse . _2) (DialogRequestPreparse . (fmap . fmap) (over _1 DialogRequestEndpoint))
+      . buildList
+  where
+    toPaths :: ([ByteString], DialogRequestRoutes ((Frames -> m ()) -> m ()))
+       -> DialogRequestRoutes (DialogReplyHandler m)
+    toPaths = fix \go (ps, rr) -> case ps of
+        [] -> rr
+        [p] -> DialogRequestPaths (Map.singleton p rr)
+        p:px' -> DialogRequestPaths (Map.singleton p (go (px', rr)))

 hand :: Monad m => a -> b -> ListBuilderT m (a, b)
 hand = curry li

+handconv :: (Monad m, Monad m', Serialise req, Serialise resp)
+    => a
+    -> Text
+    -> (req -> ExceptT ResponseStatus m resp)
+    -> ListBuilderT m' (a, Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
+handconv path msg h =
+    hand path $ processReply msg h
+
+---
+
+processReply :: forall m m' req resp .
+    ( Monad m
+    , Serialise req
+    , Serialise resp
+    , m' ~ ExceptT ResponseStatus m
+    )
+    => Text
+    -> (req -> m' resp)
+    -> Frames
+    -> Either Text ((Frames -> m ()) -> m (), Frames)
+processReply msg h = runExcept . runStateT do
+    flip runReply . h <$> cutFrameDecode msg
+
+runReply ::
+    ( Monad m
+    , Serialise a
+    )
+    => (Frames -> m r)
+    -> ExceptT ResponseStatus m a
+    -> m r
+runReply reply =
+        either
+            (\e -> reply (Frames [serialiseS (ResponseHeader e 0)]))
+            (\a -> reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
+                                  , serialiseS a
+                                  ])
+            )
+    <=< runExceptT
+
 ---

 dpath :: Text -> [ByteString] -> Frames
@ -350,6 +449,7 @@ instance Serialise ResponseStatus

 data ResponseStatusCode
  = Success200
+  | SuccessNoContent204
  | SuccessMore
  | BadRequest400
  | Forbidden403
@ -361,14 +461,14 @@ instance Serialise ResponseStatusCode
 routerSignature :: Word8
 routerSignature = 1

-routeDialogRequest :: forall m p pd .
+routeDialogRequest :: forall m .
       Monad m
    => DialogRequestRouter m
-    -> DialogRequestEnv m p pd
-    -> (Frames -> m ())
    -> Frames
+    -> (Frames -> m ())
    -> m ()
-routeDialogRequest router drenv rawReplyToPeer frames = do
+routeDialogRequest router frames rawReplyToPeer = do
+    -- error $ show router
    erun <- pure $ runExcept $ flip evalStateT req do

        signature <- cutFrameDecode
@ -377,26 +477,22 @@ routeDialogRequest router drenv rawReplyToPeer frames = do
        when (signature /= routerSignature) $ throwError
            (ResponseStatus BadRequest400 "Wrong signature in request")

-        route <- cutFrameOr
-            (ResponseStatus BadRequest400 "No route in request")
-
-        h <- fromJustThrowError
-            (ResponseStatus NotFound404 "Route not found")
-            (unDialogRequestRouter router ^? ix (BS8.split '/' route))
+        path <- cutFrameOr
+            (ResponseStatus BadRequest400 "No path in request")

        lift . ExceptT . pure
-            -- Если не может разобрать параметры запроса,
-            -- то самим ответить этому пиру '404'
-            . left (ResponseStatus BadRequest400)
-            . h
-            -- передать оставшуюся часть запроса в хэндлер
-          =<< get
+              -- Если не может разобрать параметры запроса,
+              -- то самим ответить этому пиру '404'
+              -- . left (ResponseStatus BadRequest400)
+              . travel (BS8.split '/' path) router
+              -- передать оставшуюся часть запроса в хэндлер
+            =<< get

    case erun of
        Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
-        Right run ->
+        Right go ->
            -- передать хэндлеру продолжение чтобы ответить этому пиру
-            run replyToPeer
+            go replyToPeer

  where
    (backPath, req) = splitEnvelope frames
@ -404,6 +500,27 @@ routeDialogRequest router drenv rawReplyToPeer frames = do
    replyToPeer :: Frames -> m ()
    replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)

+travel :: ()
+    => [ByteString]
+    -> DialogRequestRouter m
+    -> Frames
+    -> Either ResponseStatus ((Frames -> m ()) -> m ())
+travel path'' router'' = evalStateT $ flipfix2 path'' router''
+    \go path -> \case
+        DialogRequestPaths kv -> case path of
+            step:path' ->
+                maybe
+                    (throwError (ResponseStatus BadRequest400 "Path not found"))
+                    (go path')
+                    (Map.lookup step kv)
+            _ -> throwError (ResponseStatus BadRequest400 "Path not found (too long)")
+        DialogRequestPreparse hfx ->
+            go path =<< StateT (left (ResponseStatus BadRequest400) . hfx)
+        DialogRequestEndpoint ep -> pure ep
+
+flipfix2 :: a -> b -> ((a -> b -> c) -> (a -> b -> c)) -> c
+flipfix2 a b f = fix f a b
+
 cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b
 cutFrameDecode e =
    State.gets unFrames >>= \case
@ -440,3 +557,275 @@ fromMaybeM ma = maybe ma pure
 fromJustThrowError :: MonadError e m => e -> Maybe a -> m a
 fromJustThrowError = fromMaybeM . throwError

+
+
+------------------------------------------
+--- Type-level specification -------------
+------------------------------------------
+
+
+data ReqCBOR (a :: Type)
+data SingleAck
+data SingleRespCBOR (a :: Type)
+data StreamingRespCBOR (a :: Type)
+
+data NamedSpec (spec :: Type -> Type)
+
+class DialMode mode where
+    type mode &- spec :: Type
+infixl 0 &-
+
+data (path :: k) &/ (a :: Type)
+    deriving (Typeable)
+infixr 4 &/
+
+type path &// a = path &/ NamedSpec a
+infixr 4 &//
+
+---
+
+data ModePlain
+instance DialMode ModePlain where
+    type ModePlain &- spec = spec
+
+---
+
+data ModeServerT (m :: Type -> Type)
+
+instance DialMode (ModeServerT m) where
+    type ModeServerT m &- spec = HandlerD spec m
+
+class HasHandler m spec ctx where
+  type HandlerD spec (m' :: Type -> Type) :: Type
+
+  route ::
+       Proxy spec
+    -> Ctx ctx
+    -> HandlerD spec (DialHandlerT m)
+    -> DialogRequestRouter m
+
+  hoistDialogWithContext
+      :: Proxy spec
+      -> Proxy ctx
+      -> (forall x. m x -> n x)
+      -> HandlerD spec m
+      -> HandlerD spec n
+
+data EmptyCX -- '[]
+data Ctx ctx where
+    EmptyCtx :: Ctx EmptyCX
+    -- (:&.) :: x -> Ctx xs -> Ctx (x ': xs)
+-- infixr 5 :&.
+
+-- hoistTRouter :: forall t m n .
+--       (MonadTrans t, Monad m, Monad n, m ~ t n)
+--       => (forall a . m a -> n a)
+--       -> DialogRequestRouter m
+--       -> DialogRequestRouter n
+-- hoistTRouter nt = fmap nt'
+--   where
+--     nt' :: ((x -> m y) -> m y)
+--         -> ((x -> n y) -> n y)
+--     nt' xtmy_tmy =  nt . xtmy_tmy . fmap lift
+
+hoistTRouter :: forall m n .
+      (Monad m, Monad n)
+      => (forall a . m a -> n a)
+      -> (forall a . n a -> m a)
+      -> DialogRequestRouter m
+      -> DialogRequestRouter n
+hoistTRouter ntf ntb = fmap nt'
+  where
+    nt' :: ((x -> m y) -> m y)
+        -> ((x -> n y) -> n y)
+    nt' xtmy_tmy =  ntf . xtmy_tmy . fmap ntb
+
+
+type DialHandlerIO a = DialHandlerT IO a
+newtype DialHandlerT m a = DialHandlerT { runDialHandlerT :: ExceptT ResponseStatus m a }
+  deriving
+    ( Generic, Functor, Applicative, Monad
+    , MonadIO
+    , MonadTrans
+    , MonadError ResponseStatus
+    -- , MonadUnliftIO
+    -- , MonadThrow, MonadCatch, MonadMask
+    )
+
+---
+
+instance (KnownSymbol path, HasHandler m spec ctx) => HasHandler m (path &/ spec) ctx where
+    type HandlerD (path &/ spec) m = HandlerD spec m
+
+    route _ ctx h = DialogRequestPaths $
+        Map.singleton (cs (symbolVal (Proxy @path))) (route (Proxy @spec) ctx h)
+
+    hoistDialogWithContext _ = hoistDialogWithContext (Proxy @spec)
+
+---
+
+instance
+  ( Serialise a
+  , Typeable a
+  , HasHandler m spec ctx
+  ) =>
+  HasHandler m (ReqCBOR a &/ spec) ctx where
+    type HandlerD (ReqCBOR a &/ spec) m = a -> HandlerD spec m
+
+    route _ ctx (ha :: a -> HandlerD spec (DialHandlerT m)) =
+        DialogRequestPreparse \fx -> do
+            (a, fx')
+                <- runExcept
+                  $ flip runStateT fx
+                  $ cutFrameDecode ((cs . show . typeRep) (Proxy @a))
+            pure (route (Proxy @spec) ctx (ha a), fx')
+
+    hoistDialogWithContext _ pc nt s = hoistDialogWithContext (Proxy @spec) pc nt . s
+
+---
+
+instance
+  ( Applicative m
+  ) =>
+  HasHandler m SingleAck ctx where
+    type HandlerD SingleAck m = m ()
+
+    route _ _ctx _mx =
+        DialogRequestEndpoint \reply -> do
+            reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessNoContent204 "") 0)])
+
+    hoistDialogWithContext _ _ nt hdlM = nt hdlM
+
+---
+
+instance
+  ( Monad m
+  , Serialise a
+  ) =>
+  HasHandler m (SingleRespCBOR a) ctx where
+    type HandlerD (SingleRespCBOR a) m = m a
+
+    route _ _ctx ma =
+        DialogRequestEndpoint \reply -> do
+
+            ea <- runExceptT $ runDialHandlerT ma
+
+            case ea of
+                Left e -> reply $ Frames [ serialiseS e ]
+                Right a -> reply $ Frames
+                    [ serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
+                    , serialiseS (a :: a)
+                    ]
+
+    hoistDialogWithContext _ _ nt hdlM = nt hdlM
+
+---
+
+instance
+  ( Serialise a
+  ) =>
+  HasHandler m (StreamingRespCBOR a) ctx where
+    type HandlerD (StreamingRespCBOR a) m = Stream (Of a) m ()
+
+    route = undefined
+
+    -- hoistDialogWithContext = undefined
+
+---
+
+type GServerConstraints spec m =
+  ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
+  , GProduct (Rep (spec (ModeServerT m)))
+  )
+
+class GServer (spec :: Type -> Type) (m :: Type -> Type) where
+  gServerProof :: Dict (GServerConstraints spec m)
+
+instance
+  ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
+  , GProduct (Rep (spec (ModeServerT m)))
+  ) => GServer spec m where
+  gServerProof = Dict
+
+
+instance
+  ( HasHandler m (GToProduct (Rep (spec ModePlain))) ctx
+  -- , HasHandler m (GToProduct (Rep (spec (ModeServerT m)))) ctx
+  -- , GProduct (Rep (spec ModePlain))
+  , forall q . Generic (spec (ModeServerT q))
+  , forall q . GServer spec q
+  ) =>
+  HasHandler m (NamedSpec spec) ctx where
+    type HandlerD (NamedSpec spec) m = spec (ModeServerT m)
+
+    route ::
+           Proxy (NamedSpec spec)
+        -> Ctx ctx
+        -> spec (ModeServerT (DialHandlerT m))
+        -> DialogRequestRouter m
+    route _ ctx spec =
+      case gServerProof @spec @(DialHandlerT m) of
+          Dict -> route (Proxy @(GToProduct (Rep (spec ModePlain)))) ctx (toProduct spec)
+
+    hoistDialogWithContext
+      :: forall n. Proxy (NamedSpec spec)
+      -> Proxy ctx
+      -> (forall x. m x -> n x)
+      -> spec (ModeServerT m)
+      -> spec (ModeServerT n)
+    hoistDialogWithContext _ pctx nat dl =
+      case (gServerProof @spec @m, gServerProof @spec @n) of
+        (Dict, Dict) ->
+            fromProduct dlN
+          where
+            dlM :: HandlerD (GToProduct (Rep (spec ModePlain))) m =
+              toProduct dl
+            dlN :: HandlerD (GToProduct (Rep (spec ModePlain))) n =
+              hoistDialogWithContext (Proxy @(GToProduct (Rep (spec ModePlain)))) pctx nat dlM
+
+
+toProduct :: (Generic (spec mode), GProduct (Rep (spec mode)))
+    => spec mode -> GToProduct (Rep (spec mode))
+toProduct = gtoProduct . Generics.from
+
+fromProduct
+    :: (Generic (spec mode), GProduct (Rep (spec mode)))
+    => GToProduct (Rep (spec mode)) -> spec mode
+fromProduct = Generics.to . gfromProduct
+
+instance
+  ( HasHandler m speca ctx
+  , HasHandler m specb ctx
+  ) =>
+  HasHandler m (GP speca specb) ctx where
+    type HandlerD (GP speca specb) m = GP (HandlerD speca m) (HandlerD specb m)
+    route _ ctx (GP speca specb) =
+            route (Proxy @speca) ctx speca
+        <>  route (Proxy @specb) ctx specb
+
+    hoistDialogWithContext _ pc nt (GP speca specb) =
+      GP
+        (hoistDialogWithContext (Proxy @speca) pc nt speca)
+        (hoistDialogWithContext (Proxy @specb) pc nt specb)
+
+data GP a b = GP a b
+
+class GProduct f where
+    type GToProduct (f :: Type -> Type)
+    gtoProduct   :: f p -> GToProduct f
+    gfromProduct :: GToProduct f -> f p
+
+instance (GProduct l, GProduct r) => GProduct (l :*: r) where
+    type GToProduct (l :*: r) = GP (GToProduct l) (GToProduct r)
+    gtoProduct   (l :*: r)  = GP (gtoProduct l) (gtoProduct r)
+    gfromProduct (GP l r) = gfromProduct l :*: gfromProduct r
+
+instance GProduct f => GProduct (M1 i c f) where
+    type GToProduct (M1 i c f) = GToProduct f
+    gtoProduct   = gtoProduct . unM1
+    gfromProduct = M1 . gfromProduct
+
+instance GProduct (K1 i c) where
+    type GToProduct (K1 i c) = c
+    gtoProduct = unK1
+    gfromProduct = K1
--- a/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs
+++ b/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs
@ -7,35 +7,20 @@ module HBS2.Net.Proto.Dialog
 , module HBS2.Net.Dialog.Client
 ) where

-import HBS2.Actors.Peer
-import HBS2.Clock
-import HBS2.Data.Types
-import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto
-import HBS2.Net.Proto.Peer
-import HBS2.Net.Proto.Sessions
-import HBS2.Prelude.Plated hiding (at)
-import HBS2.System.Logger.Simple
-
 import Codec.Serialise (deserialiseOrFail)
 import Control.Arrow
 import Control.Monad
-import Control.Monad.Error.Class
-import Control.Monad.IO.Unlift
 import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Builder
 import Data.ByteString.Lazy qualified as BSL
-import Data.List qualified as List
-import Data.Map.Strict as Map
+import Data.Generics.Product.Fields ()
+import Data.Kind
 import Lens.Micro.Platform
-import Streaming as S
-import Streaming.Prelude qualified as S
-import UnliftIO.Exception
-import UnliftIO.STM

+import HBS2.Data.Types
 import HBS2.Net.Dialog.Client
 import HBS2.Net.Dialog.Core
+import HBS2.Net.Proto
+import HBS2.Prelude.Plated hiding (at)

 ---

@ -62,7 +47,7 @@ dialRespEncode = \case

 ---

-data DialogProtoEnv m e = DialogProtoEnv
+newtype DialogProtoEnv m e = DialogProtoEnv
  { dialogProtoEnvCallerEnv :: CallerEnv m
  }

@ -76,12 +61,12 @@ newDialogProtoEnv = do

 -- Adapters should share the same env

-data DialReqProtoAdapter e (m :: * -> *) s = DialReqProtoAdapter
-  { dialReqProtoAdapterRouter :: DialogRequestRouter m
-  -- , dialReqProtoAdapterEnv :: DialogProtoEnv e
+data DialReqProtoAdapter e (m :: Type -> Type) s = DialReqProtoAdapter
+  { dialReqProtoAdapterDApp :: DApp IO
+  , dialReqProtoAdapterNT :: Peer e -> forall a . m a -> IO a
  }

-data DialRespProtoAdapter e (m :: * -> *) s = DialRespProtoAdapter
+newtype DialRespProtoAdapter e (m :: Type -> Type) s = DialRespProtoAdapter
  { dialRespProtoAdapterEnv :: DialogProtoEnv m e
  }

@ -98,19 +83,22 @@ dialReqProto :: forall e s m .
    => DialReqProtoAdapter e m s
    -> DialReq e
    -> m ()
-dialReqProto DialReqProtoAdapter{..} = unDialReq >>> \frames -> do
+dialReqProto adapter = unDialReq >>> \frames -> do
    peer <- thatPeer dialReqProtoProxy

-    let dialReqEnv :: DialogRequestEnv m (Peer e) (Maybe (PeerData e))
-        dialReqEnv = DialogRequestEnv
-          { dreqEnvPeer = peer
-          , dreqEnvGetPeerData = pure Nothing -- undefined -- find (KnownPeerKey peer) id
-          }
+    -- let dialReqEnv :: DialogRequestEnv m (Peer e) (Maybe (PeerData e))
+    --     dialReqEnv = DialogRequestEnv
+    --       { dreqEnvPeer = peer
+    --       , dreqEnvGetPeerData = pure Nothing -- undefined -- find (KnownPeerKey peer) id
+    --       }

    let replyToPeer :: Frames -> m ()
        replyToPeer = request peer . DialResp @e

-    routeDialogRequest dialReqProtoAdapterRouter dialReqEnv replyToPeer frames
+    let replyToPeerIO :: Frames -> IO ()
+        replyToPeerIO = dialReqProtoAdapterNT adapter peer <$> replyToPeer
+
+    liftIO $ (dialReqProtoAdapterDApp adapter) frames replyToPeerIO

 where
   dialReqProtoProxy = Proxy @(DialReq e)
@ -127,7 +115,7 @@ dialRespProto :: forall e s m .
    -> DialResp e
    -> m ()
 dialRespProto DialRespProtoAdapter{..} = unDialResp >>> unFrames >>> \case
-  "": xs -> do
+  "": _xs -> do
      -- Ответили прямо нам сюда. Нужно как-то отреагировать на xs
      pure ()

--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@ -57,7 +57,8 @@ import RefLog (reflogWorker)
 import HttpWorker
 import ProxyMessaging
 import PeerMain.DialogCliCommand
-import PeerMain.PeerDialog
+import PeerMain.Dialog.Server
+import PeerMain.Dialog.Spec
 import PeerMeta
 import CLI.RefChan
 import RefChan
@ -720,7 +721,7 @@ runPeer opts = Exception.handle (\e -> myException e
                    }

              -- dialReqProtoAdapter <- do
-              --     dialReqProtoAdapterRouter <- pure dialogRoutes
+              --     dialReqProtoAdapterDApp <- pure dialogRoutes
              --     pure DialReqProtoAdapter {..}

              env <- ask
@ -1205,7 +1206,17 @@ runPeer opts = Exception.handle (\e -> myException e
          }

  dialReqProtoAdapter <- do
-      dialReqProtoAdapterRouter <- pure dialogRoutes
+      let denv = DialEnv
+
+      let dialReqProtoAdapterDApp = drpcFullDApp denv penv
+
+          -- dialReqProtoAdapterNT :: ResponseM L4Proto (RpcM (ResourceT IO)) a -> IO a
+          dialReqProtoAdapterNT :: Peer e -> forall a . ResponseM L4Proto (RpcM (ResourceT IO)) a -> IO a
+          dialReqProtoAdapterNT = \peer ->
+                runResourceT
+              . runRPC udp1
+              . runResponseM peer
+
      pure DialReqProtoAdapter {..}

  rpc <- async $ runRPC udp1 do
--- a/hbs2-peer/app/PeerMain/Dialog/Server.hs
+++ b/hbs2-peer/app/PeerMain/Dialog/Server.hs
@ -0,0 +1,178 @@
+{-# LANGUAGE PolyKinds #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE UndecidableInstances #-}
+module PeerMain.Dialog.Server where
+
+import Codec.Serialise
+import Control.Monad.Except
+import Control.Monad.IO.Class ()
+import Control.Monad.Reader
+import Lens.Micro.Platform
+
+import HBS2.Actors.Peer
+import HBS2.Data.Types.Refs
+import HBS2.Hash
+import HBS2.Net.Dialog.Core
+import HBS2.Net.Proto.RefLog
+import HBS2.Net.Proto.Types
+import HBS2.Prelude
+import HBS2.Storage.Simple
+
+import PeerMain.Dialog.Spec
+
+---
+
+data DialEnv = DialEnv
+
+newtype DialT m a = DialT { unDialT :: PeerM L4Proto (ReaderT DialEnv (DialHandlerT m)) a }
+  deriving
+    ( Generic, Functor, Applicative, Monad
+    , MonadIO
+    , MonadReader (PeerEnv L4Proto)
+    -- , MonadTrans
+    -- , MonadError ResponseStatus
+    -- , MonadThrow, MonadCatch, MonadMask
+    )
+
+-- instance Monad m => MonadReader DialEnv (DialT m) where
+--     ask = DialT . lift $ ask
+--     local f ma = undefined
+
+instance Monad m => HasStorage (DialT m) where
+  getStorage = asks (view envStorage)
+
+instance MonadTrans DialT where
+  lift = DialT . lift . lift . lift
+
+instance Monad m =>
+  MonadError ResponseStatus (DialT m) where
+    -- {-# MINIMAL throwError, catchError #-}
+    -- throwError :: e -> m a
+    throwError = DialT . lift . throwError
+    -- catchError :: m a -> (e -> m a) -> m a
+    catchError = undefined
+
+---
+
+runDialTtoDialHandlerT :: MonadIO m => DialEnv -> PeerEnv L4Proto -> DialT m a -> DialHandlerT m a
+runDialTtoDialHandlerT denv penv =
+    flip runReaderT denv . withPeerM penv . unDialT
+
+---
+
+dialogRoutes' :: forall m .
+    ( MonadIO m
+    , Serialise (PubKey 'Sign (Encryption L4Proto))
+    , FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
+    , Hashable (PubKey 'Sign (Encryption L4Proto))
+    )
+    => PeerEnv L4Proto
+    -> DialogRequestRouter m
+dialogRoutes' penv = dialogRequestRoutes do
+
+    hand ["ping"] \req -> (, req) <$> Right \reply -> do
+        reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"])
+
+    hand ["spec"] \req -> (, req) <$> Right \reply -> do
+        undefined
+        -- let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m penv))
+
+        -- forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do
+        --     reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j)
+        --               , BS.intercalate "/" x
+        --               ])
+
+
+    hand ["debug", "no-response-header"] \req -> (, req) <$> Right \reply -> do
+        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"])
+        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"])
+        reply (Frames [])
+
+    hand ["debug", "wrong-header"] \req -> (, req) <$> Right \reply -> do
+        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"])
+        reply (Frames ["wrong-header"])
+
+    hand ["debug", "timeout"] \req -> (, req) <$> Right \reply -> do
+        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"])
+
+
+    handconv ["reflog", "get"] "ReflogGetReq" \(ReflogGetReq ref) -> do
+
+        sto <- withPeerM penv getStorage
+
+        hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure
+            =<< liftIO do
+                    getRef sto (RefLogKey @(Encryption L4Proto) ref)
+
+        pure (ReflogGetResp hash)
+
+newtype ReflogGetReq = ReflogGetReq (PubKey 'Sign (Encryption L4Proto))
+  deriving (Generic)
+
+instance Serialise (PubKey 'Sign (Encryption L4Proto))
+    => Serialise ReflogGetReq
+
+newtype ReflogGetResp = ReflogGetResp (Hash HbSync)
+  deriving (Generic)
+
+instance Serialise (PubKey 'Sign (Encryption L4Proto))
+    => Serialise ReflogGetResp
+
+---
+
+drpcFullDApp :: forall m .
+    ( MonadIO m
+    , Unconstraints
+    )
+    => DialEnv -> PeerEnv L4Proto -> DApp m
+drpcFullDApp denv penv =
+    mkDApp
+        (Proxy @(NamedSpec DialogRPCSpec))
+        EmptyCtx
+        (runDialTtoDialHandlerT denv penv)
+        -- (drpcFullH :: DialogRPCSpec (ModeServerT (DialT m)))
+        drpcFullH
+
+type ConstraintsH m =
+    ( MonadIO m
+    , MonadError ResponseStatus m
+    , HasStorage m
+    , Unconstraints
+    )
+
+type Unconstraints =
+    ( Serialise (PubKey 'Sign (Encryption L4Proto))
+    , Hashable (PubKey 'Sign (Encryption L4Proto))
+    , Show (PubKey 'Sign (Encryption L4Proto))
+    , Typeable (PubKey 'Sign (Encryption L4Proto))
+    , FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
+    )
+
+drpcFullH :: ( ConstraintsH m )
+    => DialogRPCSpec (ModeServerT m)
+drpcFullH = DialogRPCSpec
+  { drpcPing = pure "pong"
+  , drpcSpec = pure "tbd"
+  , drpcReflog = reflogH
+  }
+
+reflogH :: ( ConstraintsH m )
+    => RPCReflogSpec (ModeServerT m)
+reflogH = RPCReflogSpec {..}
+  where
+
+    reflogGet ref = do
+
+        sto <- getStorage
+
+        hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure
+            =<< liftIO do
+                    getRef sto (RefLogKey @(Encryption L4Proto) ref)
+
+        pure hash
+
+    reflogFetch pk = do
+        liftIO $ print pk
+        pure ()
+
--- a/hbs2-peer/app/PeerMain/Dialog/Spec.hs
+++ b/hbs2-peer/app/PeerMain/Dialog/Spec.hs
@ -0,0 +1,35 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE StrictData #-}
+
+module PeerMain.Dialog.Spec where
+
+-- import Codec.Serialise
+-- import Streaming
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+import HBS2.Hash
+import HBS2.Net.Dialog.Core
+import HBS2.Net.Proto.Types
+
+
+data DialogRPCSpec r = DialogRPCSpec
+  { drpcPing :: r &- "ping" &/ SingleRespCBOR Text
+  , drpcSpec :: r &- "spec" &/ SingleRespCBOR Text
+  , drpcReflog :: r &- "reflog" &// RPCReflogSpec
+  }
+  deriving (Generic)
+
+data RPCReflogSpec r = RPCReflogSpec
+  { reflogGet :: r &- "get"
+        &/ ReqCBOR (PubKey 'Sign (Encryption L4Proto))
+        &/ SingleRespCBOR (Hash HbSync)
+
+  , reflogFetch :: r &- "fetch"
+        &/ ReqCBOR (PubKey 'Sign (Encryption L4Proto))
+        &/ SingleAck
+
+  }
+  deriving (Generic)
+
--- a/hbs2-peer/app/PeerMain/DialogCliCommand.hs
+++ b/hbs2-peer/app/PeerMain/DialogCliCommand.hs
@ -5,6 +5,7 @@ module PeerMain.DialogCliCommand where
 import Data.Generics.Labels
 import Data.Generics.Product.Fields
 import HBS2.Actors.Peer
+import HBS2.Hash
 import HBS2.Net.IP.Addr
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Proto
@ -14,8 +15,10 @@ import HBS2.Prelude
 import HBS2.System.Logger.Simple hiding (info)

 import PeerConfig
-import RPC
+import RPC (PeerRpcKey, RpcM, runRPC)

+import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT)
+import Control.Monad.State.Strict (evalStateT)
 import Control.Monad.Trans.Cont
 import Data.Default
 import Data.Function
@ -28,19 +31,23 @@ import Lens.Micro.Platform
 import Network.Socket
 import Options.Applicative
 import Streaming.Prelude qualified as S
+import System.IO
 import UnliftIO.Async
 import UnliftIO.Concurrent
 import UnliftIO.Exception as U
 import UnliftIO.Resource

-- import System.FilePath.Posix
-import System.IO
-

 pDialog :: Parser (IO ())
 pDialog = hsubparser $ mempty
   <> command "ping" (info pPing (progDesc "ping hbs2 node via dialog inteface") )
   <> command "debug" (info pDebug (progDesc "debug call different dialog inteface routes") )
+   <> command "reflog" (info pReflog (progDesc "reflog commands") )
+
+pReflog :: Parser (IO ())
+pReflog = hsubparser $ mempty
+   <> command "get" (info pRefLogGet (progDesc "get own reflog from all" ))
+   <> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" ))

 confOpt :: Parser FilePath
 confOpt = strOption ( long "config"  <> short 'c' <> help "config" )
@ -99,6 +106,35 @@ pPing = do
            liftIO . print =<< do
                dQuery1 def cli peer (dpath "ping" [])

+reflogKeyP :: ReadM (PubKey 'Sign (Encryption L4Proto))
+reflogKeyP = eitherReader $
+    maybe (Left "invalid REFLOG-KEY") pure . fromStringMay
+
+pRefLogGet :: Parser (IO ())
+pRefLogGet = do
+    dopt <- pDialCommon
+    rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
+    pure do
+        withDial dopt \peer dclient ->
+            withClient dclient \cli -> do
+                xs <- dQuery1 def cli peer (dpath "reflog/get" [serialiseS rkey])
+
+                hash <- either (lift . lift . fail) pure $ runExcept $ flip evalStateT xs do
+                    cutFrameDecode @(Hash HbSync) do
+                        "No hash in response: " <> show xs
+
+                liftIO . print $ pretty hash
+
+pRefLogFetch :: Parser (IO ())
+pRefLogFetch = do
+    dopt <- pDialCommon
+    rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
+    pure do
+        withDial dopt \peer dclient ->
+            withClient dclient \cli -> do
+                xs <- dQuery1 def cli peer (dpath "reflog/fetch" [serialiseS rkey])
+
+                liftIO . print $ "Response: " <> show xs

 pDebug :: Parser (IO ())
 pDebug = do
--- a/hbs2-peer/app/PeerMain/PeerDialog.hs
+++ b/hbs2-peer/app/PeerMain/PeerDialog.hs
@ -1,39 +0,0 @@
-module PeerMain.PeerDialog where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Bool
-import Data.ByteString qualified as BS
-import Data.Map qualified as Map
-
-import HBS2.Net.Dialog.Core
-import HBS2.Net.Proto.Types
-
-
-dialogRoutes :: forall m . MonadIO m => DialogRequestRouter m
-dialogRoutes = dialogRequestRoutes do
-
-    hand ["ping"] \req -> Right \reply -> do
-        reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"])
-
-    hand ["spec"] \req -> Right \reply -> do
-        let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m))
-
-        forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do
-            reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j)
-                      , BS.intercalate "/" x
-                      ])
-
-
-    hand ["debug", "no-response-header"] \req -> Right \reply -> do
-        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"])
-        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"])
-        reply (Frames [])
-
-    hand ["debug", "wrong-header"] \req -> Right \reply -> do
-        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"])
-        reply (Frames ["wrong-header"])
-
-    hand ["debug", "timeout"] \req -> Right \reply -> do
-        reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"])
-
--- a/hbs2-peer/hbs2-peer.cabal
+++ b/hbs2-peer/hbs2-peer.cabal
@ -136,7 +136,8 @@ executable hbs2-peer
                    , Bootstrap
                    , PeerInfo
                    , PeerMain.DialogCliCommand
-                    , PeerMain.PeerDialog
+                    , PeerMain.Dialog.Server
+                    , PeerMain.Dialog.Spec
                    , PeerMeta
                    , RPC
                    , PeerTypes