189 lines
9.5 KiB
Markdown
189 lines
9.5 KiB
Markdown
|
# Webapp-Example: Main.hs
|
||
|
|
|
||
|
|
Wie man das verwendet, siehe #[[Webapp-Example]].
|
||
|
|
|
||
|
|
```haskell
|
||
|
|
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||
|
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE LambdaCase #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE RankNTypes #-}
|
||
|
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
|
module MyService where
|
||
|
|
|
||
|
|
-- generische imports aus den dependencies/base, nicht in der prelude
|
||
|
|
import Codec.MIME.Type
|
||
|
|
import Configuration.Dotenv as Dotenv
|
||
|
|
import Control.Concurrent (forkIO, threadDelay)
|
||
|
|
import Control.Concurrent.Async
|
||
|
|
import Control.Concurrent.STM
|
||
|
|
import Control.Monad
|
||
|
|
import Control.Monad.Catch
|
||
|
|
import Control.Monad.Except
|
||
|
|
import Conversion
|
||
|
|
import Conversion.Text ()
|
||
|
|
import Data.Binary.Builder
|
||
|
|
import Data.String (IsString (..))
|
||
|
|
import Data.Time
|
||
|
|
import Data.Time.Clock
|
||
|
|
import Data.Time.Format
|
||
|
|
import Data.Default
|
||
|
|
import Network.HostName
|
||
|
|
import Network.HTTP.Client as HTTP hiding
|
||
|
|
(withConnection)
|
||
|
|
import Network.HTTP.Types (Status, statusCode)
|
||
|
|
import Network.Mom.Stompl.Client.Queue
|
||
|
|
import Network.Wai (Middleware)
|
||
|
|
import Network.Wai.Logger
|
||
|
|
import Network.Wai.Middleware.Cors
|
||
|
|
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
|
||
|
|
logStdout,
|
||
|
|
mkRequestLogger,
|
||
|
|
outputFormat)
|
||
|
|
import Servant.Client (mkClientEnv,
|
||
|
|
parseBaseUrl)
|
||
|
|
import System.Directory
|
||
|
|
import System.Envy
|
||
|
|
import System.IO
|
||
|
|
import System.Log.FastLogger
|
||
|
|
import Text.PrettyPrint.GenericPretty
|
||
|
|
|
||
|
|
-- generische imports, aber qualified, weil es sonst zu name-clashes kommt
|
||
|
|
|
||
|
|
import qualified Data.ByteString as BS
|
||
|
|
-- import qualified Data.ByteString.Char8 as BS8
|
||
|
|
import qualified Data.ByteString.Lazy as LBS
|
||
|
|
import qualified Network.HTTP.Client.TLS as UseDefaultHTTPSSettings (tlsManagerSettings)
|
||
|
|
import qualified Network.Mom.Stompl.Client.Queue as AMQ
|
||
|
|
import qualified Network.Wai as WAI
|
||
|
|
|
||
|
|
-- Handler für den MyServiceBackend-Typen und Imports aus den Libraries
|
||
|
|
import MyService.Handler as H -- handler der H.myApiEndpointV1Post implementiert
|
||
|
|
import MyService.Types -- weitere Type (s. nächste box)
|
||
|
|
import MyServiceGen.API as MS -- aus der generierten library
|
||
|
|
|
||
|
|
|
||
|
|
myServicemain :: IO ()
|
||
|
|
myServicemain = do
|
||
|
|
-- .env-Datei ins Prozess-Environment laden, falls noch nicht von außen gesetzt
|
||
|
|
void $ loadFile $ Dotenv.Config [".env"] [] False
|
||
|
|
-- Config holen (defaults + overrides aus dem Environment)
|
||
|
|
sc@ServerConfig{..} <- decodeWithDefaults defConfig
|
||
|
|
-- Backend-Setup
|
||
|
|
-- legt sowas wie Proxy-Server fest und wo man wie dran kommt. Benötigt für das Sprechen mit anderen Microservices
|
||
|
|
let defaultHTTPSSettings = UseDefaultHTTPSSettings.tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro $ 1000 * 1000 * myserviceMaxTimeout }
|
||
|
|
createBackend url proxy = do
|
||
|
|
manager <- newManager . managerSetProxy proxy
|
||
|
|
$ defaultHTTPSSettings
|
||
|
|
url' <- parseBaseUrl url
|
||
|
|
return (mkClientEnv manager url')
|
||
|
|
internalProxy = case myserviceInternalProxyUrl of
|
||
|
|
"" -> noProxy
|
||
|
|
url -> useProxy $ HTTP.Proxy (fromString url) myserviceInternalProxyPort
|
||
|
|
-- externalProxy = case myserviceExternalProxyUrl of
|
||
|
|
-- "" -> noProxy
|
||
|
|
-- url -> useProxy $ HTTP.Proxy (fromString url) myserviceExternalProxyPort
|
||
|
|
|
||
|
|
-- Definieren & Erzeugen der Funktionen um die anderen Services anzusprechen.
|
||
|
|
calls <- (,)
|
||
|
|
<$> createBackend myserviceAUri internalProxy
|
||
|
|
<*> createBackend myserviceBUri internalProxy
|
||
|
|
|
||
|
|
-- Logging-Setup
|
||
|
|
hSetBuffering stdout LineBuffering
|
||
|
|
hSetBuffering stderr LineBuffering
|
||
|
|
|
||
|
|
|
||
|
|
-- Infos holen, brauchen wir später
|
||
|
|
myName <- getHostName
|
||
|
|
today <- formatTime defaultTimeLocale "%F" . utctDay <$> getCurrentTime
|
||
|
|
|
||
|
|
|
||
|
|
-- activeMQ-Transaktional-Queue zum schreiben nachher vorbereiten
|
||
|
|
amqPost <- newTQueueIO
|
||
|
|
|
||
|
|
|
||
|
|
-- bracket a b c == erst a machen, ergebnis an c als variablen übergeben. Schmeisst c ne exception/wird gekillt/..., werden die variablen an b übergeben.
|
||
|
|
bracket
|
||
|
|
-- logfiles öffnen
|
||
|
|
(LogFiles <$> openFile ("/logs/myservice-"<>myName<>"-"<>today<>".info") AppendMode
|
||
|
|
<*> openFile (if myserviceDebug then "/logs/myservice-"<>myName<>"-"<>today<>".debug" else "/dev/null") AppendMode
|
||
|
|
<*> openFile ("/logs/myservice-"<>myName<>"-"<>today<>".error") AppendMode
|
||
|
|
<*> openFile ("/logs/myservice-"<>myName<>"-"<>today<>".timings") AppendMode
|
||
|
|
)
|
||
|
|
-- und bei exception/beendigung schlißen.h
|
||
|
|
(\(LogFiles a b c d) -> mapM_ hClose [a,b,c,d])
|
||
|
|
$ \logfiles -> do
|
||
|
|
|
||
|
|
|
||
|
|
-- logschreibe-funktionen aliasen; log ist hier abstrakt, iolog spezialisiert auf io.
|
||
|
|
let log = printLogFiles logfiles :: MonadIO m => [LogItem] -> m ()
|
||
|
|
iolog = printLogFilesIO logfiles :: [LogItem] -> IO ()
|
||
|
|
|
||
|
|
|
||
|
|
-- H.myApiEndpointV1Post ist ein Handler (alle Handler werden mit alias H importiert) und in einer eigenen Datei
|
||
|
|
-- Per Default bekommen Handler sowas wie die server-config, die Funktionen um mit anderen Services zu reden, die AMQ-Queue um ins Kibana zu loggen und eine Datei-Logging-Funktion
|
||
|
|
-- Man kann aber noch viel mehr machen - z.b. gecachte Daten übergeben, eine Talk-Instanz, etc. pp.
|
||
|
|
server = MyServiceBackend{ myApiEndpointV1Post = H.myApiEndpointV1Post sc calls amqPost log
|
||
|
|
}
|
||
|
|
config = MS.Config $ "http://" ++ myserviceHost ++ ":" ++ show myservicePort ++ "/"
|
||
|
|
iolog . pure . Info $ "Using Server configuration:"
|
||
|
|
iolog . pure . Info $ pretty sc { myserviceActivemqPassword = "******" -- Do NOT log the password ;)
|
||
|
|
, myserviceMongoPassword = "******"
|
||
|
|
}
|
||
|
|
-- alle Services starten (Hintergrund-Aktionen wie z.b. einen MongoDB-Dumper, einen Talk-Server oder wie hier die ActiveMQ
|
||
|
|
void $ forkIO $ keepActiveMQConnected sc iolog amqPost
|
||
|
|
-- logging-Framework erzeugen
|
||
|
|
loggingMW <- loggingMiddleware
|
||
|
|
-- server starten
|
||
|
|
if myserviceDebug
|
||
|
|
then runMyServiceMiddlewareServer config (cors (\_ -> Just (simpleCorsResourcePolicy {corsRequestHeaders = ["Content-Type"]})) . loggingMW . logStdout) server
|
||
|
|
else runMyServiceMiddlewareServer config (cors (\_ -> Just (simpleCorsResourcePolicy {corsRequestHeaders = ["Content-Type"]}))) server
|
||
|
|
|
||
|
|
|
||
|
|
-- Sollte bald in die Library hs-stomp ausgelagert werden
|
||
|
|
-- ist ein Beispiel für einen ActiveMQ-Dumper
|
||
|
|
keepActiveMQConnected :: ServerConfig -> ([LogItem] -> IO ()) -> TQueue BS.ByteString -> IO ()
|
||
|
|
keepActiveMQConnected sc@ServerConfig{..} printLog var = do
|
||
|
|
res <- handle (\(e :: SomeException) -> do
|
||
|
|
printLog . pure . Error $ "Exception in AMQ-Thread: "<>show e
|
||
|
|
return $ Right ()
|
||
|
|
) $ AMQ.try $ do -- catches all AMQ-Exception that we can handle. All others bubble up.
|
||
|
|
printLog . pure . Info $ "AMQ: connecting..."
|
||
|
|
withConnection myserviceActivemqHost myserviceActivemqPort [ OAuth myserviceActivemqUsername myserviceActivemqPassword
|
||
|
|
, OTmo (30*1000) {- 30 sec timeout -}
|
||
|
|
]
|
||
|
|
[] $ \c -> do
|
||
|
|
let oconv = return
|
||
|
|
printLog . pure . Info $ "AMQ: connected"
|
||
|
|
withWriter c "Chaos-Logger for Kibana" "chaos.logs" [] [] oconv $ \writer -> do
|
||
|
|
printLog . pure . Info $ "AMQ: queue created"
|
||
|
|
let postfun = writeQ writer (Type (Application "json") []) []
|
||
|
|
void $ race
|
||
|
|
(forever $ atomically (readTQueue var) >>= postfun)
|
||
|
|
(threadDelay (600*1000*1000)) -- wait 10 Minutes
|
||
|
|
-- close writer
|
||
|
|
-- close connection
|
||
|
|
-- get outside of all try/handle/...-constructions befor recursing.
|
||
|
|
case res of
|
||
|
|
Left ex -> do
|
||
|
|
printLog . pure . Error $ "AMQ: "<>show ex
|
||
|
|
keepActiveMQConnected sc printLog var
|
||
|
|
Right _ -> keepActiveMQConnected sc printLog var
|
||
|
|
|
||
|
|
|
||
|
|
-- Beispiel für eine Custom-Logging-Middleware.
|
||
|
|
-- Hier werden z.B. alle 4xx-Status-Codes inkl. Payload ins stdout-Log geschrieben.
|
||
|
|
-- Nützlich, wenn die Kollegen ihre Requests nicht ordentlich schreiben können und der Server das Format zurecht mit einem BadRequest ablehnt ;)
|
||
|
|
loggingMiddleware :: IO Middleware
|
||
|
|
loggingMiddleware = liftIO $ mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails out }
|
||
|
|
where
|
||
|
|
out :: ZonedDate -> WAI.Request -> Status -> Maybe Integer -> NominalDiffTime -> [BS.ByteString] -> Builder -> LogStr
|
||
|
|
out _ r status _ _ payload _
|
||
|
|
| statusCode status < 300 = ""
|
||
|
|
| statusCode status > 399 && statusCode status < 500 = "Error code "<>toLogStr (statusCode status) <>" sent. Request-Payload was: "<> mconcat (toLogStr <$> payload) <> "\n"
|
||
|
|
| otherwise = toLogStr (show r) <> "\n"
|
||
|
|
|
||
|
|
```
|