download fixes

.gitignore

@@ -9,3 +9,4 @@ cabal.project.local
 
 *.key
 
+.backup/

Makefile

@@ -14,7 +14,6 @@ BINS := \
   hbs2-keyman       \
   git-remote-hbs2   \
   git-hbs2          \
-  git-remote-hbs21  \
 
 ifeq ($(origin .RECIPEPREFIX), undefined)
   $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -277,6 +277,7 @@ instance ( MonadIO m
     allowed <- tryLockForPeriod peer_e msg
 
     unless allowed do
+      -- trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto
       trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto
 
     when allowed do

hbs2-core/lib/HBS2/Clock.hs

@@ -2,8 +2,10 @@
 module HBS2.Clock
   ( module HBS2.Clock
   , module System.Clock
+  , POSIXTime, getPOSIXTime, getEpoch
   )where
 
+import Data.Functor
 import Control.Concurrent (threadDelay)
 import Control.Monad.IO.Class
 import Data.Fixed
@@ -13,6 +15,8 @@ import Data.Time
 import Prettyprinter
 import System.Clock
 import Data.Time.Clock
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import Data.Word
 
 data TimeoutKind = MilliSeconds | Seconds | Minutes | NomDiffTime | TS
 
@@ -104,6 +108,9 @@ class Expires a where
   -- FIXME: dangerous!
   expiresIn _ = Nothing
 
+getEpoch :: MonadIO m => m Word64
+getEpoch = liftIO getPOSIXTime <&> floor
+
 -- | Use coarse clock timer. This timer has 1ms resolution but is much
 -- faster comparing to the ordinary one. Is used on Linux, on MacOS
 -- provides ordinary one.

hbs2-core/lib/HBS2/Merkle.hs

@@ -114,6 +114,7 @@ data MTreeEncryption
   | EncryptGroupNaClSymm1 (Hash HbSync) ByteString
   | EncryptGroupNaClSymm2 EncryptGroupNaClSymmOpts (Hash HbSync) ByteString
   deriving stock (Eq,Generic,Data,Show)
+{-# COMPLETE NullEncryption, CryptAccessKeyNaClAsymm, EncryptGroupNaClSymm #-}
 
 instance Serialise MTreeEncryption
 

hbs2-core/lib/HBS2/OrDie.hs

@@ -1,3 +1,4 @@
+{-# Language AllowAmbiguousTypes #-}
 module HBS2.OrDie
   ( module HBS2.OrDie
   ) where
@@ -7,6 +8,7 @@ import Control.Monad.IO.Class
 import System.Exit
 import Prettyprinter
 import UnliftIO
+import Control.Monad.Except
 
 class OrDie m a where
   type family OrDieResult a :: Type
@@ -39,13 +41,13 @@ class OrThrow a  where
   type family OrThrowResult a :: Type
   orThrow :: forall e m  . (MonadIO m, Exception e) =>  e -> a -> m (OrThrowResult a)
 
+
 instance OrThrow (Maybe a) where
   type instance OrThrowResult (Maybe a) = a
   orThrow e a = case a of
     Nothing -> throwIO e
     Just x  -> pure x
 
-
 instance OrThrow (Either b a) where
   type instance OrThrowResult (Either b a) = a
   orThrow e a = case a of

hbs2-core/lib/HBS2/Prelude.hs

@@ -1,3 +1,4 @@
+{-# Language FunctionalDependencies #-}
 module HBS2.Prelude
   ( module Data.String
   , module Safe
@@ -19,7 +20,7 @@ module HBS2.Prelude
   , FromByteString(..)
   , Text.Text
   , (&), (<&>), for_, for
-  , HasErrorStatus(..), ErrorStatus(..), SomeError(..)
+  , HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE
   ) where
 
 import Data.Typeable as X
@@ -47,6 +48,7 @@ import Data.Word
 import GHC.Generics
 import Data.Time.Clock (NominalDiffTime(..))
 import Codec.Serialise
+import Control.Monad.Except
 
 import UnliftIO
 import Control.Monad.IO.Unlift
@@ -113,6 +115,41 @@ class HasErrorStatus e where
 data SomeError = forall e . (Show e, HasErrorStatus e) =>
   SomeError e
 
+instance Show SomeError where
+  show (SomeError x) = show x
+
+instance HasErrorStatus SomeError where
+  getStatus (SomeError e) = getStatus e
+
+someE :: forall e . (Show e, HasErrorStatus e) => e -> SomeError
+someE = SomeError
+
+mayE :: forall e b . (Show e, HasErrorStatus e) => e -> b -> SomeError
+mayE e _ = SomeError e
+
+class WithSomeError m a b | a -> b where
+  toSomeError :: (forall e . Show e => e -> SomeError) -> m a -> ExceptT SomeError m b
+
+
+instance Monad m => WithSomeError m (Maybe a) a where
+  toSomeError f m = do
+    lift m >>= \case
+      Nothing -> throwError (f ())
+      Just v  -> pure v
+
+instance (Monad m, Show e) => WithSomeError m (Either e a) a where
+  toSomeError f m = do
+    lift m >>= \case
+      Left e  -> throwError (f e)
+      Right v -> pure v
+
+
+instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
+    withRunInIO exceptToIO = ExceptT $ try $ do
+        withRunInIO $ \runInIO ->
+            exceptToIO (runInIO . (either throwIO pure <=< runExceptT))
+
+
 asyncLinked :: MonadUnliftIO m => m a -> m (Async a)
 asyncLinked m = do
   l <- async m

hbs2-core/lib/HBS2/System/Dir.hs

@@ -44,3 +44,4 @@ expandPath = liftIO . D.canonicalizePath
 doesDirectoryExist :: MonadIO m => FilePath -> m Bool
 doesDirectoryExist = liftIO . D.doesDirectoryExist
 
+

hbs2-core/lib/HBS2/System/Logger/Simple.hs

@@ -7,7 +7,7 @@ module HBS2.System.Logger.Simple
   ( withSimpleLogger
   , trace
   , debug
-  , log
+  , writeLog
   , err
   , warn
   , notice
@@ -41,6 +41,8 @@ import Data.Map (Map)
 import Data.Map.Strict qualified as Map
 import Control.Concurrent.STM
 
+import Prettyprinter.Render.Terminal
+
 data LoggerType = LoggerStdout
                 | LoggerStderr
                 | LoggerFile FilePath
@@ -161,37 +163,40 @@ withLogger f = do
   maybeLoggerEntry <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a)
   maybe (pure ()) f maybeLoggerEntry
 
-log :: forall a s m . (MonadIO m, HasLogLevel a, ToLogStr s) => s -> m ()
-log s = liftIO $ withLogger @a $ \loggerEntry -> do
+writeLog :: forall a s m . (MonadIO m, HasLogLevel a, ToLogStr s) => s -> m ()
+writeLog s = liftIO $ withLogger @a $ \loggerEntry -> do
   loggerSets' <- readTVarIO loggerSets
   let loggerType' = view loggerType loggerEntry
       maybeLoggerSet = Map.lookup loggerType' loggerSets'
       msg = view loggerTr loggerEntry (toLogStr s)
   maybe (pure ()) (\x -> pushLogStrLn (view loggerSet x) msg) maybeLoggerSet
 
-trace :: (ToLogStr a, MonadIO m) => a -> m ()
-trace = log @TRACE
+trace :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+trace = writeLog @TRACE
 
-debug :: (ToLogStr a, MonadIO m) => a -> m ()
-debug = log @DEBUG
+debug :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+debug = writeLog @DEBUG
 
-warn :: (ToLogStr a, MonadIO m) => a -> m ()
-warn = log @WARN
+warn :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+warn = writeLog @WARN
 
-err :: (ToLogStr a, MonadIO m) => a -> m ()
-err = log @ERROR
+err :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+err = writeLog @ERROR
 
-notice :: (ToLogStr a, MonadIO m) => a -> m ()
-notice = log @NOTICE
+notice :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+notice = writeLog @NOTICE
 
-info :: (ToLogStr a, MonadIO m) => a -> m ()
-info = log @INFO
+info :: forall a m . (ToLogStr (Doc a), MonadIO m) => Doc a -> m ()
+info = writeLog @INFO
 
 -- instance {-# OVERLAPPABLE #-} Pretty a => ToLogStr a where
 --   toLogStr p = toLogStr (show (pretty p))
 
+
 instance {-# OVERLAPPABLE #-} ToLogStr (Doc ann) where
   toLogStr = toLogStr . show
 
+
 logPrefix :: LogStr -> LoggerEntry-> LoggerEntry
 logPrefix s = set loggerTr (s <>)
+

hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs

@@ -1,42 +1,59 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module HBS2.System.Logger.Simple.ANSI
-  ( trace
+  ( module HBS2.System.Logger.Simple.Class
+  , trace
   , debug
   , err
   , warn
   , notice
   , info
+  , writeLog
   , AnsiStyle
   , ToLogStr(..)
-  , INFO,NOTICE,WARN,ERROR,DEBUG,TRACE
+  -- , INFO,NOTICE,WARN,ERROR,DEBUG
   , setLogging,setLoggingOff
   , toStderr,toStdout,logPrefix,defLog
+  , SetLoggerEntry
+  , withSimpleLogger
+  , HasLogLevel(..)
   ) where
 
 import Prettyprinter.Render.Terminal
+import HBS2.System.Logger.Simple.Class
 import HBS2.System.Logger.Simple qualified as Logger
-import HBS2.System.Logger.Simple (INFO,NOTICE,WARN,ERROR,DEBUG,TRACE,setLoggingOff,setLogging,toStderr,toStdout,logPrefix,defLog)
+import HBS2.System.Logger.Simple ( setLoggingOff
+                                 , setLogging
+                                 , toStderr
+                                 , toStdout
+                                 , logPrefix
+                                 , defLog
+                                 , SetLoggerEntry
+                                 , writeLog
+                                 , withSimpleLogger
+                                 )
 import Control.Monad.IO.Class
 import Prettyprinter
 import System.Log.FastLogger
 
-trace :: MonadIO m => Doc AnsiStyle -> m ()
-trace = Logger.trace @(Doc AnsiStyle)
-
-debug :: MonadIO m => Doc AnsiStyle -> m ()
-debug = Logger.debug @(Doc AnsiStyle)
-
-warn :: MonadIO m => Doc AnsiStyle -> m ()
-warn = Logger.warn @(Doc AnsiStyle)
-
-err :: MonadIO m => Doc AnsiStyle -> m ()
-err = Logger.err @(Doc AnsiStyle)
-
-notice :: MonadIO m => Doc AnsiStyle -> m ()
-notice = Logger.notice @(Doc AnsiStyle)
-
-info :: MonadIO m => Doc AnsiStyle -> m ()
-info = Logger.info @(Doc AnsiStyle)
-
 instance ToLogStr (Doc AnsiStyle) where
   toLogStr = toLogStr . renderStrict . layoutPretty defaultLayoutOptions
+
+trace :: forall m . MonadIO m => Doc AnsiStyle -> m ()
+trace = Logger.trace @AnsiStyle
+
+debug :: forall m . MonadIO m => Doc AnsiStyle -> m ()
+debug = Logger.debug @AnsiStyle
+
+warn :: forall m. MonadIO m => Doc AnsiStyle -> m ()
+warn = Logger.warn @AnsiStyle
+
+err :: forall m . MonadIO m => Doc AnsiStyle -> m ()
+err = Logger.err @AnsiStyle
+
+notice :: forall m . MonadIO m => Doc AnsiStyle -> m ()
+notice = Logger.notice @AnsiStyle
+
+info :: MonadIO m => Doc AnsiStyle -> m ()
+info = Logger.info @AnsiStyle
+
+

hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs

@@ -37,3 +37,5 @@ instance HasLogLevel WARN where
 instance HasLogLevel NOTICE where
   type instance LogLevel NOTICE = 6
 
+
+

hbs2-core/test/TestFileLogger.hs

@@ -3,6 +3,7 @@ module TestFileLogger where
 import HBS2.System.Logger.Simple
 import System.Directory
 import Test.Tasty.HUnit
+import Prettyprinter
 
 logFile :: FilePath
 logFile = "/tmp/testFileLogger.log"
@@ -21,8 +22,8 @@ testFileLogger = do
   setLogging @DEBUG debugPrefix
   setLogging @WARN warnPrefix
 
-  debug msg1
-  warn msg2
+  debug $ pretty msg1
+  warn $ pretty msg2
 
   setLoggingOff @DEBUG
   setLoggingOff @WARN

hbs2-git/hbs2-git.cabal

@@ -17,6 +17,7 @@ common shared-properties
   ghc-options:
         -Wall
         -Wno-type-defaults
+        -fprint-potential-instances
         -- -fno-warn-unused-matches
         -- -fno-warn-unused-do-bind
         -- -Werror=missing-methods

hbs2-peer/app/BlockDownload.hs

@@ -21,7 +21,7 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
 import HBS2.Storage.Operations.Missed
-import HBS2.System.Logger.Simple
+import HBS2.Misc.PrettyStuff
 
 import PeerTypes
 import PeerInfo
@@ -635,7 +635,6 @@ blockDownloadLoop env0 = do
       let refs = withPeerM e (getKnownPeers @e <&> fmap (,60))
 
       polling (Polling 5 60) refs $ \peer -> do
-        debug $ "SOME FUCKING PEER:" <+> pretty peer
 
         -- ШАГ 1. Поллим пиров, создаём новых, если для них нет зареганой очереди
         here <- readTVarIO (_dPeerInbox state) <&> HashMap.member peer
@@ -676,16 +675,16 @@ blockDownloadLoop env0 = do
                             next (PWork todo)
 
                      PCheckPeer -> do
-                        debug $ "PEER CHECK" <+> pretty peer
+                        trace $ "PEER CHECK" <+> pretty peer
                         auth <- withPeerM e (find (KnownPeerKey peer) id <&> isJust)
 
                         when auth do
                           next PIdle
 
-                        debug "PEER FINISHING"
+                        debug $ yellow "PEER FINISHING" <+> pretty peer
 
                      PWork (DTask{..}) -> do
-                        debug $ "PEER IS WORKING"  <+> pretty peer <+> pretty _dtaskBlock
+                        trace $ "PEER IS WORKING"  <+> pretty peer <+> pretty _dtaskBlock
 
                         let (p,h) = (peer, _dtaskBlock)
 
@@ -703,7 +702,7 @@ blockDownloadLoop env0 = do
                               -- liftIO $ atomically $ modifyTVar downFail succ
                               failedDownload p h
                               atomically $ modifyTVar downFail succ
-                              debug $ "DOWNLOAD FAILED!" <+> pretty p <+> pretty h
+                              trace $ "DOWNLOAD FAILED!" <+> pretty p <+> pretty h
                               -- addDownload Nothing h
 
                             Right{} -> do
@@ -712,7 +711,7 @@ blockDownloadLoop env0 = do
                                 writeTVar  downFail 0
                                 modifyTVar downBlk succ
 
-                              debug $ "DOWNLOAD SUCCEED" <+> pretty p <+> pretty h
+                              trace $ "DOWNLOAD SUCCEED" <+> pretty p <+> pretty h
 
                         next PIdle
 
@@ -748,24 +747,26 @@ postponedLoop env0 = do
 
   pause @'Seconds 2.57
 
-  void $ liftIO $ async $ withPeerM e $ withDownload env0 do
-    q <- asks (view blockDelayTo)
-    fix \next -> do
-      w <- liftIO $ atomically $ readTQueue q
-      pause defInterBlockDelay
-      addDownload mzero w
-      -- ws <- liftIO $ atomically $ flushTQueue q
-      -- for_ (w:ws) $ addDownload mzero
-      next
+  flip runContT pure do
 
-  void $ liftIO $ withPeerM e $ withDownload env0 do
-    forever do
-      pause @'Seconds 30
-      trace "UNPOSTPONE LOOP"
-      po <- asks (view blockPostponedTo) >>= liftIO . Cache.toList
-      for_ po $ \(h, _, expired) -> do
-        when (isJust expired) do
-          unpostponeBlock h
+    void $ ContT $ withAsync $ liftIO $ withPeerM e $ withDownload env0 do
+      q <- asks (view blockDelayTo)
+      fix \next -> do
+        w <- liftIO $ atomically $ readTQueue q
+        pause defInterBlockDelay
+        addDownload mzero w
+        -- ws <- liftIO $ atomically $ flushTQueue q
+        -- for_ (w:ws) $ addDownload mzero
+        next
+
+    void $ liftIO $ withPeerM e $ withDownload env0 do
+      forever do
+        pause @'Seconds 30
+        trace "UNPOSTPONE LOOP"
+        po <- asks (view blockPostponedTo) >>= liftIO . Cache.toList
+        for_ po $ \(h, _, expired) -> do
+          when (isJust expired) do
+            unpostponeBlock h
 
 doBlockSizeRequest :: forall e m . ( MyPeer e
                                  , Sessions e (KnownPeer e) m

hbs2-peer/app/Bootstrap.hs

@@ -11,7 +11,7 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Peer.Brains
 
 import PeerConfig
-import HBS2.System.Logger.Simple
+import PeerLogger
 
 import Network.DNS
 import Control.Monad.Reader

hbs2-peer/app/Brains.hs

@@ -18,8 +18,8 @@ import HBS2.Base58
 import HBS2.Net.IP.Addr
 
 import HBS2.Peer.Brains
-import HBS2.System.Logger.Simple
 
+import PeerLogger
 import PeerConfig
 
 import Control.Concurrent.STM

hbs2-peer/app/ByPassWorker.hs

@@ -4,8 +4,6 @@ import HBS2.Prelude
 import HBS2.Clock
 import HBS2.Actors.Peer
 import HBS2.Net.Messaging.Encrypted.ByPass
-import HBS2.System.Logger.Simple
-
 
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerExchange
@@ -16,11 +14,10 @@ import PeerTypes
 
 import Control.Monad
 import UnliftIO
-
+import Control.Monad.Trans.Cont
 
 byPassWorker :: ( ForByPass e
                 , MonadUnliftIO m
-                , MonadIO m
                 , HasPeer e
                 , HasPeerLocator e m
                 , Sessions e (KnownPeer e) m
@@ -32,26 +29,21 @@ byPassWorker :: ( ForByPass e
 
 byPassWorker bp penv = do
 
-  tstat <- async $ forever do
-    stats <- getStat bp
-    info $ "ByPass stats"
-      <> line
-      <> indent 2 (pretty stats)
-      <> line
+  flip runContT pure do
 
-    pause @'Seconds 60
+    void $ ContT $ withAsync $ forever do
+      stats <- getStat bp
+      info $ "ByPass stats"
+        <> line
+        <> indent 2 (pretty stats)
+        <> line
 
-  link tstat
-
-  gc <- async $ withPeerM penv $ forever do
-          pips <- getKnownPeers
-          cleanupByPassMessaging bp pips
-          pause @'Seconds 600
-
-  link gc
-
-  void $ waitAnyCatchCancel [tstat, gc]
+      pause @'Seconds 60
 
+  forever do
+    pips <- getKnownPeers
+    cleanupByPassMessaging bp pips
+    pause @'Seconds 600
 
 
 

hbs2-peer/app/CLI/RefChan.hs

@@ -32,9 +32,7 @@ import HBS2.Peer.RefChanNotifyLog
 
 import CLI.Common
 import RPC2()
-
-import HBS2.System.Logger.Simple hiding (info)
-import HBS2.System.Logger.Simple qualified as Log
+import PeerLogger hiding (info)
 
 import Control.Monad.Cont
 import Control.Monad.Reader

hbs2-peer/app/CheckBlockAnnounce.hs

@@ -16,8 +16,6 @@ import CheckPeer (peerBanned)
 import BlockDownload
 import DownloadQ
 
-import HBS2.System.Logger.Simple
-
 import Control.Monad.Trans.Maybe
 import Control.Monad.Reader
 import Data.Set qualified as Set

hbs2-peer/app/CheckMetrics.hs

@@ -2,12 +2,10 @@ module CheckMetrics where
 
 import HBS2.Prelude.Plated
 import HBS2.Clock
-import HBS2.System.Logger.Simple
 
-import Data.Foldable
-import Data.Functor
+import PeerLogger
+
 import Control.Monad
--- import GHC.Stats
 import System.Metrics
 import Data.HashMap.Strict qualified as HashMap
 

hbs2-peer/app/DispatchProxy.hs

@@ -9,7 +9,7 @@ module DispatchProxy
 import HBS2.Prelude.Plated
 import HBS2.Net.Messaging
 
-import HBS2.System.Logger.Simple
+import PeerLogger
 
 import Control.Concurrent.STM.TQueue qualified as TQ
 import Data.ByteString.Lazy (ByteString)

hbs2-peer/app/DownloadMon.hs

@@ -3,8 +3,6 @@ module DownloadMon where
 
 import HBS2.Prelude.Plated
 
-import HBS2.System.Logger.Simple
-
 import HBS2.Actors.Peer
 import PeerTypes
 

hbs2-peer/app/DownloadQ.hs

@@ -9,7 +9,6 @@ import HBS2.Net.PeerLocator
 import HBS2.Peer.Brains
 import HBS2.Storage
 import HBS2.Storage.Operations.Missed
-import HBS2.System.Logger.Simple
 
 import PeerTypes
 import PeerConfig

hbs2-peer/app/EncryptionKeys.hs

@@ -17,7 +17,6 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
 import HBS2.Net.Proto.Definition()
-import HBS2.System.Logger.Simple
 
 import PeerConfig
 import PeerTypes

hbs2-peer/app/Fetch.hs

@@ -6,8 +6,6 @@ import HBS2.Data.Types.Refs
 import HBS2.Storage.Operations.Missed
 import HBS2.Net.Proto.Types
 
-import HBS2.System.Logger.Simple
-
 import PeerTypes
 import BlockDownload
 

hbs2-peer/app/HttpWorker.hs

@@ -11,8 +11,6 @@ import HBS2.Net.Proto.Types
 import HBS2.Net.Proto.RefLog
 import HBS2.Events
 
-import HBS2.System.Logger.Simple
-
 import PeerTypes
 import PeerConfig
 import RefLog ( doRefLogBroadCast )

hbs2-peer/app/Log.hs

@@ -1,6 +1,8 @@
-module Log where
+module Log (module Log, module PeerLogger) where
 
-import HBS2.System.Logger.Simple
+import PeerLogger
+
+-- import HBS2.System.Logger.Simple (SetLoggerEntry)
 
 tracePrefix :: SetLoggerEntry
 tracePrefix  = logPrefix "[trace] "

hbs2-peer/app/PeerConfig.hs

@@ -13,12 +13,13 @@ import HBS2.Base58
 import HBS2.Net.Proto.Types
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition()
-import HBS2.System.Logger.Simple
 
 import Data.Config.Suckless.Syntax
 import Data.Config.Suckless.Parse
 import Data.Config.Suckless.KeyValue
 
+import PeerLogger
+
 import Control.Exception
 import Control.Monad.Reader
 import Data.Maybe

hbs2-peer/app/PeerInfo.hs

@@ -14,7 +14,6 @@ import HBS2.Net.Proto.PeerExchange
 import HBS2.Net.Proto.Sessions
 import HBS2.Net.Proto.Types
 import HBS2.Prelude.Plated
-import HBS2.System.Logger.Simple
 
 import HBS2.Net.Messaging.TCP
 
@@ -22,8 +21,8 @@ import PeerConfig
 import PeerTypes
 import Brains
 
-import Control.Concurrent.Async
-import Control.Concurrent.STM
+-- import Control.Concurrent.Async
+import Control.Concurrent.STM qualified as STM
 import Control.Monad
 import Control.Monad.Reader
 import Data.Foldable hiding (find)
@@ -33,6 +32,11 @@ import Lens.Micro.Platform
 import Numeric (showGFloat)
 import System.Random.Shuffle
 import Data.HashMap.Strict qualified as HashMap
+import Data.Either
+import Control.Monad.Trans.Cont
+import Control.Exception qualified as E
+
+import UnliftIO
 
 
 data PeerPingIntervalKey
@@ -80,11 +84,11 @@ pexLoop :: forall e brains m . ( HasPeerLocator e m
                                , HasNonces (PeerExchange e) m
                                , Request e (PeerExchange e) m
                                , Sessions e (PeerExchange e) m
-                               , MonadIO m
+                               , MonadUnliftIO m
                                , e ~ L4Proto
                                ) => brains -> Maybe MessagingTCP -> m ()
 
-pexLoop brains tcpEnv = do
+pexLoop brains tcpEnv = forever do
 
   pause @'Seconds 5
 
@@ -94,44 +98,50 @@ pexLoop brains tcpEnv = do
   --  Есть подозрения, что TCP сессии не чистятся
   --  надлежащим образом. Требуется расследовать.
 
-  -- NOTE: tcpPexInfo
-  --   Этот кусок говорит Brains о том,
-  --   какие TCP сессии есть в наличии.
-  --   Убирать пока нельзя
-  tcpPexInfo <- liftIO $ async $ forever do
-    -- FIXME: fix-hardcode
-    pause @'Seconds 20
+  flip runContT pure do
 
-    pips <- knownPeers @e pl
-    onKnownPeers brains pips
+    -- NOTE: tcpPexInfo
+    --   Этот кусок говорит Brains о том,
+    --   какие TCP сессии есть в наличии.
+    --   Убирать пока нельзя
+    void $ ContT $ withAsync $ forever do
+      -- FIXME: fix-hardcode
+      pause @'Seconds 20
 
-    conns <- maybe1 (view tcpPeerConn <$> tcpEnv) (pure mempty)  $ \tconn -> do
-               liftIO $ readTVarIO tconn <&> HashMap.toList
+      pips <- knownPeers @e pl
+      onKnownPeers brains pips
 
-    ssids <- forM conns $ \(p,coo) -> do
-                debug $ "ACTUAL TCP SESSIONS" <+> pretty p <+> pretty coo
-                pa <- toPeerAddr p
-                pure (pa, coo)
+      conns <- maybe1 (view tcpPeerConn <$> tcpEnv) (pure mempty)  $ \tconn -> do
+                 try @_ @SomeException $ readTVarIO tconn <&> HashMap.toList
+                 >>= either (const $ warn "tcpSessionWait issue" >> pause @'Seconds 1 >> pure mempty) pure
 
-    setActiveTCPSessions @e brains ssids
+      ssids <- forM conns $ \(p,coo) -> do
+                  debug $ "ACTUAL TCP SESSIONS" <+> pretty p <+> pretty coo
+                  pa <- toPeerAddr p
+                  pure (pa, coo)
 
-    pure ()
+      setActiveTCPSessions @e brains ssids
 
-  liftIO $ mapM_ link [tcpPexInfo]
+      pure ()
 
-  forever do
+    void $ ContT $ withAsync $ forever do
 
-    pips <- knownPeers @e pl
+      pips <- knownPeers @e pl
 
-    peers' <- forM pips $ \p -> do
-                au <- find @e (KnownPeerKey p) id
-                pure $ maybe1 au mempty (const [p])
+      peers' <- forM pips $ \p -> do
+                  au <- find @e (KnownPeerKey p) id
+                  pure $ maybe1 au mempty (const [p])
 
-    peers <- liftIO (shuffleM (mconcat peers')) <&> take 10 -- FIXME: defaults
+      peers <- liftIO (shuffleM (mconcat peers')) <&> take 10 -- FIXME: defaults
 
-    for_ peers sendPeerExchangeGet
+      for_ peers sendPeerExchangeGet
 
-    pause @'Seconds 180  -- FIXME: defaults
+      pause @'Seconds 180  -- FIXME: defaults
+
+    forever do
+      pips <- knownPeers @e pl
+      onKnownPeers brains pips
+      pause @'Seconds 60
 
 peerPingLoop :: forall e m . ( HasPeerLocator e m
                              , HasPeer e
@@ -170,81 +180,83 @@ peerPingLoop (PeerConfig syn) penv = do
   --   liftIO $ atomically $ writeTQueue wake [p]
 
 
-  -- TODO: peer info loop
-  infoLoop <- liftIO $ async $ forever $ withPeerM e $ do
-    pause @'Seconds 10
-    pee <- knownPeers @e pl
+  flip runContT pure do
 
-    npi <- newPeerInfo
+    -- TODO: peer info loop
+    void $ ContT $ withAsync $ forever $ withPeerM e $ do
+      pause @'Seconds 10
+      pee <- knownPeers @e pl
 
-    now <- getTimeCoarse
+      npi <- newPeerInfo
 
-    debug $ "known peers" <+> pretty pee
+      now <- getTimeCoarse
 
-    for_ pee $ \p -> do
-      pinfo <- fetch True npi (PeerInfoKey p) id
-      burst  <- liftIO $ readTVarIO (view peerBurst pinfo)
-      buM    <- liftIO $ readTVarIO (view peerBurstMax pinfo)
-      errors <- liftIO $ readTVarIO (view peerErrorsPerSec pinfo)
-      downFails <- liftIO $ readTVarIO (view peerDownloadFail pinfo)
-      downMiss  <- liftIO $ readTVarIO (view peerDownloadMiss pinfo)
-      down      <- liftIO $ readTVarIO (view peerDownloadedBlk pinfo)
-      rtt       <- liftIO $ medianPeerRTT pinfo <&> fmap realToFrac
-      httpDownloaded <- liftIO $ readTVarIO (_peerHttpDownloaded pinfo)
-      seen      <- liftIO $ readTVarIO (view peerLastWatched pinfo)
-      let l = realToFrac (toNanoSecs $ now - seen) / 1e9
+      debug $ "known peers" <+> pretty pee
 
-      let rttMs = (/1e6) <$> rtt <&> (\x -> showGFloat (Just 2) x "") <&> (<> "ms")
-      let ls = showGFloat (Just 2) l "" <> "s"
+      for_ pee $ \p -> do
+        pinfo <- fetch True npi (PeerInfoKey p) id
+        burst  <- liftIO $ readTVarIO (view peerBurst pinfo)
+        buM    <- liftIO $ readTVarIO (view peerBurstMax pinfo)
+        errors <- liftIO $ readTVarIO (view peerErrorsPerSec pinfo)
+        downFails <- liftIO $ readTVarIO (view peerDownloadFail pinfo)
+        downMiss  <- liftIO $ readTVarIO (view peerDownloadMiss pinfo)
+        down      <- liftIO $ readTVarIO (view peerDownloadedBlk pinfo)
+        rtt       <- liftIO $ medianPeerRTT pinfo <&> fmap realToFrac
+        httpDownloaded <- liftIO $ readTVarIO (_peerHttpDownloaded pinfo)
+        seen      <- liftIO $ readTVarIO (view peerLastWatched pinfo)
+        let l = realToFrac (toNanoSecs $ now - seen) / 1e9
 
-      notice $ "peer" <+> pretty p <+> "burst:" <+> pretty burst
-                                   <+> "burst-max:" <+> pretty buM
-                                   <+> "errors:" <+> pretty (downFails + errors)
-                                   <+> "down:" <+> pretty down
-                                   <+> "miss:" <+> pretty downMiss
-                                   <+> "rtt:" <+> pretty rttMs
-                                   <+> "http:" <+> pretty httpDownloaded
-                                   <+> "seen" <+> pretty ls
-      pure ()
+        let rttMs = (/1e6) <$> rtt <&> (\x -> showGFloat (Just 2) x "") <&> (<> "ms")
+        let ls = showGFloat (Just 2) l "" <> "s"
+
+        notice $ "peer" <+> pretty p <+> "burst:" <+> pretty burst
+                                     <+> "burst-max:" <+> pretty buM
+                                     <+> "errors:" <+> pretty (downFails + errors)
+                                     <+> "down:" <+> pretty down
+                                     <+> "miss:" <+> pretty downMiss
+                                     <+> "rtt:" <+> pretty rttMs
+                                     <+> "http:" <+> pretty httpDownloaded
+                                     <+> "seen" <+> pretty ls
+        pure ()
 
 
-  watch <- liftIO $ async $ forever $ withPeerM e $ do
-             pause @'Seconds 120
-             pips <- getKnownPeers @e
-             now <- getTimeCoarse
-             for_ pips $ \p -> do
-               pinfo' <- find (PeerInfoKey p) id
-               maybe1 pinfo' none $ \pinfo -> do
-                seen <- liftIO $ readTVarIO (view peerLastWatched pinfo)
-                -- FIXME: do-something-with-this-nanosec-boilerplate-everywhere
-                let l = realToFrac (toNanoSecs $ now - seen) / 1e9
-                -- FIXME: time-hardcode
-                when ( l > 300 ) do
-                  mpeerData <- find (KnownPeerKey p) id
-                  delPeers pl [p]
-                  expire (PeerInfoKey p)
-                  expire (KnownPeerKey p)
-                  emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-})
+    void $ ContT $ withAsync $ liftIO $ forever $ withPeerM e $ do
+               pause @'Seconds 120
+               pips <- getKnownPeers @e
+               now <- getTimeCoarse
+               for_ pips $ \p -> do
+                 pinfo' <- find (PeerInfoKey p) id
+                 maybe1 pinfo' none $ \pinfo -> do
+                  seen <- liftIO $ readTVarIO (view peerLastWatched pinfo)
+                  -- FIXME: do-something-with-this-nanosec-boilerplate-everywhere
+                  let l = realToFrac (toNanoSecs $ now - seen) / 1e9
+                  -- FIXME: time-hardcode
+                  when ( l > 300 ) do
+                    mpeerData <- find (KnownPeerKey p) id
+                    delPeers pl [p]
+                    expire (PeerInfoKey p)
+                    expire (KnownPeerKey p)
+                    emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-})
 
-  liftIO $ mapM_ link [watch, infoLoop]
 
-  forever do
+    forever do
 
-    -- FIXME: defaults
-    r <- liftIO $ race (pause @'Seconds pingTime)
-                       (atomically $ readTQueue wake)
+      -- FIXME: defaults
+      r <- liftIO $ race (pause @'Seconds pingTime)
+                         (atomically $ readTQueue wake)
 
-    sas' <- liftIO $ atomically $ flushTQueue wake <&> mconcat
+      sas' <- liftIO $ atomically $ STM.flushTQueue wake <&> mconcat
 
-    let sas = case r of
-          Left{}   -> sas'
-          Right sa -> sa <> sas'
+      let sas = case r of
+            Left{}   -> sas'
+            Right sa -> sa <> sas'
 
-    debug "peerPingLoop"
+      debug "peerPingLoop"
 
-    pips <- knownPeers @e pl <&> (<> sas) <&> List.nub
+      pips <- knownPeers @e pl <&> (<> sas) <&> List.nub
+
+      for_ pips $ \p -> do
+        -- trace $ "SEND PING TO" <+> pretty p
+        lift $ sendPing @e p
+        -- trace $ "SENT PING TO" <+> pretty p
 
-    for_ pips $ \p -> do
-      -- trace $ "SEND PING TO" <+> pretty p
-      sendPing @e p
-      -- trace $ "SENT PING TO" <+> pretty p

hbs2-peer/app/PeerLogger.hs

@@ -0,0 +1,15 @@
+module PeerLogger
+  ( module Logger
+  , trace1, TRACE1
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.System.Logger.Simple.ANSI as Logger
+
+data TRACE1
+
+instance HasLogLevel TRACE1 where
+  type instance LogLevel TRACE1 = 101
+
+trace1 :: forall a m . (MonadIO m, ToLogStr a) => a -> m ()
+trace1 = Logger.writeLog @TRACE1

hbs2-peer/app/PeerMain.hs

@@ -38,14 +38,13 @@ import HBS2.Storage.Simple
 import HBS2.Storage.Operations.Missed
 import HBS2.Data.Detect
 
-import HBS2.System.Logger.Simple hiding (info)
 import HBS2.Version
 import Paths_hbs2_peer qualified as Pkg
 
 import Brains
 import BrainyPeerLocator
 import ByPassWorker
-import PeerTypes
+import PeerTypes hiding (info)
 import BlockDownload
 import CheckBlockAnnounce (checkBlockAnnounce)
 import CheckPeer (peerBanned)
@@ -64,8 +63,9 @@ import CLI.RefChan
 import RefChan
 import RefChanNotifyLog
 import Fetch (fetchHash)
-import Log
+import Log hiding (info)
 
+import HBS2.Misc.PrettyStuff
 import HBS2.Peer.RPC.Internal.Types()
 import HBS2.Peer.RPC.Internal.Storage()
 
@@ -540,8 +540,7 @@ runCLI = do
     hashP = maybeReader fromStringMay
 
 myException :: SomeException -> IO ()
-myException e = err ( show e )
-
+myException e = err ( viaShow e )
 
 newtype CredentialsM e s m a =
   CredentialsM { fromCredentials :: ReaderT (PeerCredentials s) m a }
@@ -995,16 +994,15 @@ runPeer opts = Exception.handle (\e -> myException e
                 debug "sending first peer announce"
                 request localMulticast (PeerAnnounce @e pnonce)
 
-              let peerThread t mx = W.tell . L.singleton =<< (liftIO . async) do
-                    withPeerM env mx
-                      `U.withException` \e -> case fromException e of
-                        Just (_ :: AsyncCancelled) -> pure ()
-                        Nothing -> do
-                          err ("peerThread" <+> viaShow t <+> "Failed with" <+> viaShow e)
+              let peerThread t mx = ContT $ withAsync $ liftIO $
+                                      withPeerM env mx
+                                       `U.withException` \e -> case fromException e of
+                                          Just (_ :: AsyncCancelled) -> pure ()
+                                          Nothing -> do
+                                            err $ red "Exception" <+> "in thread" <+> pretty t <+> viaShow e
+                                            liftIO $ throwTo myself GoAgainException
 
-                    debug $ "peerThread Finished:" <+> t
-
-              workers <- W.execWriterT do
+              flip runContT pure do
 
                 peerThread "local multicast" $ forever $ do
                   pause defPeerAnnounceTime -- FIXME: setting!
@@ -1039,7 +1037,7 @@ runPeer opts = Exception.handle (\e -> myException e
 
                 peerThread "refChanNotifyLogWorker" (refChanNotifyLogWorker @e conf (SomeBrains brains))
 
-                peerThread "all protos" do
+                liftIO $ withPeerM penv do
                   runProto @e
                     [ makeResponse (blockSizeProto blk (downloadOnBlockSize denv) onNoBlock)
                     , makeResponse (blockChunksProto adapter)
@@ -1055,8 +1053,6 @@ runPeer opts = Exception.handle (\e -> myException e
                     , makeResponse (refChanNotifyProto False refChanAdapter)
                     ]
 
-              void $ liftIO $ waitAnyCancel workers
-              liftIO $ throwTo myself GoAgainException
 
   let refChanHeadPostAction href = do
         void $ liftIO $ withPeerM penv $ do

hbs2-peer/app/PeerMeta.hs

@@ -13,7 +13,6 @@ import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerMeta
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
-import HBS2.System.Logger.Simple
 
 import PeerTypes
 

hbs2-peer/app/PeerTypes.hs

@@ -5,6 +5,7 @@
 {-# Language MultiWayIf #-}
 module PeerTypes
   ( module PeerTypes
+  , module PeerLogger
   , module HBS2.Net.PeerLocator
   , module HBS2.Polling
   ) where
@@ -30,11 +31,10 @@ import HBS2.Storage
 import HBS2.Storage.Operations.Missed
 import HBS2.Net.PeerLocator
 import HBS2.Net.Proto.PeerMeta
-import HBS2.System.Logger.Simple
 
--- import PeerInfo
 import Brains
 import PeerConfig
+import PeerLogger
 
 import Prelude hiding (log)
 import Control.Monad.Reader
@@ -541,12 +541,5 @@ simpleBlockAnnounce size h = do
     let annInfo = BlockAnnounceInfo 0 NoBlockInfoMeta size h
     pure $ BlockAnnounce @e no annInfo
 
-data TRACE1
-
-instance HasLogLevel TRACE1 where
-  type instance LogLevel TRACE1 = 101
-
-trace1 :: (MonadIO m, ToLogStr a) => a -> m ()
-trace1 = log @TRACE1
 
 

hbs2-peer/app/RPC2/Announce.hs

@@ -6,13 +6,13 @@ import HBS2.Prelude.Plated
 import HBS2.Data.Types.Refs (HashRef(..))
 import HBS2.Net.Proto.Service
 
-import HBS2.System.Logger.Simple
-
 import SendBlockAnnounce
 
 import HBS2.Peer.RPC.Internal.Types
 import HBS2.Peer.RPC.API.Peer
 
+import PeerLogger
+
 
 instance (MonadIO m,HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcAnnounce where
 

hbs2-peer/app/RPC2/Downloads.hs

@@ -5,12 +5,13 @@ module RPC2.Downloads where
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto.Service
 import HBS2.Peer.Brains
-import HBS2.System.Logger.Simple
 import HBS2.Net.Proto.Definition()
 
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.Internal.Types
 
+import PeerLogger
+
 instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcDownloadList where
 
   handleMethod _ = do

hbs2-peer/app/RPC2/Fetch.hs

@@ -5,11 +5,11 @@ module RPC2.Fetch where
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto.Service
 
-import HBS2.System.Logger.Simple
-
 import HBS2.Peer.RPC.Internal.Types
 import HBS2.Peer.RPC.API.Peer
 
+import PeerLogger
+
 instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcFetch where
 
   handleMethod href = do

hbs2-peer/app/RPC2/LogLevel.hs

@@ -8,7 +8,6 @@ import Log
 
 import HBS2.Peer.RPC.API.Peer
 
-import HBS2.System.Logger.Simple
 
 instance (MonadIO m) => HandleMethod m RpcLogLevel where
 

hbs2-peer/app/RPC2/Ping.hs

@@ -6,8 +6,6 @@ import HBS2.Prelude.Plated
 import HBS2.Actors.Peer
 import HBS2.Net.Proto.Service
 
-import HBS2.System.Logger.Simple
-
 import HBS2.Peer.RPC.Internal.Types
 
 import PeerTypes

hbs2-peer/app/RPC2/Poke.hs

@@ -5,11 +5,10 @@ module RPC2.Poke where
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto.Service
 
-import HBS2.System.Logger.Simple
-
 import HBS2.Peer.RPC.Internal.Types
 import HBS2.Peer.RPC.API.Peer
 
+import PeerLogger
 
 instance ( MonadIO m
          , HasRpcContext PeerAPI RPC2Context m)

hbs2-peer/app/RPC2/Poll.hs

@@ -5,12 +5,13 @@ module RPC2.Poll where
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto.Service
 import HBS2.Peer.Brains
-import HBS2.System.Logger.Simple
 import HBS2.Net.Proto.Definition()
 
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.Internal.Types
 
+import PeerLogger
+
 instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollList where
 
   handleMethod _ = do

hbs2-peer/app/RPC2/RefChan.hs

@@ -19,7 +19,6 @@ import HBS2.Storage
 import HBS2.Peer.RPC.API.RefChan
 import HBS2.Peer.RPC.Internal.Types
 
-import HBS2.System.Logger.Simple
 import PeerTypes
 
 import Data.Functor

hbs2-peer/app/RPC2/RefLog.hs

@@ -18,7 +18,6 @@ import HBS2.Net.Proto.Service
 import HBS2.Storage
 import HBS2.Net.Messaging.Unix
 
-import HBS2.System.Logger.Simple
 import PeerTypes
 import RefLog (doRefLogBroadCast)
 

hbs2-peer/app/RefChan.hs

@@ -36,8 +36,6 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Storage
 import HBS2.Storage.Operations.Missed
 
-import HBS2.System.Logger.Simple
-
 import PeerTypes hiding (downloads)
 import PeerConfig
 import BlockDownload
@@ -513,6 +511,8 @@ runRefChanRelyWorker env adapter = liftIO $ forever do
     runResponseM me $ do
       refChanNotifyProto True adapter mess
 
+{- HLINT ignore "Functor law" -}
+
 refChanWorker :: forall e s m . ( MonadIO m
                                 , MonadUnliftIO m
                                 , MyPeer e

hbs2-peer/app/RefChanNotifyLog.hs

@@ -22,8 +22,6 @@ import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.RefChan
 import HBS2.Net.Proto.Sessions
 
-import HBS2.System.Logger.Simple
-
 import HBS2.Peer.RefChanNotifyLog
 
 import PeerTypes hiding (downloads)

hbs2-peer/app/RefLog.hs

@@ -20,8 +20,6 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Net.Auth.Credentials
 import HBS2.Merkle
 
-import HBS2.System.Logger.Simple
-
 import Brains
 import PeerConfig
 import PeerTypes
@@ -95,6 +93,8 @@ data RefLogWorkerAdapter e =
  , reflogUpdated  :: (RefLogKey (Encryption e), Hash HbSync) -> IO ()
  }
 
+{- HLINT ignore "Functor law" -}
+
 reflogWorker :: forall e s m . ( e ~ L4Proto
                                , MonadIO m, MyPeer e
                                , EventListener e (RefLogUpdateEv e) m
@@ -164,10 +164,6 @@ reflogWorker conf brains adapter = do
   reflogMon <- liftIO $ newTVarIO (mempty :: HashSet (Hash HbSync))
 
   subscribe @e RefLogReqAnswerKey $ \(RefLogReqAnswerData reflog h) -> do
-    -- TODO: ASAP-only-process-link-if-we-subscribed
-    -- TODO: ASAP-start-only-one-instance-for-link-monitor
-    -- TODO: ASAP-dont-do-if-already-done
-
     -- TODO: use-download-mon
     here <- liftIO $ readTVarIO reflogMon <&> HashSet.member h
     unless here do

hbs2-peer/app/SendBlockAnnounce.hs

@@ -9,8 +9,6 @@ import HBS2.Net.Proto.BlockAnnounce
 
 import PeerTypes
 
-import HBS2.System.Logger.Simple
-
 sendBlockAnnounce :: forall e m . (e ~ L4Proto, MonadIO m)
                   => PeerEnv e
                   -> Peer e

hbs2-peer/hbs2-peer.cabal

@@ -152,6 +152,7 @@ library
       HBS2.Peer.CLI.Detect
 
     other-modules:
+      -- HBS2.System.Logger.Simple
 
 executable hbs2-peer
     import:           shared-properties
@@ -190,6 +191,7 @@ executable hbs2-peer
                     , RPC2.RefLog
                     , RPC2.RefChan
                     , PeerTypes
+                    , PeerLogger
                     , PeerConfig
                     , RefLog
                     , RefChan

hbs2-share/hbs2-share.cabal

@@ -99,7 +99,7 @@ library
 
     -- other-modules:
     -- other-extensions:
-    build-depends:    base
+    build-depends:    base, hbs2-peer
     hs-source-dirs:   src
 
 executable hbs2-share
@@ -108,7 +108,7 @@ executable hbs2-share
     -- other-modules:
     -- other-extensions:
     build-depends:
-        base, hbs2-share
+        base, hbs2-share, hbs2-peer
         , optparse-applicative
 
     hs-source-dirs:   app

hbs2-share/src/HBS2/Share/App.hs

@@ -44,7 +44,7 @@ import HBS2.Share.Keys
 import HBS2.Share.MetaData
 import HBS2.Share.LocalHash
 
-import HBS2.System.Logger.Simple
+import HBS2.System.Logger.Simple.ANSI
 import DBPipe.SQLite
 
 import Control.Applicative

nix/peer/flake.lock

@@ -295,16 +295,16 @@
         "suckless-conf": "suckless-conf_2"
       },
       "locked": {
-        "lastModified": 1707747161,
-        "narHash": "sha256-eVTLMpxXUeto7Socc02vQg5sc59O64KQUpkOKcFF7IY=",
-        "ref": "new-git-export-3",
-        "rev": "e17ca1578e6843c0edd4bee8ae976475cff867b9",
-        "revCount": 1096,
+        "lastModified": 1708329902,
+        "narHash": "sha256-DrXP90f4etkB+AyqnHXNfdB3fE8Eg4f4uEcDbk5ppQI=",
+        "ref": "newest-hbs2-git",
+        "rev": "f1ded0ae7d580a00f23574cc11c2ba6793857b0c",
+        "revCount": 1046,
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       },
       "original": {
-        "ref": "new-git-export-3",
+        "ref": "newest-hbs2-git",
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       }

nix/peer/flake.nix

@@ -6,7 +6,7 @@
   inputs = {
     extra-container.url = "github:erikarvstedt/extra-container";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
-    hbs2.url = "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=new-git-export-3";
+    hbs2.url = "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=newest-hbs2-git";
     hbs2.inputs.nixpkgs.follows = "nixpkgs";
 
     home-manager.url = "github:nix-community/home-manager";