streamly-0.11.0: src/Streamly/Internal/Data/Stream/Time.hs
-- |
-- Module : Streamly.Internal.Data.Stream.Time
-- Copyright : (c) 2020 Composewell Technologies
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
module Streamly.Internal.Data.Stream.Time
(
-- * Imports for Examples
-- $setup
-- * Timers
periodic -- XXX Should go to Streamly.Data.Stream
, ticks -- XXX Should go to Streamly.Data.Stream
, ticksRate
, interject
-- * Trimming
, takeInterval
, takeLastInterval
, dropInterval
, dropLastInterval
-- * Chunking
, intervalsOf
, boundedIntervalsOf
, timedGroupsOf
, timedChunksOf
, timedChunksOf'
-- * Sampling
, sampleIntervalEnd
, sampleIntervalStart
, sampleBurst
, sampleBurstEnd
, sampleBurstStart
-- * Windowed Sessions
, classifySessionsByGeneric
, classifySessionsBy
, classifySessionsOf
, classifyKeepAliveSessions
-- XXX This should go in the concurrent module
-- * Buffering
-- | Evaluate strictly using a buffer of results. When the buffer becomes
-- full we can block, drop the new elements, drop the oldest element and
-- insert the new at the end.
, bufferLatest
, bufferLatestN
, bufferOldestN
-- * Deprecated
, groupsOfTimeout
)
where
import Control.Concurrent (threadDelay)
import Control.Exception (assert)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Heap (Entry(..))
import Data.Kind (Type)
import Data.Map (Map)
import Data.Maybe (isNothing)
import Data.Proxy (Proxy(..))
import Streamly.Data.Fold (Fold)
import Streamly.Data.Array (Unbox)
import Streamly.Internal.Data.Array (Array)
import Streamly.Internal.Data.Fold (Fold (..))
import Streamly.Internal.Data.IsMap (IsMap(..))
import Streamly.Internal.Data.Channel.Types (Rate)
import Streamly.Internal.Data.Stream (Stream)
import Streamly.Internal.Data.Stream.Channel.Type (rate)
import Streamly.Internal.Data.Time.Units
( AbsTime
, MilliSecond64(..)
, addToAbsTime
, toAbsTime
, toRelTime
)
import Streamly.Internal.Data.Time.Units (NanoSecond64(..), toRelTime64)
import qualified Data.Heap as H
import qualified Streamly.Internal.Data.Array as Array
import qualified Streamly.Data.Fold as Fold
import qualified Streamly.Data.Scanl as Scanl
import qualified Streamly.Data.Stream as Stream
import qualified Streamly.Data.Unfold as Unfold
import qualified Streamly.Internal.Data.Fold as Fold (Step(..))
import qualified Streamly.Internal.Data.IsMap as IsMap
import qualified Streamly.Internal.Data.Stream as Stream
( scanlMAfter'
, timeIndexed
, timestamped
)
import Streamly.Internal.Data.Stream.Concurrent
-- $setup
--
-- Imports for example snippets in this module.
--
-- >>> :m
-- >>> import Control.Concurrent (threadDelay)
-- >>> import qualified Streamly.Data.Array as Array
-- >>> import qualified Streamly.Data.Fold as Fold
-- >>> import qualified Streamly.Data.Parser as Parser
-- >>> import qualified Streamly.Data.Stream as Stream
-- >>> import qualified Streamly.Data.Stream.Prelude as Stream
-- >>> import qualified Streamly.Internal.Data.Stream as Stream (delayPost, timestamped)
-- >>> import qualified Streamly.Internal.Data.Stream.Concurrent as Stream (parListEagerFst)
-- >>> import qualified Streamly.Internal.Data.Stream.Time as Stream
-- >>> import Prelude hiding (concatMap, concat)
-- >>> :{
-- delay n = do
-- threadDelay (n * 1000000) -- sleep for n seconds
-- putStrLn (show n ++ " sec") -- print "n sec"
-- return n -- IO Int
-- :}
--------------------------------------------------------------------------------
-- Combinators
--------------------------------------------------------------------------------
-- | Generate a stream by running an action periodically at the specified time
-- interval.
--
{-# INLINE periodic #-}
periodic :: MonadIO m => m a -> Double -> Stream m a
periodic action n = Stream.repeatM timed
where
timed = liftIO (threadDelay (round $ n * 1000000)) >> action
-- | Generate a tick stream consisting of '()' elements, each tick is generated
-- after the specified time delay given in seconds.
--
-- >>> ticks = Stream.periodic (return ())
--
{-# INLINE ticks #-}
ticks :: MonadIO m => Double -> Stream m ()
ticks = periodic (return ())
-- | Generate a tick stream, ticks are generated at the specified 'Rate'. The
-- rate is adaptive, the tick generation speed can be increased or decreased at
-- different times to achieve the specified rate. The specific behavior for
-- different styles of 'Rate' specifications is documented under 'Rate'. The
-- effective maximum rate achieved by a stream is governed by the processor
-- speed.
--
-- >>> tickStream = Stream.repeatM (return ())
-- >>> ticksRate r = Stream.parBuffered (Stream.rate (Just r)) tickStream
--
{-# INLINE ticksRate #-}
ticksRate :: MonadAsync m => Rate -> Stream m ()
ticksRate r = parBuffered (rate (Just r)) $ Stream.repeatM (return ())
-- XXX The case when the interval is 0, we should run only the stream being
-- interjected.
-- | Intersperse a monadic action into the input stream after every @n@
-- seconds.
--
-- Definition:
--
-- >>> interject n f xs = Stream.parListEagerFst [xs, Stream.periodic f n]
--
-- Example:
--
-- >>> s = Stream.fromList "hello"
-- >>> input = Stream.mapM (\x -> threadDelay 1000000 >> putChar x) s
-- >>> Stream.fold Fold.drain $ Stream.interject (putChar ',') 1.05 input
-- h,e,l,l,o
--
{-# INLINE interject #-}
interject :: MonadAsync m => m a -> Double -> Stream m a -> Stream m a
interject f n xs = parListEagerFst [xs, periodic f n]
-- XXX No element should be yielded if the duration is zero.
-- | @takeInterval interval@ runs the stream only upto the specified time
-- @interval@ in seconds.
--
-- The interval starts when the stream is evaluated for the first time.
--
{-# INLINE takeInterval #-}
takeInterval :: MonadAsync m => Double -> Stream m a -> Stream m a
takeInterval d =
Stream.catMaybes
. Stream.takeWhile isNothing
. interject (return Nothing) d . fmap Just
-- | Take time interval @i@ seconds at the end of the stream.
--
-- O(n) space, where n is the number elements taken.
--
-- /Unimplemented/
{-# INLINE takeLastInterval #-}
takeLastInterval :: -- MonadAsync m =>
Double -> Stream m a -> Stream m a
takeLastInterval = undefined
-- XXX All elements should be yielded if the duration is zero.
-- | @dropInterval interval@ drops all the stream elements that are generated
-- before the specified @interval@ in seconds has passed.
--
-- The interval begins when the stream is evaluated for the first time.
--
{-# INLINE dropInterval #-}
dropInterval :: MonadAsync m => Double -> Stream m a -> Stream m a
dropInterval d =
Stream.catMaybes
. Stream.dropWhile isNothing
. interject (return Nothing) d . fmap Just
-- | Drop time interval @i@ seconds at the end of the stream.
--
-- O(n) space, where n is the number elements dropped.
--
-- /Unimplemented/
{-# INLINE dropLastInterval #-}
dropLastInterval :: -- MonadAsync m =>
Int -> Stream m a -> Stream m a
dropLastInterval = undefined
-- | Group the input stream into windows of @n@ second each and then fold each
-- group using the provided fold function.
--
-- If the fold terminates before the interval is over, the next collection is
-- started, thus multiple collection can happen in the same interval. If the
-- fold does not terminate before the interval is over, the fold will be forced
-- to terminate at the interval end.
--
-- Example:
--
-- >>> twoPerSec = Stream.parBuffered (Stream.constRate 2) $ Stream.enumerateFrom 1
-- >>> intervals = Stream.intervalsOf 1 Fold.toList twoPerSec
-- >>> Stream.fold Fold.toList $ Stream.take 2 intervals
-- [...,...]
--
{-# INLINE intervalsOf #-}
intervalsOf :: MonadAsync m => Double -> Fold m a b -> Stream m a -> Stream m b
intervalsOf n f xs =
Stream.foldMany
(Fold.takeEndBy isNothing (Fold.catMaybes f))
(interject (return Nothing) n (fmap Just xs))
-- | Like 'intervalsOf' but with an additional argument to limit the number of
-- collected items to a max limit. If the limit is reached, the fold output is
-- emitted and the next interval is started.
--
-- An alternative behavior would be to emit multiple elements in the same
-- interval if the size is exceeded, keeping the intervals fixed. That can be
-- achieved by using 'intervalsOf' and using a fold that terminates on the
-- limit.
--
-- /Unimplemented/
{-# INLINE boundedIntervalsOf #-}
boundedIntervalsOf :: -- MonadAsync m =>
Int -> Double -> Int -> Fold m a b -> Stream m a -> Stream m b
boundedIntervalsOf _len _time _f _xs = undefined
-- XXX This can be implemented more efficiently by sharing a Clock.Timer across
-- parallel threads and resetting it whenever a span is emitted.
-- | Like 'groupsOf' but if the group is not completed within the specified
-- time interval then emit whatever we have collected till now. The group
-- timeout is reset whenever a group is emitted. The granularity of the clock
-- is 100 ms.
--
-- Note that it will not emit any output unless at least one item has been
-- collected in the group. The time interval is only for timing out the already
-- collected but not yet complete group.
--
-- >>> s = Stream.delayPost 0.3 $ Stream.fromList [1..1000]
-- >>> f = Stream.fold (Fold.drainMapM print) $ Stream.timedGroupsOf 1 5 Fold.toList s
--
-- /Pre-release/
{-# INLINE timedGroupsOf #-}
timedGroupsOf :: MonadAsync m
=> Double -> Int -> Fold m a b -> Stream m a -> Stream m b
timedGroupsOf timeout n f =
fmap snd
. classifySessionsBy
0.1 False (const (return False)) timeout (Fold.take n f)
. Stream.timestamped
. fmap ((),)
{-# Deprecated groupsOfTimeout "Please use timedGroupsOf instead." #-}
{-# INLINE groupsOfTimeout #-}
groupsOfTimeout :: MonadAsync m
=> Int -> Double -> Fold m a b -> Stream m a -> Stream m b
groupsOfTimeout n timeout = timedGroupsOf timeout n
-- Ideally this should be in an array module, but we do not have one in
-- streamly package.
-- | Like 'chunksOf' from the Array module but emits the chunk after the
-- timeout even if we have not yet collected the requested size.
{-# INLINE timedChunksOf #-}
timedChunksOf :: (MonadAsync m, Unbox a) =>
Double -> Int -> Stream m a -> Stream m (Array a)
timedChunksOf timeout n = timedGroupsOf timeout n (Array.unsafeCreateOf n)
-- | Like 'timedChunksOf' but creates pinned arrays. If the chunks are smaller
-- than LARGE_OBJECT_THRESHOLD then this routine may be useful for better
-- performance if the arrays are to be sent for IO. This will avoid a copy for
-- pinning by the IO routines.
{-# INLINE timedChunksOf' #-}
timedChunksOf' :: (MonadAsync m, Unbox a) =>
Double -> Int -> Stream m a -> Stream m (Array a)
timedChunksOf' timeout n =
timedGroupsOf timeout n (Array.unsafeCreateOf' n)
------------------------------------------------------------------------------
-- Windowed classification
------------------------------------------------------------------------------
-- TODO: To mark the position in space or time we can have Indexed or
-- TimeStamped types. That can make it easy to deal with the position indices
-- or timestamps.
------------------------------------------------------------------------------
-- Keyed Sliding Windows
------------------------------------------------------------------------------
{-
{-# INLINABLE classifySlidingChunks #-}
classifySlidingChunks
:: (IsStream t, MonadAsync m, Ord k)
=> Int -- ^ window size
-> Int -- ^ window slide
-> Fold m a b -- ^ Fold to be applied to window events
-> t m (k, a, Bool) -- ^ window key, data, close event
-> t m (k, b)
classifySlidingChunks wsize wslide (Fold step initial extract) str
= undefined
-- XXX Another variant could be to slide the window on an event, e.g. in TCP we
-- slide the send window when an ack is received and we slide the receive
-- window when a sequence is complete. Sliding is stateful in case of TCP,
-- sliding releases the send buffer or makes data available to the user from
-- the receive buffer.
{-# INLINABLE classifySlidingSessions #-}
classifySlidingSessions
:: (IsStream t, MonadAsync m, Ord k)
=> Double -- ^ timer tick in seconds
-> Double -- ^ time window size
-> Double -- ^ window slide
-> Fold m a b -- ^ Fold to be applied to window events
-> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp
-> t m (k, b)
classifySlidingSessions tick interval slide (Fold step initial extract) str
= undefined
-}
------------------------------------------------------------------------------
-- Sliding Window Buffers
------------------------------------------------------------------------------
-- These buffered versions could be faster than concurrent incremental folds of
-- all overlapping windows as in many cases we may not need all the values to
-- compute the fold, we can just compute the result using the old value and new
-- value. However, we may need the buffer once in a while, for example for
-- string search we usually compute the hash incrementally but when the hash
-- matches the hash of the pattern we need to compare the whole string.
--
-- XXX we should be able to implement sequence based splitting combinators
-- using this combinator.
{-
-- | Buffer n elements of the input in a ring buffer. When t new elements are
-- collected, slide the window to remove the same number of oldest elements,
-- insert the new elements, and apply an incremental fold on the sliding
-- window, supplying the outgoing elements, the new ring buffer as arguments.
slidingChunkBuffer
:: (IsStream t, Monad m, Ord a, Unboxed a)
=> Int -- window size
-> Int -- window slide
-> Fold m (RingArray a, Array a) b
-> t m a
-> t m b
slidingChunkBuffer = undefined
-- Buffer n seconds worth of stream elements of the input in a radix tree.
-- Every t seconds, remove the items that are older than n seconds, and apply
-- an incremental fold on the sliding window, supplying the outgoing elements,
-- and the new radix tree buffer as arguments.
slidingSessionBuffer
:: (IsStream t, Monad m, Ord a, Unboxed a)
=> Int -- window size
-> Int -- tick size
-> Fold m (RTree a, Array a) b
-> t m a
-> t m b
slidingSessionBuffer = undefined
-}
------------------------------------------------------------------------------
-- Keyed Session Windows
------------------------------------------------------------------------------
{-
-- | Keyed variable size space windows. Close the window if we do not receive a
-- window event in the next "spaceout" elements.
{-# INLINABLE classifyChunksBy #-}
classifyChunksBy
:: (IsStream t, MonadAsync m, Ord k)
=> Int -- ^ window spaceout (spread)
-> Bool -- ^ reset the spaceout when a chunk window element is received
-> Fold m a b -- ^ Fold to be applied to chunk window elements
-> t m (k, a, Bool) -- ^ chunk key, data, last element
-> t m (k, b)
classifyChunksBy spanout reset (Fold step initial extract) str = undefined
-- | Like 'classifyChunksOf' but the chunk size is reset if an element is
-- received within the chunk size window. The chunk gets closed only if no
-- element is received within the chunk window.
--
{-# INLINABLE classifyKeepAliveChunks #-}
classifyKeepAliveChunks
:: (IsStream t, MonadAsync m, Ord k)
=> Int -- ^ window spaceout (spread)
-> Fold m a b -- ^ Fold to be applied to chunk window elements
-> t m (k, a, Bool) -- ^ chunk key, data, last element
-> t m (k, b)
classifyKeepAliveChunks spanout = classifyChunksBy spanout True
-}
data SessionState t m f s b = SessionState
{ sessionCurTime :: !AbsTime -- ^ time since last event
, sessionEventTime :: !AbsTime -- ^ time as per last event
-- We can use the Map size instead of maintaining a count, but if we have
-- to switch to HashMap then it can be useful.
, sessionCount :: !Int -- ^ total number of sessions in progress
, sessionTimerHeap :: H.Heap (H.Entry AbsTime (Key f)) -- ^ heap for timeouts
, sessionKeyValueMap :: f s -- ^ Stored sessions for keys
, sessionOutputStream :: t (m :: Type -> Type) (Key f, b) -- ^ Completed sessions
}
data SessionEntry s = LiveSession !AbsTime !s | ZombieSession
-- delete from map and output the fold accumulator
ejectEntry :: (Monad m, IsMap f) =>
(acc -> m b)
-> heap
-> f entry
-> Stream m (Key f, b)
-> Int
-> acc
-> Key f
-> m (heap, f entry, Stream m (Key f, b), Int)
ejectEntry extract hp mp out cnt acc key = do
sess <- extract acc
let out1 = Stream.cons (key, sess) out
let mp1 = IsMap.mapDelete key mp
return (hp, mp1, out1, cnt - 1)
{-# NOINLINE flush #-}
flush :: (Monad m, IsMap f) =>
(s -> m b)
-> SessionState Stream m f (SessionEntry s) b
-> m (SessionState Stream m f (SessionEntry s) b)
flush extract session@SessionState{..} = do
(hp', mp', out, count) <-
ejectAll
( sessionTimerHeap
, sessionKeyValueMap
, Stream.nil
, sessionCount
)
return $ session
{ sessionCount = count
, sessionTimerHeap = hp'
, sessionKeyValueMap = mp'
, sessionOutputStream = out
}
where
ejectAll (hp, mp, out, !cnt) = do
let hres = H.uncons hp
case hres of
Just (Entry _ key, hp1) -> do
r <- case IsMap.mapLookup key mp of
Nothing -> return (hp1, mp, out, cnt)
Just ZombieSession ->
return (hp1, IsMap.mapDelete key mp, out, cnt)
Just (LiveSession _ acc) ->
ejectEntry extract hp1 mp out cnt acc key
ejectAll r
Nothing -> do
assert (IsMap.mapNull mp) (return ())
return (hp, mp, out, cnt)
{-# NOINLINE ejectOne #-}
ejectOne :: (IsMap f, Monad m) =>
Bool
-> (acc -> m b)
-> ( H.Heap (Entry AbsTime (Key f))
, f (SessionEntry acc)
, Stream m (Key f, b)
, Int
)
-> m ( H.Heap (Entry AbsTime (Key f))
, f (SessionEntry acc)
, Stream m (Key f, b), Int
)
ejectOne reset extract = go
where
go (hp, mp, out, !cnt) = do
let hres = H.uncons hp
case hres of
Just (Entry expiry key, hp1) ->
case IsMap.mapLookup key mp of
Nothing -> go (hp1, mp, out, cnt)
Just ZombieSession ->
go (hp1, IsMap.mapDelete key mp, out, cnt)
Just (LiveSession expiry1 acc) -> do
if not reset || expiry1 <= expiry
then ejectEntry extract hp1 mp out cnt acc key
else
-- reset the session timeout and continue
let hp2 = H.insert (Entry expiry1 key) hp1
in go (hp2, mp, out, cnt)
Nothing -> do
assert (IsMap.mapNull mp) (return ())
return (hp, mp, out, cnt)
{-# NOINLINE ejectExpired #-}
ejectExpired :: (IsMap f, Monad m) =>
Bool
-> (Int -> m Bool)
-> (acc -> m b)
-> SessionState Stream m f (SessionEntry acc) b
-> AbsTime
-> m (SessionState Stream m f (SessionEntry acc) b)
ejectExpired reset ejectPred extract session@SessionState{..} curTime = do
(hp', mp', out, count) <-
ejectLoop
sessionTimerHeap sessionKeyValueMap Stream.nil sessionCount
return $ session
{ sessionCurTime = curTime
, sessionCount = count
, sessionTimerHeap = hp'
, sessionKeyValueMap = mp'
, sessionOutputStream = out
}
where
ejectLoop hp mp out !cnt = do
let hres = H.uncons hp
case hres of
Just (Entry expiry key, hp1) -> do
(eject, force) <-
if curTime >= expiry
then return (True, False)
else do
r <- ejectPred cnt
return (r, r)
if eject
then
case IsMap.mapLookup key mp of
Nothing -> ejectLoop hp1 mp out cnt
Just ZombieSession ->
ejectLoop hp1 (IsMap.mapDelete key mp) out cnt
Just (LiveSession expiry1 acc) -> do
if expiry1 <= curTime || not reset || force
then do
(hp2,mp1,out1,cnt1) <-
ejectEntry extract hp1 mp out cnt acc key
ejectLoop hp2 mp1 out1 cnt1
else
-- reset the session timeout and continue
let hp2 = H.insert (Entry expiry1 key) hp1
in ejectLoop hp2 mp out cnt
else return (hp, mp, out, cnt)
Nothing -> do
assert (IsMap.mapNull mp) (return ())
return (hp, mp, out, cnt)
-- XXX Use mutable IORef in accumulator
{-# INLINE classifySessionsByGeneric #-}
classifySessionsByGeneric
:: forall m f a b. (MonadAsync m, IsMap f)
=> Proxy (f :: (Type -> Type))
-> Double -- ^ timer tick in seconds
-> Bool -- ^ reset the timer when an event is received
-> (Int -> m Bool) -- ^ predicate to eject sessions based on session count
-> Double -- ^ session timeout in seconds
-> Fold m a b -- ^ Fold to be applied to session data
-> Stream m (AbsTime, (Key f, a)) -- ^ timestamp, (session key, session
-- data)
-> Stream m (Key f, b) -- ^ session key, fold result
classifySessionsByGeneric _ tick reset ejectPred tmout
(Fold step initial extract final) input =
Stream.unfoldEach (Unfold.lmap sessionOutputStream Unfold.fromStream)
$ Stream.scanlMAfter' sstep (return szero) (flush final)
$ interject (return Nothing) tick
$ fmap Just input
where
timeoutMs = toRelTime (round (tmout * 1000) :: MilliSecond64)
tickMs = toRelTime (round (tick * 1000) :: MilliSecond64)
szero = SessionState
{ sessionCurTime = toAbsTime (0 :: MilliSecond64)
, sessionEventTime = toAbsTime (0 :: MilliSecond64)
, sessionCount = 0
, sessionTimerHeap = H.empty
, sessionKeyValueMap = IsMap.mapEmpty :: f s
, sessionOutputStream = Stream.nil
}
-- We can eject sessions based on the current session count to limit
-- memory consumption. There are two possible strategies:
--
-- 1) Eject old sessions or sessions beyond a certain/lower timeout
-- threshold even before timeout, effectively reduce the timeout.
-- 2) Drop creation of new sessions but keep accepting new events for the
-- old ones.
--
-- We use the first strategy as of now.
-- Got a new stream input element
sstep session@SessionState{..} (Just (timestamp, (key, value))) = do
-- XXX instead of a heap we could use a timer wheel.
--
-- XXX if the key is an Int, we can also use an IntMap for slightly
-- better performance.
--
-- How it works:
--
-- Values for each key are collected in a map using the supplied fold.
-- When we insert a key in the Map we insert an entry into the heap as
-- well with the session expiry as the sort key. The Map entry
-- consists of the fold result, and the expiry time of the session. If
-- "reset" is True the expiry time is readjusted whenever a new event
-- is processed. If the fold terminates and a new session is started
-- for the same key the expiry time is set to the first timestamp of
-- the new session.
--
-- The heap must have at most one entry for any given key. The heap is
-- processed periodically to remove the expired entries. We pick up an
-- expired entry from the top of the heap and if the session has
-- expired based on the expiry time in the Map entry then we remove the
-- session from the Map and yield its fold output. Otherwise, we
-- reinsert the entry into the heap based on the current expiry in the
-- Map entry.
--
-- If an entry is removed from the Map and not removed from the heap
-- and in the meantime it is inserted again in the Map (using the same
-- key) then how do we avoid inserting multiple entries in the heap?
-- For this reason we maintain the invariant that the Map entry is
-- removed only when the heap entry is removed. Even if the fold has
-- finished we still keep a dummy Map entry (ZombieSession) until the
-- heap entry is removed. That way if we have a Map entry we do not
-- insert a heap entry because we know it is already there.
-- XXX The ZombieSession mechanism does not work as expected as we
-- ignore ZombieSession when inserting a new entry. Anyway, we can
-- remove this mechanism as at most only two heap entries may be
-- created and they will be ultimately cleaned up.
--
-- Heap processing needs the map and map processing needs the heap,
-- therefore we cannot separate the two for modularity unless we have a
-- way to achieve mutual recursion.
--
let curTime = max sessionEventTime timestamp
mOld = IsMap.mapLookup key sessionKeyValueMap
let done fb = do
-- deleting a key from the heap is expensive, so we never
-- delete a key from heap, we just purge it from the Map and it
-- gets purged from the heap on timeout. We just need an extra
-- lookup in the Map when the key is purged from the heap, that
-- should not be expensive.
--
let (mp, cnt) = case mOld of
Just (LiveSession _ _) ->
( IsMap.mapInsert
key ZombieSession sessionKeyValueMap
, sessionCount - 1
)
_ -> (sessionKeyValueMap, sessionCount)
return $ session
{ sessionCurTime = curTime
, sessionEventTime = curTime
, sessionCount = cnt
, sessionKeyValueMap = mp
, sessionOutputStream = Stream.fromPure (key, fb)
}
partial fs1 = do
let expiry = addToAbsTime timestamp timeoutMs
(hp1, mp1, out1, cnt1) <- do
let vars = (sessionTimerHeap, sessionKeyValueMap,
Stream.nil, sessionCount)
case mOld of
-- inserting new entry
Nothing -> do
-- Eject a session from heap and map if needed
eject <- ejectPred sessionCount
(hp, mp, out, cnt) <-
if eject
then ejectOne reset extract vars
else return vars
-- Insert the new session in heap
let hp' = H.insert (Entry expiry key) hp
in return (hp', mp, out, cnt + 1)
-- updating old entry
Just _ -> return vars
let acc = LiveSession expiry fs1
mp2 = IsMap.mapInsert key acc mp1
return $ SessionState
{ sessionCurTime = curTime
, sessionEventTime = curTime
, sessionCount = cnt1
, sessionTimerHeap = hp1
, sessionKeyValueMap = mp2
, sessionOutputStream = out1
}
res0 <- do
case mOld of
Just (LiveSession _ acc) -> return $ Fold.Partial acc
_ -> initial
case res0 of
Fold.Done _ ->
error $ "classifySessionsBy: "
++ "The supplied fold must consume at least one input"
Fold.Partial fs -> do
res <- step fs value
case res of
Fold.Done fb -> done fb
Fold.Partial fs1 -> partial fs1
-- Got a timer tick event
sstep sessionState@SessionState{..} Nothing =
let curTime = addToAbsTime sessionCurTime tickMs
in ejectExpired reset ejectPred extract sessionState curTime
-- | @classifySessionsBy tick keepalive predicate timeout fold stream@
-- classifies an input event @stream@ consisting of @(timestamp, (key,
-- value))@ into sessions based on the @key@, folding all the values
-- corresponding to the same key into a session using the supplied @fold@.
--
-- When the fold terminates or a @timeout@ occurs, a tuple consisting of the
-- session key and the folded value is emitted in the output stream. The
-- timeout is measured from the first event in the session. If the @keepalive@
-- option is set to 'True' the timeout is reset to 0 whenever an event is
-- received.
--
-- The @timestamp@ in the input stream is an absolute time from some epoch,
-- characterizing the time when the input event was generated. The notion of
-- current time is maintained by a monotonic event time clock using the
-- timestamps seen in the input stream. The latest timestamp seen till now is
-- used as the base for the current time. When no new events are seen, a timer
-- is started with a clock resolution of @tick@ seconds. This timer is used to
-- detect session timeouts in the absence of new events.
--
-- To ensure an upper bound on the memory used the number of sessions can be
-- limited to an upper bound. If the ejection @predicate@ returns 'True', the
-- oldest session is ejected before inserting a new session.
--
-- When the stream ends any buffered sessions are ejected immediately.
--
-- If a session key is received even after a session has finished, another
-- session is created for that key.
--
-- >>> :{
-- Stream.fold (Fold.drainMapM print)
-- $ Stream.classifySessionsBy 1 False (const (return False)) 3 (Fold.take 3 Fold.toList)
-- $ Stream.timestamped
-- $ Stream.delay 0.1
-- $ Stream.fromList ((,) <$> [1,2,3] <*> ['a','b','c'])
-- :}
-- (1,"abc")
-- (2,"abc")
-- (3,"abc")
--
-- /Pre-release/
{-# INLINE classifySessionsBy #-}
classifySessionsBy
:: (MonadAsync m, Ord k)
=> Double -- ^ timer tick in seconds
-> Bool -- ^ reset the timer when an event is received
-> (Int -> m Bool) -- ^ predicate to eject sessions based on session count
-> Double -- ^ session timeout in seconds
-> Fold m a b -- ^ Fold to be applied to session data
-> Stream m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)
-> Stream m (k, b) -- ^ session key, fold result
classifySessionsBy = classifySessionsByGeneric (Proxy :: Proxy (Map k))
-- | Same as 'classifySessionsBy' with a timer tick of 1 second and keepalive
-- option set to 'True'.
--
-- @
-- classifyKeepAliveSessions = classifySessionsBy 1 True
-- @
--
-- /Pre-release/
--
{-# INLINE classifyKeepAliveSessions #-}
classifyKeepAliveSessions ::
(MonadAsync m, Ord k)
=> (Int -> m Bool) -- ^ predicate to eject sessions on session count
-> Double -- ^ session inactive timeout
-> Fold m a b -- ^ Fold to be applied to session payload data
-> Stream m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)
-> Stream m (k, b)
classifyKeepAliveSessions = classifySessionsBy 1 True
------------------------------------------------------------------------------
-- Keyed tumbling windows
------------------------------------------------------------------------------
-- Tumbling windows is a special case of sliding windows where the window slide
-- is the same as the window size. Or it can be a special case of session
-- windows where the reset flag is set to False.
-- XXX instead of using the early termination flag in the stream, we can use an
-- early terminating fold instead.
{-
-- | Split the stream into fixed size chunks of specified size. Within each
-- such chunk fold the elements in buckets identified by the keys. A particular
-- bucket fold can be terminated early if a closing flag is encountered in an
-- element for that key.
--
-- @since 0.7.0
{-# INLINABLE classifyChunksOf #-}
classifyChunksOf
:: (IsStream t, MonadAsync m, Ord k)
=> Int -- ^ window size
-> Fold m a b -- ^ Fold to be applied to window events
-> t m (k, a, Bool) -- ^ window key, data, close event
-> t m (k, b)
classifyChunksOf wsize = classifyChunksBy wsize False
-}
-- | Same as 'classifySessionsBy' with a timer tick of 1 second and keepalive
-- option set to 'False'.
--
-- >>> classifySessionsOf = Stream.classifySessionsBy 1 False
--
-- /Pre-release/
--
{-# INLINE classifySessionsOf #-}
classifySessionsOf ::
(MonadAsync m, Ord k)
=> (Int -> m Bool) -- ^ predicate to eject sessions on session count
-> Double -- ^ time window size
-> Fold m a b -- ^ Fold to be applied to session data
-> Stream m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)
-> Stream m (k, b)
classifySessionsOf = classifySessionsBy 1 False
------------------------------------------------------------------------------
-- Sampling
------------------------------------------------------------------------------
-- | Continuously evaluate the input stream and sample the last event in each
-- time window of @n@ seconds.
--
-- This is also known as @throttle@ in some libraries.
--
-- >>> sampleIntervalEnd n = Stream.catMaybes . Stream.intervalsOf n Fold.latest
--
{-# INLINE sampleIntervalEnd #-}
sampleIntervalEnd :: MonadAsync m => Double -> Stream m a -> Stream m a
sampleIntervalEnd n = Stream.catMaybes . intervalsOf n Fold.latest
-- | Like 'sampleInterval' but samples at the beginning of the time window.
--
-- >>> sampleIntervalStart n = Stream.catMaybes . Stream.intervalsOf n Fold.one
--
{-# INLINE sampleIntervalStart #-}
sampleIntervalStart :: MonadAsync m => Double -> Stream m a -> Stream m a
sampleIntervalStart n = Stream.catMaybes . intervalsOf n Fold.one
data BurstState t x =
BurstNone
| BurstWait !t !x
| BurstDone !x
| BurstDoneNext !x !t !x
{-# INLINE sampleBurst #-}
sampleBurst :: MonadAsync m => Bool -> Double -> Stream m a -> Stream m a
sampleBurst sampleAtEnd gap xs =
-- XXX Ideally we should schedule a timer event exactly after gap time,
-- but the tick stream should work well as long as the timer
-- granularity is small enough compared to the gap.
Stream.mapMaybe extract
$ Stream.scanl (Scanl.mkScanl step BurstNone)
$ Stream.timeIndexed
$ interject (return Nothing) 0.01 (fmap Just xs)
where
gap1 = toRelTime64 (NanoSecond64 (round (gap * 10^(9::Int))))
{-# INLINE step #-}
step BurstNone (t1, Just x1) = BurstWait t1 x1
step BurstNone _ = BurstNone
step (BurstDone _) (t1, Just x1) = BurstWait t1 x1
step (BurstDone _) _ = BurstNone
step old@(BurstWait t0 x0) (t1, Nothing)
| t1 - t0 >= gap1 = BurstDone x0
| otherwise = old
-- This can happen due to scheduling delays, if we received back to
-- back events spaced by more than the timeout without an
-- intervening timeout event then we emit the old event instead of
-- replacing it by the new.
step (BurstWait t0 x0) (t1, Just x1)
| t1 - t0 >= gap1 = BurstDoneNext x0 t1 x1
| sampleAtEnd = BurstWait t1 x1
| otherwise = BurstWait t1 x0
step (BurstDoneNext _ t0 x0) (t1, Nothing)
| t1 - t0 >= gap1 = BurstDone x0
| otherwise = BurstWait t0 x0
step (BurstDoneNext _ t0 x0) (t1, Just x1)
| t1 - t0 >= gap1 = BurstDoneNext x0 t1 x1
| sampleAtEnd = BurstWait t1 x1
| otherwise = BurstWait t1 x0
{-# INLINE extract #-}
extract (BurstDoneNext x _ _) = Just x
extract (BurstDone x) = Just x
extract _ = Nothing
-- | Sample one event at the end of each burst of events. A burst is a group
-- of events close together in time, it ends when an event is spaced by more
-- than the specified time interval (in seconds) from the previous event.
--
-- This is known as @debounce@ in some libraries.
--
-- The clock granularity is 10 ms.
--
{-# INLINE sampleBurstEnd #-}
sampleBurstEnd :: MonadAsync m => Double -> Stream m a -> Stream m a
sampleBurstEnd = sampleBurst True
-- | Like 'sampleBurstEnd' but samples the event at the beginning of the burst
-- instead of at the end of it.
--
{-# INLINE sampleBurstStart #-}
sampleBurstStart :: MonadAsync m => Double -> Stream m a -> Stream m a
sampleBurstStart = sampleBurst False
------------------------------------------------------------------------------
-- Lossy Buffering
------------------------------------------------------------------------------
-- XXX We could use 'maxBuffer Block/Drop/Rotate/Sample' instead. However we
-- may want to have the evaluation rate independent of the sampling rate. To
-- support that we can decouple evaluation and sampling in independent stages.
-- The sampling stage would strictly evaluate and sample, the evaluation stage
-- would control the evaluation rate.
--
-- bufferLatest - evaluate retaining only the latest element. Fork a thread
-- that keeps writing the stream to an IORef, another parallel thread reads
-- from the IORef.
--
-- bufferLatestN - Fork a thread that keeps writing to a sliding ring buffer,
-- and the stream unfolds the entire buffer when it is read, and the empty
-- buffer starts filling again in the same way.
--
-- bufferOldestN - Fork a thread that keeps writing to a buffer until it is
-- filled and keeps dropping once it is filled. When the stream is read the
-- buffer is unfolded to a stream and the empty buffer starts filling again.
-- | Evaluate the input stream continuously and keep only the oldest @n@
-- elements in the buffer, discard the new ones when the buffer is full. When
-- the output stream is evaluated the collected buffer is streamed and the
-- buffer starts filling again.
--
-- /Unimplemented/
--
{-# INLINE bufferOldestN #-}
bufferOldestN :: -- MonadAsync m =>
Int -> Stream m a -> Stream m a
bufferOldestN = undefined
-- | Evaluate the input stream continuously and keep only the latest @n@
-- elements in a ring buffer, keep discarding the older ones to make space for
-- the new ones. When the output stream is evaluated the buffer collected till
-- now is streamed and it starts filling again.
--
-- /Unimplemented/
--
{-# INLINE bufferLatestN #-}
bufferLatestN :: -- MonadAsync m =>
Int -> Stream m a -> Stream m a
bufferLatestN = undefined
-- | Always produce the latest available element from the stream without any
-- delay. The stream is continuously evaluated at the highest possible rate and
-- only the latest element is retained for sampling.
--
-- /Unimplemented/
--
{-# INLINE bufferLatest #-}
bufferLatest :: -- MonadAsync m =>
Stream m a -> Stream m (Maybe a)
bufferLatest = undefined