Wie man das verwendet, siehe Webapp-Development in 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"