Unfinished updated outbox handler

src/Control/Concurrent/ResultShare.hs

@@ -0,0 +1,97 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | This module provides a structure that allows multiple threads that need to
+-- run the same action, to run it only once, and let all the threads get the
+-- result. For example, suppose in multiple places in your concurrent program,
+-- it needs to download some file over the network. Using 'ResultShare', the
+-- download is started when it's first requested, and if during the download
+-- other threads request it too, they instead wait for that existing download
+-- to complete and they all get that same file once it's downloaded.
+--
+-- Note that the result is deleted from the structure once the action
+-- completes! So if you'd like that downloaded file to be reused after the
+-- download completes, use some separate structure for that.
+--
+-- Limitations:
+--
+--   * The settings constructor is exposed, and there's no defaults, not
+--     allowing to add settings in a backward compatible way
+--   * It could be nice to provide defaults for plain IO and for UnliftIO
+--   * The action is constant, could make it more flexible
+module Control.Concurrent.ResultShare
+    ( ResultShareSettings (..)
+    , ResultShare ()
+    , newResultShare
+    , runShared
+    )
+where
+
+import Prelude
+
+import Control.Concurrent.MVar
+import Control.Concurrent.STM.TVar
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.STM
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+
+import qualified Data.HashMap.Strict as M
+
+data ResultShareSettings m k v a = ResultShareSettings
+    { resultShareFork   :: m () -> m ()
+    , resultShareAction :: k -> a -> m v
+    }
+
+data ResultShare m k v a = ResultShare
+    { _rsMap    :: TVar (HashMap k (MVar v))
+    , _rsFork   :: m () -> m ()
+    , _rsAction :: k -> a -> m v
+    }
+
+newResultShare
+    :: MonadIO m => ResultShareSettings m k v a -> m (ResultShare m k v a)
+newResultShare (ResultShareSettings fork action) = do
+    tvar <- liftIO $ newTVarIO M.empty
+    return $ ResultShare tvar fork action
+
+-- TODO this is copied from stm-2.5, remove when we upgrade LTS
+stateTVar :: TVar s -> (s -> (a, s)) -> STM a
+stateTVar var f = do
+    s <- readTVar var
+    let (a, s') = f s -- since we destructure this, we are strict in f
+    writeTVar var s'
+    return a
+
+runShared
+    :: (MonadIO m, Eq k, Hashable k) => ResultShare m k v a -> k -> a -> m v
+runShared (ResultShare tvar fork action) key param = do
+    (mvar, new) <- liftIO $ do
+        existing <- M.lookup key <$> readTVarIO tvar
+        case existing of
+            Just v -> return (v, False)
+            Nothing -> do
+                v <- newEmptyMVar
+                atomically $ stateTVar tvar $ \ m ->
+                    case M.lookup key m of
+                        Just v' -> ((v', False), m)
+                        Nothing -> ((v , True) , M.insert key v m)
+    when new $ fork $ do
+        result <- action key param
+        liftIO $ do
+            atomically $ modifyTVar' tvar $ M.delete key
+            putMVar mvar result
+    liftIO $ readMVar mvar