From 60ed3e8f512510d595848b9488aec93c5495c7a5 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sun, 11 Apr 2021 14:51:05 +0200 Subject: [PATCH 1/9] cleaned up some dependencies --- package.yaml | 5 ++++- tickLeisteServer.cabal | 2 -- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index b902fa2..30c4809 100644 --- a/package.yaml +++ b/package.yaml @@ -41,9 +41,12 @@ dependencies: - containers - wai - wai-websockets +# only used for the error message on missing webclient - http-types - tomland -- validation-selective +# if we want more interaction with tomland errors this might +# be practical (not used atm, there are functions to Either) +#- validation-selective - optparse-applicative - co-log - unliftio-core diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index c14f24d..b1e69e3 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -63,7 +63,6 @@ executable tickLeisteServer , unliftio , unliftio-core , uuid - , validation-selective , wai , wai-websockets , websockets @@ -105,7 +104,6 @@ test-suite tickLeisteServer-test , unliftio , unliftio-core , uuid - , validation-selective , wai , wai-websockets , websockets From b98e5e27d03d6be915343bc04f39b7b0d3c9862f Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Wed, 14 Apr 2021 10:48:59 +0200 Subject: [PATCH 2/9] 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 3/9] 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 4/9] 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 5/9] 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 From 9bf0157575761f48a1dbf0baf5704e1533bf2e9a Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sun, 2 Jan 2022 23:59:36 +0100 Subject: [PATCH 6/9] removed lib dependency from test --- package.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 30c4809..4ad753d 100644 --- a/package.yaml +++ b/package.yaml @@ -86,5 +86,5 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N - dependencies: - - tickLeisteServer +# dependencies: +# - tickLeisteServer From 5dfca682120e291f8940563932f03cc0583eae05 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Mon, 3 Jan 2022 00:02:41 +0100 Subject: [PATCH 7/9] changes propagated to cabal --- tickLeisteServer.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index b1e69e3..c3823b5 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -99,7 +99,6 @@ test-suite tickLeisteServer-test , text , tickLeiste , tickLeiste-aeson - , tickLeisteServer , tomland , unliftio , unliftio-core From 9a3183d2393d219dfab5381cbfc83d4c0295ce9f Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Tue, 4 Jan 2022 23:44:06 +0100 Subject: [PATCH 8/9] made all config params start lower case --- app/Backend/Http.hs | 6 +++--- app/Backend/Https.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index e99c8be..4b6f813 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -67,9 +67,9 @@ httpDefaultSettings = [httpDefaultSetting] httpConfigCodec :: TomlCodec HttpConfiguration httpConfigCodec = HttpConfiguration - <$> Toml.configM Toml.text "InstanceName" .= instanceName - <*> Toml.configM Toml.int "Port" .= port - <*> Toml.configM bindPreference "Bind" .= bindPref + <$> Toml.configM Toml.text "instanceName" .= instanceName + <*> Toml.configM Toml.int "port" .= port + <*> Toml.configM bindPreference "bind" .= bindPref httpConfigsCodec :: TomlCodec [HttpConfiguration] httpConfigsCodec = Toml.list httpConfigCodec "http" diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 69afa1e..01f2181 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -55,9 +55,9 @@ httpsDefaultSettings = [httpsDefaultSetting] httpsConfigCodec' :: TomlCodec TLSConfiguration httpsConfigCodec' = TLSConfiguration - <$> Toml.configM Toml.string "Certificate" .= certFile - <*> Toml.configM (Toml.arrayOf Toml._String) "CertChain" .= certChain - <*> Toml.configM Toml.string "KeyFile" .= keyFile + <$> Toml.configM Toml.string "certificate" .= certFile + <*> Toml.configM (Toml.arrayOf Toml._String) "certChain" .= certChain + <*> Toml.configM Toml.string "keyFile" .= keyFile httpsConfigCodec :: TomlCodec HttpsConfiguration httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' From cbe6a7b6a7b6a8a74b98e63c487cdcf6b871d5f6 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sat, 10 May 2025 14:42:07 +0200 Subject: [PATCH 9/9] changed submodule url to forgejo --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 9548495..166aaf1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "tickLeiste"] path = tickLeiste - url = ssh://gitolite@nerfingen.de:39999/tickLeiste + url = https://git.nerfingen.de/Splittertech/tickLeiste.git