{-|
Module      : KMonad.Util
Description : Various bits and bobs that I don't know where to put
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

Contains code for making it slighly easier to work with time, errors, and
Acquire datatypes.

-}
module KMonad.Util
  ( -- * Time units and utils
    -- $time
    Milliseconds
  , tDiff

    -- * Random utility helpers that have no better home
  , onErr
  , using
  , logRethrow

    -- * Some helpers to launch background process
  , withLaunch
  , withLaunch_
  , launch
  , launch_
  )

where

import KMonad.Prelude

import Data.Time.Clock
import Data.Time.Clock.System

--------------------------------------------------------------------------------
-- $time
--

-- | Newtype wrapper around 'Int' to add type safety to our time values
newtype Milliseconds = Milliseconds Int
  deriving (Milliseconds -> Milliseconds -> Bool
(Milliseconds -> Milliseconds -> Bool)
-> (Milliseconds -> Milliseconds -> Bool) -> Eq Milliseconds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Milliseconds -> Milliseconds -> Bool
$c/= :: Milliseconds -> Milliseconds -> Bool
== :: Milliseconds -> Milliseconds -> Bool
$c== :: Milliseconds -> Milliseconds -> Bool
Eq, Eq Milliseconds
Eq Milliseconds =>
(Milliseconds -> Milliseconds -> Ordering)
-> (Milliseconds -> Milliseconds -> Bool)
-> (Milliseconds -> Milliseconds -> Bool)
-> (Milliseconds -> Milliseconds -> Bool)
-> (Milliseconds -> Milliseconds -> Bool)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> Ord Milliseconds
Milliseconds -> Milliseconds -> Bool
Milliseconds -> Milliseconds -> Ordering
Milliseconds -> Milliseconds -> Milliseconds
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Milliseconds -> Milliseconds -> Milliseconds
$cmin :: Milliseconds -> Milliseconds -> Milliseconds
max :: Milliseconds -> Milliseconds -> Milliseconds
$cmax :: Milliseconds -> Milliseconds -> Milliseconds
>= :: Milliseconds -> Milliseconds -> Bool
$c>= :: Milliseconds -> Milliseconds -> Bool
> :: Milliseconds -> Milliseconds -> Bool
$c> :: Milliseconds -> Milliseconds -> Bool
<= :: Milliseconds -> Milliseconds -> Bool
$c<= :: Milliseconds -> Milliseconds -> Bool
< :: Milliseconds -> Milliseconds -> Bool
$c< :: Milliseconds -> Milliseconds -> Bool
compare :: Milliseconds -> Milliseconds -> Ordering
$ccompare :: Milliseconds -> Milliseconds -> Ordering
$cp1Ord :: Eq Milliseconds
Ord, Integer -> Milliseconds
Milliseconds -> Milliseconds
Milliseconds -> Milliseconds -> Milliseconds
(Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds)
-> (Integer -> Milliseconds)
-> Num Milliseconds
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Milliseconds
$cfromInteger :: Integer -> Milliseconds
signum :: Milliseconds -> Milliseconds
$csignum :: Milliseconds -> Milliseconds
abs :: Milliseconds -> Milliseconds
$cabs :: Milliseconds -> Milliseconds
negate :: Milliseconds -> Milliseconds
$cnegate :: Milliseconds -> Milliseconds
* :: Milliseconds -> Milliseconds -> Milliseconds
$c* :: Milliseconds -> Milliseconds -> Milliseconds
- :: Milliseconds -> Milliseconds -> Milliseconds
$c- :: Milliseconds -> Milliseconds -> Milliseconds
+ :: Milliseconds -> Milliseconds -> Milliseconds
$c+ :: Milliseconds -> Milliseconds -> Milliseconds
Num, Num Milliseconds
Ord Milliseconds
(Num Milliseconds, Ord Milliseconds) =>
(Milliseconds -> Rational) -> Real Milliseconds
Milliseconds -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: Milliseconds -> Rational
$ctoRational :: Milliseconds -> Rational
$cp2Real :: Ord Milliseconds
$cp1Real :: Num Milliseconds
Real, Int -> Milliseconds
Milliseconds -> Int
Milliseconds -> [Milliseconds]
Milliseconds -> Milliseconds
Milliseconds -> Milliseconds -> [Milliseconds]
Milliseconds -> Milliseconds -> Milliseconds -> [Milliseconds]
(Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds)
-> (Int -> Milliseconds)
-> (Milliseconds -> Int)
-> (Milliseconds -> [Milliseconds])
-> (Milliseconds -> Milliseconds -> [Milliseconds])
-> (Milliseconds -> Milliseconds -> [Milliseconds])
-> (Milliseconds -> Milliseconds -> Milliseconds -> [Milliseconds])
-> Enum Milliseconds
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Milliseconds -> Milliseconds -> Milliseconds -> [Milliseconds]
$cenumFromThenTo :: Milliseconds -> Milliseconds -> Milliseconds -> [Milliseconds]
enumFromTo :: Milliseconds -> Milliseconds -> [Milliseconds]
$cenumFromTo :: Milliseconds -> Milliseconds -> [Milliseconds]
enumFromThen :: Milliseconds -> Milliseconds -> [Milliseconds]
$cenumFromThen :: Milliseconds -> Milliseconds -> [Milliseconds]
enumFrom :: Milliseconds -> [Milliseconds]
$cenumFrom :: Milliseconds -> [Milliseconds]
fromEnum :: Milliseconds -> Int
$cfromEnum :: Milliseconds -> Int
toEnum :: Int -> Milliseconds
$ctoEnum :: Int -> Milliseconds
pred :: Milliseconds -> Milliseconds
$cpred :: Milliseconds -> Milliseconds
succ :: Milliseconds -> Milliseconds
$csucc :: Milliseconds -> Milliseconds
Enum, Enum Milliseconds
Real Milliseconds
(Real Milliseconds, Enum Milliseconds) =>
(Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> Milliseconds)
-> (Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds))
-> (Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds))
-> (Milliseconds -> Integer)
-> Integral Milliseconds
Milliseconds -> Integer
Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds)
Milliseconds -> Milliseconds -> Milliseconds
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Milliseconds -> Integer
$ctoInteger :: Milliseconds -> Integer
divMod :: Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds)
$cdivMod :: Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds)
quotRem :: Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds)
$cquotRem :: Milliseconds -> Milliseconds -> (Milliseconds, Milliseconds)
mod :: Milliseconds -> Milliseconds -> Milliseconds
$cmod :: Milliseconds -> Milliseconds -> Milliseconds
div :: Milliseconds -> Milliseconds -> Milliseconds
$cdiv :: Milliseconds -> Milliseconds -> Milliseconds
rem :: Milliseconds -> Milliseconds -> Milliseconds
$crem :: Milliseconds -> Milliseconds -> Milliseconds
quot :: Milliseconds -> Milliseconds -> Milliseconds
$cquot :: Milliseconds -> Milliseconds -> Milliseconds
$cp2Integral :: Enum Milliseconds
$cp1Integral :: Real Milliseconds
Integral, Int -> Milliseconds -> ShowS
[Milliseconds] -> ShowS
Milliseconds -> String
(Int -> Milliseconds -> ShowS)
-> (Milliseconds -> String)
-> ([Milliseconds] -> ShowS)
-> Show Milliseconds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Milliseconds] -> ShowS
$cshowList :: [Milliseconds] -> ShowS
show :: Milliseconds -> String
$cshow :: Milliseconds -> String
showsPrec :: Int -> Milliseconds -> ShowS
$cshowsPrec :: Int -> Milliseconds -> ShowS
Show, ReadPrec [Milliseconds]
ReadPrec Milliseconds
Int -> ReadS Milliseconds
ReadS [Milliseconds]
(Int -> ReadS Milliseconds)
-> ReadS [Milliseconds]
-> ReadPrec Milliseconds
-> ReadPrec [Milliseconds]
-> Read Milliseconds
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Milliseconds]
$creadListPrec :: ReadPrec [Milliseconds]
readPrec :: ReadPrec Milliseconds
$creadPrec :: ReadPrec Milliseconds
readList :: ReadS [Milliseconds]
$creadList :: ReadS [Milliseconds]
readsPrec :: Int -> ReadS Milliseconds
$creadsPrec :: Int -> ReadS Milliseconds
Read, (forall x. Milliseconds -> Rep Milliseconds x)
-> (forall x. Rep Milliseconds x -> Milliseconds)
-> Generic Milliseconds
forall x. Rep Milliseconds x -> Milliseconds
forall x. Milliseconds -> Rep Milliseconds x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Milliseconds x -> Milliseconds
$cfrom :: forall x. Milliseconds -> Rep Milliseconds x
Generic, Milliseconds -> Text
Milliseconds -> Utf8Builder
(Milliseconds -> Utf8Builder)
-> (Milliseconds -> Text) -> Display Milliseconds
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: Milliseconds -> Text
$ctextDisplay :: Milliseconds -> Text
display :: Milliseconds -> Utf8Builder
$cdisplay :: Milliseconds -> Utf8Builder
Display)

-- | Calculate how much time has elapsed between 2 time points
tDiff :: ()
  => SystemTime   -- ^ The earlier timepoint
  -> SystemTime   -- ^ The later timepoint
  -> Milliseconds -- ^ The time in milliseconds between the two
tDiff :: SystemTime -> SystemTime -> Milliseconds
tDiff a :: SystemTime
a b :: SystemTime
b = let
  a' :: UTCTime
a' = SystemTime -> UTCTime
systemToUTCTime SystemTime
a
  b' :: UTCTime
b' = SystemTime -> UTCTime
systemToUTCTime SystemTime
b
  d :: NominalDiffTime
d  = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
b' UTCTime
a'
  in NominalDiffTime -> Milliseconds
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Milliseconds)
-> NominalDiffTime -> Milliseconds
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* 1000
-- tDiff (MkSystemTime s_a ns_a) (MkSystemTime s_b ns_b) = let
  -- s  = fromIntegral $ (s_b  - s_a) * 1000
  -- ns = fromIntegral $ (ns_b - ns_a) `div` 1000000
  -- in s + ns

--------------------------------------------------------------------------------
-- $util

-- | A helper function that helps to throw errors when a return code is -1.
-- Easiest when used as infix like this:
--
-- > someFFIcall `onErr` MyCallFailedError someData
--
onErr :: (MonadUnliftIO m, Exception e) => m Int -> e -> m ()
onErr :: m Int -> e -> m ()
onErr a :: m Int
a err :: e
err = m Int
a m Int -> (Int -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ret :: Int
ret -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ret Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ e -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO e
err

-- | Embed the action of using an 'Acquire' in a continuation monad
using :: Acquire a -> ContT r (RIO e) a
using :: Acquire a -> ContT r (RIO e) a
using dat :: Acquire a
dat = ((a -> RIO e r) -> RIO e r) -> ContT r (RIO e) a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> RIO e r) -> RIO e r) -> ContT r (RIO e) a)
-> ((a -> RIO e r) -> RIO e r) -> ContT r (RIO e) a
forall a b. (a -> b) -> a -> b
$ (\next :: a -> RIO e r
next -> Acquire a -> (a -> RIO e r) -> RIO e r
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with Acquire a
dat ((a -> RIO e r) -> RIO e r) -> (a -> RIO e r) -> RIO e r
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> a -> RIO e r
next a
a)


-- | Log an error message and then rethrow the error
--
-- Particularly useful as a suffix using `catch`. i.e.
--
-- > doSomething `catch` logRethrow "I caught something"
logRethrow :: HasLogFunc e
  => Text
  -> SomeException -- ^ The error to throw
  -> RIO e a
logRethrow :: Text -> SomeException -> RIO e a
logRethrow t :: Text
t e :: SomeException
e = do
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
t Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SomeException
e
  SomeException -> RIO e a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e

-- | Launch a process that repeats an action indefinitely. If an error ever
-- occurs, print it and rethrow it. Ensure the process is cleaned up upon error
-- and/or shutdown.
withLaunch :: HasLogFunc e
  => Text                   -- ^ The name of this process (for logging)
  -> RIO e a                -- ^ The action to repeat forever
  -> ((Async a) -> RIO e b) -- ^ The foreground action to run
  -> RIO e b                -- ^ The resulting action
withLaunch :: Text -> RIO e a -> (Async a -> RIO e b) -> RIO e b
withLaunch n :: Text
n a :: RIO e a
a f :: Async a -> RIO e b
f = do
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Launching process: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
n
  RIO e a -> (Async a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync
   (RIO e a -> RIO e a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever RIO e a
a
    RIO e a -> (SomeException -> RIO e a) -> RIO e a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`   Text -> SomeException -> RIO e a
forall e a. HasLogFunc e => Text -> SomeException -> RIO e a
logRethrow ("Encountered error in <" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Display a => a -> Text
textDisplay Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ">")
    RIO e a -> RIO e () -> RIO e a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo    ("Closing process: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
n))
   (\a' :: Async a
a' -> Async a -> RIO e ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async a
a' RIO e () -> RIO e b -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async a -> RIO e b
f Async a
a')

-- | Like withLaunch, but without ever needing access to the async process
withLaunch_ :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> RIO e b -- ^ The foreground action to run
  -> RIO e b -- ^ The resulting action
withLaunch_ :: Text -> RIO e a -> RIO e b -> RIO e b
withLaunch_ n :: Text
n a :: RIO e a
a f :: RIO e b
f = Text -> RIO e a -> (Async a -> RIO e b) -> RIO e b
forall e a b.
HasLogFunc e =>
Text -> RIO e a -> (Async a -> RIO e b) -> RIO e b
withLaunch Text
n RIO e a
a (RIO e b -> Async a -> RIO e b
forall a b. a -> b -> a
const RIO e b
f)

-- | Like 'withLaunch', but in the ContT monad
launch :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> ContT r (RIO e) (Async a)
launch :: Text -> RIO e a -> ContT r (RIO e) (Async a)
launch n :: Text
n = ((Async a -> RIO e r) -> RIO e r) -> ContT r (RIO e) (Async a)
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Async a -> RIO e r) -> RIO e r) -> ContT r (RIO e) (Async a))
-> (RIO e a -> (Async a -> RIO e r) -> RIO e r)
-> RIO e a
-> ContT r (RIO e) (Async a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RIO e a -> (Async a -> RIO e r) -> RIO e r
forall e a b.
HasLogFunc e =>
Text -> RIO e a -> (Async a -> RIO e b) -> RIO e b
withLaunch Text
n

-- | Like 'withLaunch_', but in the ContT monad
launch_ :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> ContT r (RIO e) ()
launch_ :: Text -> RIO e a -> ContT r (RIO e) ()
launch_ n :: Text
n a :: RIO e a
a = ((() -> RIO e r) -> RIO e r) -> ContT r (RIO e) ()
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((() -> RIO e r) -> RIO e r) -> ContT r (RIO e) ())
-> ((() -> RIO e r) -> RIO e r) -> ContT r (RIO e) ()
forall a b. (a -> b) -> a -> b
$ \next :: () -> RIO e r
next -> Text -> RIO e a -> RIO e r -> RIO e r
forall e a b. HasLogFunc e => Text -> RIO e a -> RIO e b -> RIO e b
withLaunch_ Text
n RIO e a
a (() -> RIO e r
next ())