# Webapp-Example: Main.hs

Haskell
Code
Published

April 1, 2020

Wie man das verwendet, siehe Webapp-Example.

    {-# 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"