Merge pull request #373 from input-output-hk/lehins/fixup-time-relate…

…d-instances

Fixup time related instances

cardano-binary/CHANGELOG.md

@@ -1,5 +1,15 @@
 # Changelog for `cardano-binary`
 
+## 1.7.0.0
+
+* Remove `To/FromCBOR` instances for `NominalDiffTime`, since they did rounding.  Newly
+  added functions `encodeNominalDiffTimeMicro`/`decodedNominalDiffTimeMicro` can be used
+  to recover previous behavior. Correct instances that do not perform any rounding will
+  be added in some future version, for now `decodeNominalDiffTime` and
+  `encodeNominalDiffTime` can be used.
+* Add `decodeNominalDiffTime` and `encodeNominalDiffTime`
+* Add `To/FromCBOR` for all `Fixed a`, not just `Nano` and `Pico`
+
 ## 1.6.0.0
 
 * Removed `Cardano.Binary.Annotated` and `Cardano.Binary.Drop` modules. They have been

cardano-binary/cardano-binary.cabal

@@ -1,7 +1,7 @@
 cabal-version: 2.2
 
 name:                cardano-binary
-version:             1.6.0.0
+version:             1.7.0.0
 synopsis:            Binary serialization for Cardano
 description:         This package includes the binary serialization format for Cardano
 license:             Apache-2.0

cardano-binary/src/Cardano/Binary/FromCBOR.hs

@@ -17,6 +17,8 @@ module Cardano.Binary.FromCBOR
   , decodeNullMaybe
   , decodeSeq
   , decodeListWith
+  , decodeNominalDiffTime
+  , decodeNominalDiffTimeMicro
     -- * Helper tools to build instances
   , decodeMapSkel
   , decodeCollection
@@ -39,7 +41,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Short as SBS
 import Data.ByteString.Short.Internal (ShortByteString (SBS))
-import Data.Fixed (Fixed(..), Nano, Pico)
+import Data.Fixed (Fixed(..))
 import Data.Int (Int32, Int64)
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import qualified Data.Map as M
@@ -51,7 +53,7 @@ import Data.Tagged (Tagged(..))
 import Data.Text (Text)
 import qualified Data.Text  as T
 import Data.Time.Calendar.OrdinalDate ( fromOrdinalDate )
-import Data.Time.Clock (NominalDiffTime, UTCTime(..), picosecondsToDiffTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime(..), secondsToNominalDiffTime, picosecondsToDiffTime)
 import Data.Typeable ( Typeable, typeRep, Proxy )
 import qualified Data.Vector as Vector
 import qualified Data.Vector.Generic as Vector.Generic
@@ -218,15 +220,15 @@ instance FromCBOR Rational where
       then cborError $ DecoderErrorCustom "Rational" "invalid denominator"
       else return $! n % d
 
-instance FromCBOR Nano where
+instance Typeable a => FromCBOR (Fixed a) where
   fromCBOR = MkFixed <$> fromCBOR
 
-instance FromCBOR Pico where
-  fromCBOR = MkFixed <$> fromCBOR
+decodeNominalDiffTime :: Decoder s NominalDiffTime
+decodeNominalDiffTime = secondsToNominalDiffTime <$> fromCBOR
 
 -- | For backwards compatibility we round pico precision to micro
-instance FromCBOR NominalDiffTime where
-  fromCBOR = fromRational . (% 1e6) <$> fromCBOR
+decodeNominalDiffTimeMicro :: Decoder s NominalDiffTime
+decodeNominalDiffTimeMicro = fromRational . (% 1e6) <$> fromCBOR
 
 instance FromCBOR Natural where
   fromCBOR = do

cardano-binary/src/Cardano/Binary/ToCBOR.hs

@@ -19,7 +19,8 @@ module Cardano.Binary.ToCBOR
   , toCBORMaybe
   , encodeNullMaybe
   , encodeSeq
-
+  , encodeNominalDiffTime
+  , encodeNominalDiffTimeMicro
     -- * Size of expressions
   , Range(..)
   , szEval
@@ -52,7 +53,7 @@ import qualified Data.ByteString.Short as SBS
 import Data.ByteString.Short.Internal (ShortByteString (SBS))
 import qualified Data.Primitive.ByteArray as Prim
 import qualified Data.Sequence as Seq
-import Data.Fixed (E12, Fixed(..), Nano, Pico, resolution)
+import Data.Fixed (Fixed(..), Micro)
 #if MIN_VERSION_recursion_schemes(5,2,0)
 import Data.Fix ( Fix(..) )
 #else
@@ -70,7 +71,7 @@ import qualified Data.Text as Text
 import Data.Text (Text)
 import Data.Text.Lazy.Builder (Builder)
 import Data.Time.Calendar.OrdinalDate ( toOrdinalDate )
-import Data.Time.Clock (NominalDiffTime, UTCTime(..), diffTimeToPicoseconds)
+import Data.Time.Clock (NominalDiffTime, nominalDiffTimeToSeconds, diffTimeToPicoseconds, UTCTime(..))
 import Data.Typeable ( Typeable, typeRep, TypeRep, Proxy(..) )
 import qualified Data.Vector as Vector
 import qualified Data.Vector.Generic as Vector.Generic
@@ -491,19 +492,16 @@ instance ToCBOR a => ToCBOR (Ratio a) where
   toCBOR r = E.encodeListLen 2 <> toCBOR (numerator r) <> toCBOR (denominator r)
   encodedSizeExpr size _ = 1 + size (Proxy @a) + size (Proxy @a)
 
-instance ToCBOR Nano where
-  toCBOR (MkFixed nanoseconds) = toCBOR nanoseconds
+instance Typeable a => ToCBOR (Fixed a) where
+  toCBOR (MkFixed i) = toCBOR i
 
-instance ToCBOR Pico where
-  toCBOR (MkFixed picoseconds) = toCBOR picoseconds
+encodeNominalDiffTime :: NominalDiffTime -> Encoding
+encodeNominalDiffTime = toCBOR . nominalDiffTimeToSeconds
 
--- | For backwards compatibility we round pico precision to micro
-instance ToCBOR NominalDiffTime where
-  toCBOR = toCBOR . (`div` 1e6) . toPicoseconds
-   where
-    toPicoseconds :: NominalDiffTime -> Integer
-    toPicoseconds t =
-      numerator (toRational t * toRational (resolution $ Proxy @E12))
+-- | Same as `encodeNominalDiffTime`, except with loss of precision, because it encoded as
+-- `Data.Fixed.Micro`
+encodeNominalDiffTimeMicro :: NominalDiffTime -> Encoding
+encodeNominalDiffTimeMicro = toCBOR . realToFrac @_ @Micro
 
 instance ToCBOR Natural where
   toCBOR = toCBOR . toInteger

cardano-slotting/CHANGELOG.md

@@ -1,3 +1,10 @@
+# Changelog for `cardano-slotting`
+
+## 0.1.1.0
+
+* Addition of `ToJSON`/`FromJSON` instances for `SystemStart`
+* Addition of `ToCBOR`/`FromCBOR` instances for `RelativeTime` and `SlotLength`
+
 ## 0.1.0.1
 
 * Initial release

cardano-slotting/cardano-slotting.cabal

@@ -1,7 +1,7 @@
 cabal-version: 3.0
 
 name:                cardano-slotting
-version:             0.1.0.2
+version:             0.1.1.0
 synopsis:            Key slotting types for cardano libraries
 license:             Apache-2.0
 license-files:

cardano-slotting/src/Cardano/Slotting/Time.hs

@@ -30,6 +30,7 @@ module Cardano.Slotting.Time (
 import           Cardano.Binary (FromCBOR(..), ToCBOR(..))
 import           Codec.Serialise
 import           Control.Exception (assert)
+import           Data.Aeson (FromJSON, ToJSON)
 import           Data.Fixed
 import           Data.Time
                   ( NominalDiffTime,
@@ -55,17 +56,30 @@ newtype SystemStart = SystemStart { getSystemStart :: UTCTime }
   deriving NoThunks via InspectHeap SystemStart
   deriving Show via Quiet SystemStart
   deriving newtype Serialise
-  deriving newtype (ToCBOR, FromCBOR)
+  deriving newtype (ToCBOR, FromCBOR, ToJSON, FromJSON)
 
 {-------------------------------------------------------------------------------
   Relative time
 -------------------------------------------------------------------------------}
 
 -- | 'RelativeTime' is time relative to the 'SystemStart'
+--
+-- Precision is in picoseconds
 newtype RelativeTime = RelativeTime { getRelativeTime :: NominalDiffTime }
   deriving stock   (Eq, Ord, Generic)
   deriving newtype (NoThunks)
   deriving Show via Quiet RelativeTime
+  deriving newtype (ToJSON, FromJSON)
+
+instance ToCBOR RelativeTime where
+  toCBOR = toCBOR . nominalDiffTimeToSeconds . getRelativeTime
+
+instance FromCBOR RelativeTime where
+  fromCBOR = RelativeTime . secondsToNominalDiffTime <$> fromCBOR
+
+instance Serialise RelativeTime where
+  encode = toCBOR
+  decode = fromCBOR
 
 addRelativeTime :: NominalDiffTime -> RelativeTime -> RelativeTime
 addRelativeTime delta (RelativeTime t) = RelativeTime (t + delta)
@@ -95,10 +109,22 @@ multNominalDiffTime t f =
 -------------------------------------------------------------------------------}
 
 -- | Slot length
+--
+-- Precision is in milliseconds
 newtype SlotLength = SlotLength { getSlotLength :: NominalDiffTime }
   deriving (Eq, Generic, NoThunks)
   deriving Show via Quiet SlotLength
 
+instance ToCBOR SlotLength where
+  toCBOR = toCBOR . slotLengthToMillisec
+
+instance FromCBOR SlotLength where
+  fromCBOR = slotLengthFromMillisec <$> fromCBOR
+
+instance Serialise SlotLength where
+  encode = toCBOR
+  decode = fromCBOR
+
 -- | Constructor for 'SlotLength'
 mkSlotLength :: NominalDiffTime -> SlotLength
 mkSlotLength = SlotLength
@@ -129,21 +155,3 @@ slotLengthToMillisec = conv . getSlotLength
          . (* 1000)
          . (realToFrac :: NominalDiffTime -> Pico)
 
-{-------------------------------------------------------------------------------
-  Serialisation
--------------------------------------------------------------------------------}
-
-instance Serialise RelativeTime where
-  encode = encode . toPico . getRelativeTime
-    where
-      toPico :: NominalDiffTime -> Pico
-      toPico = realToFrac
-
-  decode = (RelativeTime . fromPico) <$> decode
-    where
-      fromPico :: Pico -> NominalDiffTime
-      fromPico = realToFrac
-
-instance Serialise SlotLength where
-  encode = encode . slotLengthToMillisec
-  decode = slotLengthFromMillisec <$> decode