From 5b052e8a5643b4a058f3fe35564aad59dea2986f Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sat, 15 Jul 2023 17:39:20 +0300
Subject: [PATCH] wip, minor refactoring

---
 hbs2-core/hbs2-core.cabal   |  1 +
 hbs2-core/lib/HBS2/Clock.hs | 25 ++++++++++++++++++++++---
 hbs2-peer/app/PeerTypes.hs  |  8 ++++----
 3 files changed, 27 insertions(+), 7 deletions(-)

diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal
index 2a8bdddb..afa2cd07 100644
--- a/hbs2-core/hbs2-core.cabal
+++ b/hbs2-core/hbs2-core.cabal
@@ -134,6 +134,7 @@ library
                     , microlens-platform
                     , mtl
                     , murmur-hash
+                    , time
                     , network
                     , network-multicast
                     , network-simple
diff --git a/hbs2-core/lib/HBS2/Clock.hs b/hbs2-core/lib/HBS2/Clock.hs
index c9947d24..a00c11af 100644
--- a/hbs2-core/lib/HBS2/Clock.hs
+++ b/hbs2-core/lib/HBS2/Clock.hs
@@ -1,4 +1,3 @@
-{-# Language FunctionalDependencies #-}
 {-# LANGUAGE CPP #-}
 module HBS2.Clock
   ( module HBS2.Clock
@@ -12,8 +11,9 @@ import Data.Int (Int64)
 import Data.Proxy
 import Prettyprinter
 import System.Clock
+import Data.Time.Clock
 
-data TimeoutKind = MilliSeconds | Seconds | Minutes
+data TimeoutKind = MilliSeconds | Seconds | Minutes | NomDiffTime | TS
 
 data family Timeout ( a :: TimeoutKind )
 
@@ -25,7 +25,6 @@ newtype Delay a = Delay a
                   deriving newtype (Eq,Show,Pretty)
 
 
-
 class IsTimeout a where
   toNanoSeconds :: Timeout a -> Int64
 
@@ -56,6 +55,20 @@ newtype instance Timeout 'Minutes =
   TimeoutMin (Fixed E9)
   deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
 
+newtype instance Timeout 'NomDiffTime =
+  TimeoutNDT NominalDiffTime
+  deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
+
+newtype instance Timeout 'TS =
+  TimeoutTS TimeSpec
+  deriving newtype (Eq,Ord,Num,Real,Show,Pretty)
+
+instance Pretty NominalDiffTime where
+  pretty = viaShow
+
+instance Pretty TimeSpec where
+  pretty = viaShow
+
 instance IsTimeout 'MilliSeconds where
   toNanoSeconds (TimeoutMSec x) = round (x * 1e6)
 
@@ -65,6 +78,12 @@ instance IsTimeout 'Seconds where
 instance IsTimeout 'Minutes where
   toNanoSeconds (TimeoutMin x) = round (x * 60 * 1e9)
 
+instance IsTimeout 'NomDiffTime where
+  toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * 1e9)
+
+instance IsTimeout 'TS where
+  toNanoSeconds (TimeoutTS s) = fromIntegral $ toNanoSecs s
+
 class Expires a where
   expiresIn :: Proxy a -> Maybe (Timeout 'Seconds)
 
diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs
index 55e84f0b..fa37718d 100644
--- a/hbs2-peer/app/PeerTypes.hs
+++ b/hbs2-peer/app/PeerTypes.hs
@@ -417,7 +417,7 @@ polling :: forall a m . (MonadIO m, Hashable a)
 
 polling o listEntries action = do
 
-  pause (TimeoutSec (nominalDiffTimeToSeconds (waitBefore o)))
+  pause (TimeoutNDT (waitBefore o))
 
   now0 <- getTimeCoarse
   refs0 <- listEntries <&> fmap (set _2 now0) <&> HashMap.fromList
@@ -426,7 +426,7 @@ polling o listEntries action = do
     now <- getTimeCoarse
     refs <- listEntries <&> HashMap.fromList
     let mon' = mon `HashMap.union`
-                 HashMap.fromList [ (e, now + fromNanoSecs (round (realToFrac (nominalDiffTimeToSeconds t) * 1e9)))
+                 HashMap.fromList [ (e, now + toTimeSpec (TimeoutNDT t))
                                   | (e, t) <- HashMap.toList refs
                                   ]
 
@@ -440,11 +440,11 @@ polling o listEntries action = do
         next (HashMap.delete r mon')
 
       Just (Entry t _, _) | otherwise -> do
-        pause @'Seconds $ fromInteger $ round $ realToFrac (toNanoSecs (t - now)) / 1e9
+        pause (TimeoutTS (t - now))
         next mon'
 
       Nothing -> do
-        pause (TimeoutSec (nominalDiffTimeToSeconds (waitOnEmpty o)))
+        pause (TimeoutNDT (waitOnEmpty o))
         next mon'
 
     ) refs0