diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +This module is under this "3 clause" BSD license: + +Copyright (c) 2025-2025, Daniil Iaitskov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse or + promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +# non-negative-time-diff changelog + +## Version 0.0.1 2026-02-26 + * init diff --git a/non-negative-time-diff.cabal b/non-negative-time-diff.cabal new file mode 100644 --- /dev/null +++ b/non-negative-time-diff.cabal @@ -0,0 +1,141 @@ +cabal-version: 3.0 +name: non-negative-time-diff +version: 0.0.1 + +synopsis: type safe diffUTCTime +description: + Both arguments of @diffUTCTime@ function from @time@ package have the + same type. It is easy to mix them. + + > f = do + > started <- getCurrentTime + > threadDelay 10_000_000 + > ended <- getCurrentTime + > pure $ started `diffUTCTime` ended + + This package provides a stricter @diffUTCTime@ that significantly + reduces possibility of mixing its arguments by an accident. + + > import Data.Time.Clock.NonNegativeTimeDiff + > f = do + > started <- getCurrentTime + > threadDelay 10_000_000 + > ended <- getTimeAfter started + > pure $ ended `diffUTCTime` started + + == STM use case + #stm-use-case# + + The STM package is shipped without a function to get current time. Let’s + consider a situtation like this: + + > data Ctx + > = Ctx { m :: Map Int UTCTime + > , s :: TVar NominalDiffTime + > , q :: TQueue Int + > } + > + > f (c :: Ctx) = do + > now <- getCurrentTime + > atomically $ do + > i <- readTQueue q + > lookup i c.m >>= \case + > Nothing -> pure () + > Just t -> modifyTVar' c.s (+ diffUTCTime now t) + + @now@ might be less than @t@ because the queue might be empty by the + time @f@ is invoked. The package API can correct the above snippet as + follows: + + > data Ctx + > = Ctx { m :: Map Int UtcBox + > , s :: TVar NominalDiffTime + > , q :: TQueue Int + > } + > + > f (c :: Ctx) = do + > atomically $ do + > i <- readTQueue q + > lookup i c.m >>= \case + > Nothing -> pure () + > Just t -> + > doAfter tb \t -> do + > now <- getTimeAfter t + > modifyTVar' c.s (+ diffUTCTime now t) + + == File access time + #file-access-time# + + Another popular usecase where original @diffUTCTime@ might be misused. + + > isFileOlderThan :: FilePath -> NominalDiffTime -> IO Bool + > isFileOlderThan fp maxAge = do + > now <- getCurrentTime + > mt <- getModificationTime fp + > when (mt `diffUTCTime` now > maxAge) $ do + > removeFile fp + + File age is always negative in the above example - this eventually would + cause a space leak on disk. + + Corrected version: + + > isFileOlderThan :: FilePath -> NominalDiffTime -> IO Bool + > isFileOlderThan fp maxAge = + > getModificationTime fp >>= (`doAfter` \mt -> do + > now <- getTimeAfter mt + > when (now `diffUTCTime` mt > maxAge) $ do + > removeFile fp) + + == Requirements + #requirements# + + Unboxing @UtcBox@ values requires a GHC + : + + > {-# GHC_OPTIONS -fplugin GHC.TypeLits.Normalise #-} +homepage: http://github.com/yaitskov/non-negative-time-diff +license: BSD-3-Clause +license-file: LICENSE +author: Daniil Iaitskov +maintainer: dyaitskov@gmail.com +copyright: Daniil Iaitkov 2026 +category: System +build-type: Simple +bug-reports: https://github.com/yaitskov/non-negative-time-diff/issues + +extra-doc-files: + changelog.md +tested-with: + GHC == 9.12.2 + +source-repository head + type: + git + location: + https://github.com/yaitskov/non-negative-time-diff.git + +common base + default-language: GHC2024 + ghc-options: -Wall -fplugin GHC.TypeLits.Normalise + default-extensions: + DefaultSignatures + NoImplicitPrelude + TypeFamilies + ViewPatterns + build-depends: + , base >=4.7 && < 5 + +library + import: base + hs-source-dirs: src + exposed-modules: + Data.Time.Clock.NonNegativeTimeDiff + build-depends: + , aeson < 3 + , deepseq < 2 + , directory < 2 + , ghc-typelits-natnormalise < 1 + , mtl < 3 + , safecopy < 1 + , time < 2 diff --git a/src/Data/Time/Clock/NonNegativeTimeDiff.hs b/src/Data/Time/Clock/NonNegativeTimeDiff.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/NonNegativeTimeDiff.hs @@ -0,0 +1,96 @@ +module Data.Time.Clock.NonNegativeTimeDiff + ( UtcBox + , UTCTime + , mkUtcBox + , ClockMonad (..) + , diffUTCTime + , doAfter + , toNominalDiffTime + , NominalDiffTime + , getModificationTime + ) where + +import Control.DeepSeq ( NFData(..) ) +import Control.Monad.Trans ( MonadIO(liftIO), MonadTrans(..) ) +import Data.Aeson ( FromJSON(parseJSON), ToJSON(toJSON) ) +import Data.Coerce ( coerce ) +import Data.Time.Clock qualified as C +import Data.SafeCopy + ( SafeCopy(putCopy, getCopy), contain, safeGet, safePut ) +import GHC.Conc ( STM, unsafeIOToSTM ) +import GHC.Generics ( Generic ) +import GHC.TypeLits ( TypeError, type (+), type (<=?), ErrorMessage(Text), Nat ) +import GHC.TypeError ( Assert ) +import Prelude +import System.Directory qualified as D + +newtype UTCTime (n :: Nat) + = UTCTime + { unUTCTime :: C.UTCTime } + deriving newtype (Show, Eq, Ord, Generic, Read, NFData) + +class Monad m => ClockMonad m where + getCurrentTime :: m (UTCTime 0) + getTimeAfter :: UTCTime n -> m (UTCTime (n + 1)) + +data UtcBox = forall n. UtcBox (UTCTime n) + +mkUtcBox :: UTCTime n -> UtcBox +mkUtcBox = UtcBox + +instance NFData UtcBox where + rnf (UtcBox u) = rnf u +instance Eq UtcBox where + (UtcBox (UTCTime a)) == (UtcBox (UTCTime b)) = a == b +instance Ord UtcBox where + (UtcBox (UTCTime a)) `compare` (UtcBox (UTCTime b)) = a `compare` b +instance Show UtcBox where + show (UtcBox (UTCTime ut)) = show ut +instance ToJSON UtcBox where + toJSON (UtcBox u) = toJSON $ unUTCTime u +instance FromJSON UtcBox where + parseJSON x = UtcBox . UTCTime <$> parseJSON x +instance SafeCopy UtcBox where + putCopy (UtcBox (UTCTime ut)) = contain $ safePut ut + getCopy= contain $ UtcBox . UTCTime <$> safeGet + +doAfter :: ClockMonad m => UtcBox -> (forall n. (UTCTime n -> m b)) -> m b +doAfter (UtcBox u) m = m u + +getModificationTime :: MonadIO m => FilePath -> m UtcBox +getModificationTime fp = UtcBox . UTCTime <$> liftIO (D.getModificationTime fp) + +instance ClockMonad IO where + getCurrentTime = UTCTime <$> liftIO C.getCurrentTime + getTimeAfter _ = UTCTime <$> liftIO C.getCurrentTime + +instance ClockMonad STM where + getCurrentTime = unsafeIOToSTM getCurrentTime + getTimeAfter x = unsafeIOToSTM (getTimeAfter x) + +instance (ClockMonad m, MonadTrans t) => ClockMonad (t m) where + getCurrentTime = lift getCurrentTime + getTimeAfter x = lift $ getTimeAfter x + + +newtype NominalDiffTime + = NominalDiffTime + { toNominalDiffTime :: C.NominalDiffTime + } deriving newtype (Show, Eq, Ord, Read, Num, Enum, Fractional, Real, RealFrac, NFData) + +diffUTCTime :: + (Assert (a + 1 <=? b) + (TypeError (Text "First argument might be less than the second"))) => + UTCTime b -> UTCTime a -> NominalDiffTime +diffUTCTime (coerce -> b) (coerce -> a) = NominalDiffTime $ b `C.diffUTCTime` a + +_testDiff :: UTCTime 2 -> UTCTime 1 -> NominalDiffTime +_testDiff a b = a `diffUTCTime` b + +_testBox :: ClockMonad m => UtcBox -> m NominalDiffTime +_testBox b = + doAfter b (\sa -> do + n <- getTimeAfter sa + m <- getTimeAfter n + pure $ n `diffUTCTime` sa + m `diffUTCTime` sa + (m `diffUTCTime` n) + )