diff --git a/.gitmodules b/.gitmodules index 166aaf1..9548495 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "tickLeiste"] path = tickLeiste - url = https://git.nerfingen.de/Splittertech/tickLeiste.git + url = ssh://gitolite@nerfingen.de:39999/tickLeiste 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/Backend/Http.hs b/app/Backend/Http.hs index 4b6f813..e99c8be 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 01f2181..69afa1e 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' diff --git a/app/Environment.hs b/app/Environment.hs index 1f69bec..55738d1 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 +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 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 diff --git a/package.yaml b/package.yaml index 4ad753d..36dc1f0 100644 --- a/package.yaml +++ b/package.yaml @@ -41,17 +41,16 @@ dependencies: - containers - wai - wai-websockets -# only used for the error message on missing webclient - http-types - tomland -# if we want more interaction with tomland errors this might -# be practical (not used atm, there are functions to Either) -#- validation-selective +- validation-selective - optparse-applicative - co-log - unliftio-core - unliftio - mtl +# for pseq in logging +- parallel when: - condition: flag(http) @@ -86,5 +85,5 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N -# dependencies: -# - tickLeisteServer + dependencies: + - tickLeisteServer diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index c3823b5..e93b88c 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -56,6 +56,7 @@ executable tickLeisteServer , http-types , mtl , optparse-applicative + , parallel , text , tickLeiste , tickLeiste-aeson @@ -63,6 +64,7 @@ executable tickLeisteServer , unliftio , unliftio-core , uuid + , validation-selective , wai , wai-websockets , websockets @@ -96,13 +98,16 @@ test-suite tickLeisteServer-test , http-types , mtl , optparse-applicative + , parallel , text , tickLeiste , tickLeiste-aeson + , tickLeisteServer , tomland , unliftio , unliftio-core , uuid + , validation-selective , wai , wai-websockets , websockets