diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000..066e659c --- /dev/null +++ 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 diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 23095e5f..cb454686 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 348666ef..a574609a 100644 --- 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) diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Client.hs b/hbs2-core/lib/HBS2/Net/Dialog/Client.hs index 21be3275..dd4d2465 100644 --- 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] <>) diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Core.hs b/hbs2-core/lib/HBS2/Net/Dialog/Core.hs index e38691eb..60aef062 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs b/hbs2-core/lib/HBS2/Net/Proto/Dialog.hs index ddaf0959..925980bb 100644 --- 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 () diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 1533bc4d..0d5b48f5 100644 --- 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 diff --git a/hbs2-peer/app/PeerMain/Dialog/Server.hs b/hbs2-peer/app/PeerMain/Dialog/Server.hs new file mode 100644 index 00000000..f7c0bb5e --- /dev/null +++ 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 () + diff --git a/hbs2-peer/app/PeerMain/Dialog/Spec.hs b/hbs2-peer/app/PeerMain/Dialog/Spec.hs new file mode 100644 index 00000000..d9dbb898 --- /dev/null +++ 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) + diff --git a/hbs2-peer/app/PeerMain/DialogCliCommand.hs b/hbs2-peer/app/PeerMain/DialogCliCommand.hs index bbfbc13f..18fd279a 100644 --- 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 diff --git a/hbs2-peer/app/PeerMain/PeerDialog.hs b/hbs2-peer/app/PeerMain/PeerDialog.hs deleted file mode 100644 index 7382bd53..00000000 --- a/hbs2-peer/app/PeerMain/PeerDialog.hs +++ /dev/null @@ -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"]) - diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 0f951bdf..626e9a9b 100644 --- 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