smaller changes not changing semantics

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
+-- the path of the config File.
--- and the action should not try to evaluate the FilePath.
--- type Backend = (Wai.Application -> FilePath -> IO [MVar ()],T.Text,Bool)
 
 data Backend =
   BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String

app/Environment.hs

@@ -11,13 +11,13 @@ 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)
 
 newtype Env m = Env {logAction :: LogAction m Message}
 
@@ -42,20 +42,21 @@ 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 -> 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))
 
+-- my format Message without fancy colors, but with syslog numbers
 formatMessage :: Message -> T.Text
 formatMessage Msg{..} =
   showMyServerity msgSeverity

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

package.yaml

@@ -49,6 +49,8 @@ dependencies:
 - unliftio-core
 - unliftio
 - mtl
+# for pseq in logging
+- parallel
 
 when:
   - condition: flag(http)

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