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"

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
module MyService.Types where
 
import           Data.Aeson                     (FromJSON, ToJSON)
import           Data.Text
import           Data.Time.Clock
import           GHC.Generics
import           System.Envy
import           Text.PrettyPrint               (text)
import           Text.PrettyPrint.GenericPretty
 
-- Out hat hierfür keine Instanzen, daher kurz eine einfach Definition.
instance Out Text where
  doc = text . unpack
  docPrec i a = text $ showsPrec i a ""
 
instance Out UTCTime where
  doc = text . show
  docPrec i a = text $ showsPrec i a ""
 
-- Der ServerConfig-Typ. Wird mit den defaults unten initialisiert, dann mit den Variablen aus der .env-Datei überschrieben und zum Schluss können Serveradmins diese via $MYSERVICE_FOO nochmal überschreiben.
data ServerConfig = ServerConfig
                  { myserviceHost              :: String -- ^ Environment: $MYSERVICE_HOST
                  , myservicePort              :: Int    -- ^ Environment: $MYSERVICE_PORT
                  , myserviceMaxTimeout        :: Int    -- ^ Environment: $MYSERVICE_MAX_TIMEOUT
                  , myserviceInternalProxyUrl  :: String -- ^ Environment: $MYSERVICE_INTERNAL_PROXY_URL
                  , myserviceInternalProxyPort :: Int    -- ^ Environment: $MYSERVICE_INTERNAL_PROXY_PORT
                  , myserviceExternalProxyUrl  :: String -- ^ Environment: $MYSERVICE_EXTERNAL_PROXY_URL
                  , myserviceExternalProxyPort :: Int    -- ^ Environment: $MYSERVICE_EXTERNAL_PROXY_PORT
                  , myserviceActivemqHost      :: String -- ^ Environment: $MYSERVICE_ACTIVEMQ_HOST
                  , myserviceActivemqPort      :: Int    -- ^ Environment: $MYSERVICE_ACTIVEMQ_PORT
                  , myserviceActivemqUsername  :: String -- ^ Environment: $MYSERVICE_ACTIVEMQ_USERNAME
                  , myserviceActivemqPassword  :: String -- ^ Environment: $MYSERVICE_ACTIVEMQ_PASSWORD
                  , myserviceMongoUsername     :: String -- ^ Environment: $MYSERVICE_MONGO_USERNAME
                  , myserviceMongoPassword     :: String -- ^ Environment: $MYSERVICE_MONGO_PASSWORD
                  , myserviceDebug             :: Bool   -- ^ Environment: $MYSERVICE_DEBUG
                  } deriving (Show, Eq, Generic)
 
-- Default-Konfigurations-Instanz für diesen Service.
instance DefConfig ServerConfig where
  defConfig = ServerConfig "0.0.0.0" 8080 20
                           ""
                           ""
                           ""
                           0
                           ""
                           0
                           ""
                           0
                           ""
                           ""
                           ""
                           ""
                           False
 
-- Kann auch aus dem ENV gefüllt werden
instance FromEnv ServerConfig
-- Und hübsch ausgegeben werden.
instance Out ServerConfig
 
 
instance Out Response
instance FromBSON Repsonse -- FromBSON-Instanz geht immer davon aus, dass alle keys da sind (ggf. mit null bei Nothing).