upgrade to 0.8; added Opinion-section
This commit is contained in:
188
content/Coding/Haskell/Webapp-Example/Main.hs.md
Normal file
188
content/Coding/Haskell/Webapp-Example/Main.hs.md
Normal file
@ -0,0 +1,188 @@
|
||||
# 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"
|
||||
|
||||
```
|
||||
83
content/Coding/Haskell/Webapp-Example/MyService_Types.hs.md
Normal file
83
content/Coding/Haskell/Webapp-Example/MyService_Types.hs.md
Normal file
@ -0,0 +1,83 @@
|
||||
# Webapp-Example: MyService/Types.hs
|
||||
|
||||
Anleitung siehe #[[Webapp-Example]].
|
||||
|
||||
```haskell
|
||||
{-# 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).
|
||||
```
|
||||
Reference in New Issue
Block a user