From a2b4f123217e95d96879edba3f92b3549c1faf92 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 21 Oct 2023 12:51:30 +0300 Subject: [PATCH 1/4] Implements LRU-cache on core level --- Makefile | 2 +- mig/mig.cabal | 97 +++++++++++++++++--------------- mig/package.yaml | 1 + mig/src/Mig/Core/Server.hs | 40 +++++++++++-- mig/src/Mig/Core/Server/Cache.hs | 58 +++++++++++++++++++ 5 files changed, 149 insertions(+), 49 deletions(-) create mode 100644 mig/src/Mig/Core/Server/Cache.hs diff --git a/Makefile b/Makefile index 41f2137..60e83d7 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build + stack build mig test: stack test diff --git a/mig/mig.cabal b/mig/mig.cabal index a4f2324..4625070 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.2. -- @@ -7,16 +7,18 @@ cabal-version: 1.12 name: mig version: 0.2.0.0 synopsis: Build lightweight and composable servers -description: Core for the mig server library. - With library mig we can build lightweight and composable servers. - There are only couple of combinators to assemble servers from parts. - It supports generic handler functions as servant does. But strives to use more - simple model for API. It does not go to describing Server API at type level which - leads to simpler error messages. - . - * quick start guide at - . - * examples directory for more fun servers: at +description: + Core for the mig server library. + With library mig we can build lightweight and composable servers. + There are only couple of combinators to assemble servers from parts. + It supports generic handler functions as servant does. But strives to use more + simple model for API. It does not go to describing Server API at type level which + leads to simpler error messages. + . + * quick start guide at + . + * examples directory for more fun servers: at + category: Web homepage: https://github.com/anton-k/mig#readme bug-reports: https://github.com/anton-k/mig/issues @@ -25,45 +27,50 @@ maintainer: anton.kholomiov@gmail.com copyright: 2023 Anton Kholomiov license: BSD3 build-type: Simple -extra-source-files: - README.md +extra-source-files: README.md source-repository head - type: git + type: git location: https://github.com/anton-k/mig library exposed-modules: - Mig.Core - Mig.Core.Api - Mig.Core.Class - Mig.Core.Class.MediaType - Mig.Core.Class.Monad - Mig.Core.Class.Plugin - Mig.Core.Class.Response - Mig.Core.Class.Route - Mig.Core.Class.Server - Mig.Core.OpenApi - Mig.Core.Server - Mig.Core.ServerFun - Mig.Core.Types - Mig.Core.Types.Http - Mig.Core.Types.Info - Mig.Core.Types.Route - other-modules: - Paths_mig - hs-source-dirs: - src + Mig.Core + Mig.Core.Api + Mig.Core.Class + Mig.Core.Class.MediaType + Mig.Core.Class.Monad + Mig.Core.Class.Plugin + Mig.Core.Class.Response + Mig.Core.Class.Route + Mig.Core.Class.Server + Mig.Core.OpenApi + Mig.Core.Server + Mig.Core.Server.Cache + Mig.Core.ServerFun + Mig.Core.Types + Mig.Core.Types.Http + Mig.Core.Types.Info + Mig.Core.Types.Route + + other-modules: Paths_mig + hs-source-dirs: src default-extensions: - OverloadedStrings - TypeFamilies - OverloadedRecordDot - DuplicateRecordFields - LambdaCase - DerivingStrategies - StrictData - AllowAmbiguousTypes - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages + AllowAmbiguousTypes + DerivingStrategies + DuplicateRecordFields + LambdaCase + OverloadedRecordDot + OverloadedStrings + StrictData + TypeFamilies + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -Wunused-packages + build-depends: aeson , base >=4.7 && <5 @@ -79,8 +86,10 @@ library , http-types , insert-ordered-containers , lens + , lrucache , mtl , openapi3 , safe , text - default-language: GHC2021 + + default-language: GHC2021 diff --git a/mig/package.yaml b/mig/package.yaml index 75c0618..8580b49 100644 --- a/mig/package.yaml +++ b/mig/package.yaml @@ -47,6 +47,7 @@ dependencies: - extra - insert-ordered-containers - lens +- lrucache default-extensions: - OverloadedStrings diff --git a/mig/src/Mig/Core/Server.hs b/mig/src/Mig/Core/Server.hs index a68ab84..4cce853 100644 --- a/mig/src/Mig/Core/Server.hs +++ b/mig/src/Mig/Core/Server.hs @@ -6,6 +6,7 @@ module Mig.Core.Server ( mapServerFun, mapResponse, fromServer, + fromServerWithCache, fillCaptures, addTag, setDescription, @@ -40,6 +41,7 @@ import Mig.Core.Api qualified as Api import Mig.Core.Class.MediaType import Mig.Core.Class.Response (IsResp (..), Resp (..)) import Mig.Core.Class.Route +import Mig.Core.Server.Cache import Mig.Core.ServerFun (ServerFun) import Mig.Core.Types (Request (..), Response, setContent) import Mig.Core.Types.Info (RouteInfo (..), RouteInput (..), describeInfoInputs, setOutputMedia) @@ -101,7 +103,7 @@ mapResponse f = mapServerFun $ \fun -> fmap (fmap f) . fun {-| Converts server to server function. Server function can be used to implement low-level handlers in various server-libraries. -} -fromServer :: (Monad m) => Server m -> ServerFun m +fromServer :: forall m. (Monad m) => Server m -> ServerFun m fromServer (Server server) = \req -> do case getRoute req of Just (routes, captureMap) -> routes.run req{capture = captureMap} @@ -109,11 +111,41 @@ fromServer (Server server) = \req -> do where serverNormal = toNormalApi (fillCaptures server) + getRoute :: Request -> Maybe (Route m, Api.CaptureMap) getRoute req = do - api <- fromNormalApi req.method (getMediaType "Accept" req) (getMediaType "Content-Type" req) serverNormal - Api.getPath req.path api + api <- fromNormalApi key.method key.outputType key.inputType serverNormal + Api.getPath key.path api + where + key = getCacheKey req + +{-| Converts server to server function. Server function can be used to implement low-level handlers +in various server-libraries. This function also uses LRU-cache to cache fetching of +the routes +-} +fromServerWithCache :: forall m. (MonadIO m) => RouteCache m -> Server m -> ServerFun m +fromServerWithCache cache (Server server) = \req -> do + mRoute <- liftIO $ withCache cache getRouteCache (getCacheKey req) + case mRoute of + Just (CacheValue captureMap routes) -> routes.run req{capture = captureMap} + Nothing -> pure Nothing + where + serverNormal = toNormalApi (fillCaptures server) - getMediaType name req = fromMaybe "*/*" $ Map.lookup name req.headers + getRouteCache :: CacheKey -> Maybe (CacheValue m) + getRouteCache key = do + api <- fromNormalApi key.method key.outputType key.inputType serverNormal + uncurry (flip CacheValue) <$> Api.getPath key.path api + +getCacheKey :: Request -> CacheKey +getCacheKey req = + CacheKey + { inputType = getMediaType "Content-Type" + , outputType = getMediaType "Accept" + , method = req.method + , path = req.path + } + where + getMediaType name = fromMaybe "*/*" $ Map.lookup name req.headers {-| Substitutes all stars * for corresponding names in captures if there are more captures in the route than in the path it adds diff --git a/mig/src/Mig/Core/Server/Cache.hs b/mig/src/Mig/Core/Server/Cache.hs new file mode 100644 index 0000000..6091e73 --- /dev/null +++ b/mig/src/Mig/Core/Server/Cache.hs @@ -0,0 +1,58 @@ +-- | LRU cache to speedup fetching of the route handler +module Mig.Core.Server.Cache ( + CacheConfig (..), + CacheKey (..), + CacheValue (..), + RouteCache (..), + newRouteCache, + withCache, +) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Cache.LRU.IO (AtomicLRU) +import Data.Cache.LRU.IO qualified as Lru +import Data.Text (Text) +import Mig.Core.Api (CaptureMap) +import Mig.Core.Class.Route (Route) +import Network.HTTP.Types.Method (Method) + +data CacheConfig = CacheConfig + { size :: Int + , cacheFilter :: CacheKey -> Bool + } + +data CacheKey = CacheKey + { inputType :: ByteString + , outputType :: ByteString + , method :: Method + , path :: [Text] + } + deriving (Show, Eq, Ord) + +data CacheValue m = CacheValue + { captures :: CaptureMap + , route :: Route m + } + +data RouteCache m = RouteCache + { cacheFilter :: CacheKey -> Bool + , cache :: AtomicLRU CacheKey (CacheValue m) + } + +newRouteCache :: CacheConfig -> IO (RouteCache m) +newRouteCache config = + RouteCache config.cacheFilter <$> Lru.newAtomicLRU (Just (fromIntegral config.size)) + +withCache :: RouteCache m -> (CacheKey -> Maybe (CacheValue m)) -> CacheKey -> IO (Maybe (CacheValue m)) +withCache (RouteCache cacheFilter cache) f key = do + mCacheResult <- liftIO $ Lru.lookup key cache + case mCacheResult of + Just result -> pure (Just result) + Nothing -> do + case f key of + Just result -> do + when (cacheFilter key) $ Lru.insert key result cache + pure (Just result) + Nothing -> pure Nothing From 320c368b0dc32ebb9c2f62cd666fa7a7372be116 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 21 Oct 2023 12:58:57 +0300 Subject: [PATCH 2/4] Implements LRU-cache for wai-warp --- Makefile | 2 +- mig-server/src/Mig.hs | 1 + mig-server/src/Mig/Server/Warp.hs | 5 ++++- mig-wai/src/Mig/Server/Wai.hs | 23 +++++++++++++++++++++-- 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 60e83d7..5819a80 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build mig + stack build mig-server test: stack test diff --git a/mig-server/src/Mig.hs b/mig-server/src/Mig.hs index 0160d6a..ce9cf61 100644 --- a/mig-server/src/Mig.hs +++ b/mig-server/src/Mig.hs @@ -110,6 +110,7 @@ module Mig ( runServer, runServer', ServerConfig (..), + CacheConfig (..), toApplication, -- ** Render diff --git a/mig-server/src/Mig/Server/Warp.hs b/mig-server/src/Mig/Server/Warp.hs index a41fa60..2caf54b 100644 --- a/mig-server/src/Mig/Server/Warp.hs +++ b/mig-server/src/Mig/Server/Warp.hs @@ -2,16 +2,19 @@ module Mig.Server.Warp ( runServer, runServer', + ServerConfig (..), + CacheConfig (..), ) where import Mig.Core +import Mig.Core.Server.Cache import Mig.Server.Wai import Network.Wai.Handler.Warp qualified as Warp runServer :: Int -> Server IO -> IO () runServer port server = Warp.run port (toApplication config server) where - config = ServerConfig{maxBodySize = Nothing} + config = ServerConfig{maxBodySize = Nothing, cache = Nothing} runServer' :: ServerConfig -> Int -> Server IO -> IO () runServer' config port server = Warp.run port (toApplication config server) diff --git a/mig-wai/src/Mig/Server/Wai.hs b/mig-wai/src/Mig/Server/Wai.hs index 855344d..322a2e3 100644 --- a/mig-wai/src/Mig/Server/Wai.hs +++ b/mig-wai/src/Mig/Server/Wai.hs @@ -18,6 +18,7 @@ import Data.Text (Text) import Network.Wai qualified as Wai import Mig.Core +import Mig.Core.Server.Cache -- | Size of the input body type Kilobytes = Int @@ -26,11 +27,17 @@ type Kilobytes = Int data ServerConfig = ServerConfig { maxBodySize :: Maybe Kilobytes -- ^ limit the request body size. By default it is unlimited. + , cache :: Maybe CacheConfig } --- | Convert server to WAI-application toApplication :: ServerConfig -> Server IO -> Wai.Application -toApplication config server req procResponse = do +toApplication config = case config.cache of + Just cacheConfig -> toApplicationWithCache cacheConfig config + Nothing -> toApplicationNoCache config + +-- | Convert server to WAI-application +toApplicationNoCache :: ServerConfig -> Server IO -> Wai.Application +toApplicationNoCache config server req procResponse = do mResp <- handleError onErr (fromServer server) =<< fromRequest config.maxBodySize req procResponse $ toWaiResponse $ fromMaybe noResult mResp where @@ -39,6 +46,18 @@ toApplication config server req procResponse = do onErr :: SomeException -> ServerFun IO onErr err = const $ pure $ Just $ badRequest @Text $ "Error: Exception has happened: " <> toText (show err) +-- | Convert server to WAI-application +toApplicationWithCache :: CacheConfig -> ServerConfig -> Server IO -> Wai.Application +toApplicationWithCache cacheConfig config server req procResponse = do + cache <- newRouteCache cacheConfig + mResp <- handleError onErr (fromServerWithCache cache server) =<< fromRequest config.maxBodySize req + procResponse $ toWaiResponse $ fromMaybe noResult mResp + where + noResult = badRequest @Text ("Server produces nothing" :: Text) + + onErr :: SomeException -> ServerFun IO + onErr err = const $ pure $ Just $ badRequest @Text $ "Error: Exception has happened: " <> toText (show err) + -- | Convert response to low-level WAI-response toWaiResponse :: Response -> Wai.Response toWaiResponse resp = From 85837966b41601123b30be37937f5afb6bb043e1 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 21 Oct 2023 13:01:53 +0300 Subject: [PATCH 3/4] Build all --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 5819a80..f599f5c 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build mig-server + stack build test: stack test From 487fde54889f6085bb2ce6a400a732c403c6b004 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 21 Oct 2023 13:13:43 +0300 Subject: [PATCH 4/4] Inline getRoutes --- mig/src/Mig/Core/Server.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/mig/src/Mig/Core/Server.hs b/mig/src/Mig/Core/Server.hs index 4cce853..c7428f4 100644 --- a/mig/src/Mig/Core/Server.hs +++ b/mig/src/Mig/Core/Server.hs @@ -103,7 +103,7 @@ mapResponse f = mapServerFun $ \fun -> fmap (fmap f) . fun {-| Converts server to server function. Server function can be used to implement low-level handlers in various server-libraries. -} -fromServer :: forall m. (Monad m) => Server m -> ServerFun m +fromServer :: (Monad m) => Server m -> ServerFun m fromServer (Server server) = \req -> do case getRoute req of Just (routes, captureMap) -> routes.run req{capture = captureMap} @@ -111,12 +111,11 @@ fromServer (Server server) = \req -> do where serverNormal = toNormalApi (fillCaptures server) - getRoute :: Request -> Maybe (Route m, Api.CaptureMap) getRoute req = do - api <- fromNormalApi key.method key.outputType key.inputType serverNormal - Api.getPath key.path api - where - key = getCacheKey req + api <- fromNormalApi req.method (getMediaType "Accept" req) (getMediaType "Content-Type" req) serverNormal + Api.getPath req.path api + + getMediaType name req = fromMaybe "*/*" $ Map.lookup name req.headers {-| Converts server to server function. Server function can be used to implement low-level handlers in various server-libraries. This function also uses LRU-cache to cache fetching of