From b98e5e27d03d6be915343bc04f39b7b0d3c9862f Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Wed, 14 Apr 2021 10:48:59 +0200 Subject: [PATCH 1/4] forced evaluation of logging message before blocking --- app/Environment.hs | 3 ++- package.yaml | 2 ++ tickLeisteServer.cabal | 2 ++ 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/app/Environment.hs b/app/Environment.hs index 1f69bec..ba5e8a0 100644 --- a/app/Environment.hs +++ b/app/Environment.hs @@ -18,6 +18,7 @@ import System.IO.Unsafe(unsafePerformIO) import qualified Control.Concurrent.MVar as M import qualified Data.Text as T import qualified Data.Text.IO as T +import Control.Parallel(pseq) newtype Env m = Env {logAction :: LogAction m Message} @@ -54,7 +55,7 @@ syncMVar = unsafePerformIO $ newMVar () {-# NOINLINE syncMVar #-} myLogAction :: LogAction EnvM Message -myLogAction = LogAction $ \x -> EnvM . lift $ modifyMVar_ syncMVar (const (T.putStrLn . formatMessage $ x)) +myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m)) formatMessage :: Message -> T.Text formatMessage Msg{..} = diff --git a/package.yaml b/package.yaml index b902fa2..36dc1f0 100644 --- a/package.yaml +++ b/package.yaml @@ -49,6 +49,8 @@ dependencies: - unliftio-core - unliftio - mtl +# for pseq in logging +- parallel when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index c14f24d..e93b88c 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -56,6 +56,7 @@ executable tickLeisteServer , http-types , mtl , optparse-applicative + , parallel , text , tickLeiste , tickLeiste-aeson @@ -97,6 +98,7 @@ test-suite tickLeisteServer-test , http-types , mtl , optparse-applicative + , parallel , text , tickLeiste , tickLeiste-aeson From f45297d86bca3ef5705f6212b0b124cca78e1201 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Wed, 14 Apr 2021 16:19:39 +0200 Subject: [PATCH 2/4] added some reasoning about deadlocks and removed unneeded code --- app/Environment.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/app/Environment.hs b/app/Environment.hs index ba5e8a0..1fd9108 100644 --- a/app/Environment.hs +++ b/app/Environment.hs @@ -11,11 +11,10 @@ module Environment(Env (..), EnvM, runEnvM, myLogAction,defaultEnv) where import Prelude hiding (log) import Colog import Control.Monad.Reader (ReaderT (..), MonadReader) -import Control.Monad.Trans +import Control.Monad.Trans(lift) import Control.Monad.IO.Unlift import Control.Concurrent.MVar (MVar,modifyMVar_,newMVar) import System.IO.Unsafe(unsafePerformIO) -import qualified Control.Concurrent.MVar as M import qualified Data.Text as T import qualified Data.Text.IO as T import Control.Parallel(pseq) @@ -43,17 +42,17 @@ instance MonadUnliftIO EnvM where withRunInIO inner = EnvM $ withRunInIO (\fromReader -> inner (fromReader . unEnvM)) {-# INLINE withRunInIO #-} -modifyMVar :: M.MVar a -> (a -> EnvM (a,b)) -> EnvM b -modifyMVar mvar action = withRunInIO $ \run -> M.modifyMVar mvar (run . action) - - runEnvM :: Env EnvM -> EnvM a -> IO a runEnvM env envm = runReaderT (unEnvM envm) env +-- we do not export this MVar (which makes it easier to reason about deadlocks syncMVar :: MVar () syncMVar = unsafePerformIO $ newMVar () {-# NOINLINE syncMVar #-} +-- Every time you do something like this you should ask yourself: Is this a potential deadlock? And the answer +-- is in this case is NO. Even if m diverges it won't be able to lock up other threads as it will be forced to +-- evaluate before we take the MVar. So as long printing to stdout terminates we will always put back the mvar. myLogAction :: LogAction EnvM Message myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m)) From 70ee16d202dc0ff1afa0f02c9d422d42773beb3e Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Wed, 14 Apr 2021 16:21:25 +0200 Subject: [PATCH 3/4] added a comment to formatMessage --- app/Environment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/app/Environment.hs b/app/Environment.hs index 1fd9108..55738d1 100644 --- a/app/Environment.hs +++ b/app/Environment.hs @@ -56,6 +56,7 @@ syncMVar = unsafePerformIO $ newMVar () myLogAction :: LogAction EnvM Message myLogAction = LogAction $ \x -> let m = formatMessage x in EnvM . lift $ m `pseq` modifyMVar_ syncMVar (const (T.putStrLn m)) +-- my format Message without fancy colors, but with syslog numbers formatMessage :: Message -> T.Text formatMessage Msg{..} = showMyServerity msgSeverity From 1816bd9bb5260d65c2bfc147528d6c0d6e479e00 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sun, 2 Jan 2022 23:58:22 +0100 Subject: [PATCH 4/4] smaller changes not changing semantics --- app/Backend/Backend.hs | 4 +--- app/Main.hs | 15 +++++++-------- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/app/Backend/Backend.hs b/app/Backend/Backend.hs index fceb050..8af84dd 100644 --- a/app/Backend/Backend.hs +++ b/app/Backend/Backend.hs @@ -21,9 +21,7 @@ import qualified Backend.Https as HTTPS -- list of MVar is there to communicate the termination of the backend. (The main -- threat will wait till all MVar are present (not neccesarry at once)). -- The action takes two parameter, the application the backend should run and --- the path of the config File. If the Bool is False there are no guarantees on the FilePath --- and the action should not try to evaluate the FilePath. --- type Backend = (Wai.Application -> FilePath -> IO [MVar ()],T.Text,Bool) +-- the path of the config File. data Backend = BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String diff --git a/app/Main.hs b/app/Main.hs index eff0e8f..8379eff 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -41,6 +41,13 @@ defaultLogLevel = Info blockBackends :: [MVar ()] -> EnvM () blockBackends = mapM_ takeMVar +runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> EnvM [MVar ()] +runBackend app (Left (Just conf)) (BackendWithConfig b _ _) = b app conf +runBackend _ (Left Nothing) (BackendWithConfig _ _ _) = return [] +runBackend app (Right True) (BackendWithoutConfig b _ _) = b app +runBackend _ (Right False) (BackendWithoutConfig _ _ _) = return [] +runBackend _ _ _ = logError "Backend and parser type don't match! THIS IS A BUG" >> return [] + data CommandLineOptions = CommandLineOptions { backendOptions :: [Either (Maybe String) Bool], logSeverity :: Maybe Severity @@ -57,14 +64,6 @@ parser = CommandLineOptions <$> backendsParser <*> severityParser - -runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> EnvM [MVar ()] -runBackend app (Left (Just conf)) (BackendWithConfig b _ _) = b app conf -runBackend _ (Left Nothing) (BackendWithConfig _ _ _) = return [] -runBackend app (Right True) (BackendWithoutConfig b _ _) = b app -runBackend _ (Right False) (BackendWithoutConfig _ _ _) = return [] -runBackend _ _ _ = logError "Backend and parser type don't match! THIS IS A BUG" >> return [] - commandLineParser :: ParserInfo CommandLineOptions commandLineParser = info (parser <**> helper) ( fullDesc