diff --git a/app/Backend/Backend.hs b/app/Backend/Backend.hs index 8af84dd..fceb050 100644 --- a/app/Backend/Backend.hs +++ b/app/Backend/Backend.hs @@ -21,7 +21,9 @@ 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. +-- 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) data Backend = BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String diff --git a/app/Environment.hs b/app/Environment.hs index 55738d1..1f69bec 100644 --- a/app/Environment.hs +++ b/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(lift) +import Control.Monad.Trans 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,21 +42,20 @@ 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)) +myLogAction = LogAction $ \x -> EnvM . lift $ modifyMVar_ syncMVar (const (T.putStrLn . formatMessage $ x)) --- my format Message without fancy colors, but with syslog numbers formatMessage :: Message -> T.Text formatMessage Msg{..} = showMyServerity msgSeverity diff --git a/app/Main.hs b/app/Main.hs index 8379eff..eff0e8f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -41,13 +41,6 @@ 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 @@ -64,6 +57,14 @@ 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 diff --git a/package.yaml b/package.yaml index 36dc1f0..b902fa2 100644 --- a/package.yaml +++ b/package.yaml @@ -49,8 +49,6 @@ dependencies: - unliftio-core - unliftio - mtl -# for pseq in logging -- parallel when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index e93b88c..c14f24d 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -56,7 +56,6 @@ executable tickLeisteServer , http-types , mtl , optparse-applicative - , parallel , text , tickLeiste , tickLeiste-aeson @@ -98,7 +97,6 @@ test-suite tickLeisteServer-test , http-types , mtl , optparse-applicative - , parallel , text , tickLeiste , tickLeiste-aeson