Merge pull request #45 from anton-k/lru-cache

Implements LRU cache
anton-k · Oct 21, 2023 · b241624 · b241624
2 parents 0e462f0 + 487fde5
commit b241624
Show file tree

Hide file tree

Showing 8 changed files with 170 additions and 48 deletions.
diff --git a/Makefile b/Makefile
@@ -1,7 +1,7 @@
 .PHONY: build test run docs
 
 build:
-	stack build 
+	stack build
 
 test:
 	stack test

diff --git 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
@@ -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
@@ -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 =

diff --git 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 <https://github.com/anton-k/mig#readme>
-                    .
-                    * examples directory for more fun servers: at <https://github.com/anton-k/mig/tree/main/examples/mig-example-apps#readme>
+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 <https://github.com/anton-k/mig#readme>
+  .
+  * examples directory for more fun servers: at <https://github.com/anton-k/mig/tree/main/examples/mig-example-apps#readme>
+
 category:           Web
 homepage:           https://github.com/anton-k/mig#readme
 bug-reports:        https://github.com/anton-k/mig/issues
@@ -25,45 +27,50 @@ maintainer:         [email protected]
 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
@@ -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
@@ -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)
@@ -115,6 +117,35 @@ fromServer (Server server) = \req -> do
 
     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
+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)
+
+    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
 additional captures from the route to the path

diff --git a/mig/src/Mig/Core/Server/Cache.hs 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