Compare commits
5 commits
Author | SHA1 | Date | |
---|---|---|---|
cbe6a7b6a7 | |||
|
9a3183d239 | ||
|
5dfca68212 | ||
|
9bf0157575 | ||
|
60ed3e8f51 |
8 changed files with 31 additions and 33 deletions
2
.gitmodules
vendored
2
.gitmodules
vendored
|
@ -1,3 +1,3 @@
|
|||
[submodule "tickLeiste"]
|
||||
path = tickLeiste
|
||||
url = ssh://gitolite@nerfingen.de:39999/tickLeiste
|
||||
url = https://git.nerfingen.de/Splittertech/tickLeiste.git
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -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
|
||||
|
|
15
app/Main.hs
15
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
|
||||
|
|
11
package.yaml
11
package.yaml
|
@ -41,16 +41,17 @@ 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
|
||||
- unliftio
|
||||
- mtl
|
||||
# for pseq in logging
|
||||
- parallel
|
||||
|
||||
when:
|
||||
- condition: flag(http)
|
||||
|
@ -85,5 +86,5 @@ tests:
|
|||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- tickLeisteServer
|
||||
# dependencies:
|
||||
# - tickLeisteServer
|
||||
|
|
|
@ -56,7 +56,6 @@ executable tickLeisteServer
|
|||
, http-types
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, parallel
|
||||
, text
|
||||
, tickLeiste
|
||||
, tickLeiste-aeson
|
||||
|
@ -64,7 +63,6 @@ executable tickLeisteServer
|
|||
, unliftio
|
||||
, unliftio-core
|
||||
, uuid
|
||||
, validation-selective
|
||||
, wai
|
||||
, wai-websockets
|
||||
, websockets
|
||||
|
@ -98,16 +96,13 @@ 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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue