From bebd4b4b2b8e4bf1bd66d3d1577cb6751cb95fb6 Mon Sep 17 00:00:00 2001 From: Alberto Valverde Date: Thu, 29 Feb 2024 09:12:15 +0100 Subject: [PATCH] [inferno-vc] Add a parameter to apply WAI middleware to the VC server (#104) Allow users of the library to apply WAI Middleare to the Application to, eg, extend the API --- inferno-vc/CHANGELOG.md | 5 ++++ inferno-vc/inferno-vc.cabal | 2 +- .../src/Inferno/VersionControl/Client.hs | 10 +++----- inferno-vc/src/Inferno/VersionControl/Log.hs | 2 ++ .../src/Inferno/VersionControl/Operations.hs | 14 ++++++++++- .../src/Inferno/VersionControl/Server.hs | 25 ++++++++++++------- inferno-vc/test/Spec.hs | 4 +-- 7 files changed, 43 insertions(+), 19 deletions(-) diff --git a/inferno-vc/CHANGELOG.md b/inferno-vc/CHANGELOG.md index 96af0f3..aae8b13 100644 --- a/inferno-vc/CHANGELOG.md +++ b/inferno-vc/CHANGELOG.md @@ -1,6 +1,11 @@ # Revision History for inferno-vc *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.3.4.0 -- 2024-02-28 +* Add a parameter to runServerConfig to allow wai middleware to be applied +* Extend VCServerError type with a constructor for storage bakcend to inject + their errors + ## 0.3.3.0 -- 2024-01-09 * Add some tests for `fetchFunctionsForGroups` that should have caught recent bug in Cardith backend diff --git a/inferno-vc/inferno-vc.cabal b/inferno-vc/inferno-vc.cabal index 6ed01e4..2c82705 100644 --- a/inferno-vc/inferno-vc.cabal +++ b/inferno-vc/inferno-vc.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: inferno-vc -version: 0.3.3.0 +version: 0.3.4.0 synopsis: Version control server for Inferno description: A version control server for Inferno scripts category: DSL,Scripting diff --git a/inferno-vc/src/Inferno/VersionControl/Client.hs b/inferno-vc/src/Inferno/VersionControl/Client.hs index 64c51e8..3986ab7 100644 --- a/inferno-vc/src/Inferno/VersionControl/Client.hs +++ b/inferno-vc/src/Inferno/VersionControl/Client.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} module Inferno.VersionControl.Client where @@ -17,14 +15,14 @@ import Servant.Client (BaseUrl, Client, ClientEnv, ClientM, client, mkClientEnv) import Servant.Typed.Error (TypedClientM) mkVCClientEnv :: Manager -> BaseUrl -> ClientEnv -mkVCClientEnv man@Manager {mModifyRequest = modReq} baseUrl = - mkClientEnv man {mModifyRequest = modReq'} baseUrl +mkVCClientEnv man@Manager {mModifyRequest = modReq} = + mkClientEnv man {mModifyRequest = modReq'} where modReq' :: Request -> IO Request modReq' r = do x <- modReq r pure $ - if ((hContentEncoding, "gzip") `elem` requestHeaders x) + if (hContentEncoding, "gzip") `elem` requestHeaders x then x else let new_hdrs = (hContentEncoding, "gzip") : requestHeaders x @@ -42,7 +40,7 @@ mkVCClientEnv man@Manager {mModifyRequest = modReq} baseUrl = RequestBodyIO iob -> RequestBodyIO $ compressBody <$> iob b -> b -api :: Proxy (VersionControlAPI a g) +api :: forall a g. Proxy (VersionControlAPI a g) api = Proxy infernoVcClient :: (FromJSON a, FromJSON g, ToJSON a, ToJSON g) => Client ClientM (VersionControlAPI a g) diff --git a/inferno-vc/src/Inferno/VersionControl/Log.hs b/inferno-vc/src/Inferno/VersionControl/Log.hs index 0672f5e..5f76a87 100644 --- a/inferno-vc/src/Inferno/VersionControl/Log.hs +++ b/inferno-vc/src/Inferno/VersionControl/Log.hs @@ -7,6 +7,7 @@ import Inferno.VersionControl.Operations.Error (VCStoreError, vcStoreErrorToStri data VCServerTrace = ThrownVCStoreError VCStoreError + | ThrownVCOtherError Text | WriteJSON FilePath | WriteTxt FilePath | AlreadyExistsJSON FilePath @@ -22,4 +23,5 @@ vcServerTraceToText = \case ReadJSON fp -> "Reading JSON at: " <> pack fp ReadTxt fp -> "Reading TXT at: " <> pack fp ThrownVCStoreError e -> pack (vcStoreErrorToString e) + ThrownVCOtherError e -> "Other server error: " <> e DeleteFile fp -> "Deleting file: " <> pack fp diff --git a/inferno-vc/src/Inferno/VersionControl/Operations.hs b/inferno-vc/src/Inferno/VersionControl/Operations.hs index e348871..b1a1703 100644 --- a/inferno-vc/src/Inferno/VersionControl/Operations.hs +++ b/inferno-vc/src/Inferno/VersionControl/Operations.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -7,14 +8,17 @@ -- This module defines operations on the Inferno VC store. module Inferno.VersionControl.Operations ( InfernoVCOperations (..), + throwTyped, ) where +import Control.Monad.Error.Lens (throwing) import Control.Monad.Except (MonadError) -import Data.Generics.Sum (AsType) +import Data.Generics.Sum (AsType (..)) import Data.Kind (Type) import qualified Data.Set as Set import Data.Time.Clock.POSIX (POSIXTime) +import Inferno.Types.Syntax (getDependencies) import Inferno.VersionControl.Operations.Error (VCStoreError) import Inferno.VersionControl.Types ( VCHashUpdate, @@ -61,6 +65,11 @@ class -- | Fetch all dependencies of an object. fetchVCObjectClosureHashes :: VCObjectHash -> m [VCObjectHash] + fetchVCObjectClosureHashes h0 = fmap (Set.toList . Set.delete h0) . go $ h0 + where + go h = do + o <- fetchVCObject h + mconcat . (Set.singleton h :) <$> mapM go (Set.toList (getDependencies (obj o))) -- | Retrieves the full history of the chain which the given hash belongs to. -- History is given from newest (head) to oldest (root) @@ -75,3 +84,6 @@ class -- | Delete all auto-saved objects older than a given time deleteAutosavedVCObjectsOlderThan :: POSIXTime -> m () + +throwTyped :: forall e err m x. (MonadError err m, AsType e err) => e -> m x +throwTyped = throwing _Typed diff --git a/inferno-vc/src/Inferno/VersionControl/Server.hs b/inferno-vc/src/Inferno/VersionControl/Server.hs index 8b41637..7976cf6 100644 --- a/inferno-vc/src/Inferno/VersionControl/Server.hs +++ b/inferno-vc/src/Inferno/VersionControl/Server.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,6 +19,7 @@ where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (link, withAsync) +import Control.Exception (Exception) import Control.Lens (to, (^.)) import Control.Monad (forM, forever) import Control.Monad.Except (ExceptT, runExceptT, throwError) @@ -36,7 +36,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import GHC.Generics (Generic) import Inferno.Types.Syntax (Expr) import Inferno.Types.Type (TCScheme) -import Inferno.VersionControl.Log (VCServerTrace (ThrownVCStoreError), vcServerTraceToText) +import Inferno.VersionControl.Log (VCServerTrace (ThrownVCOtherError, ThrownVCStoreError), vcServerTraceToText) import qualified Inferno.VersionControl.Operations as Ops import qualified Inferno.VersionControl.Operations.Error as Ops import Inferno.VersionControl.Server.Types (readServerConfig) @@ -49,6 +49,7 @@ import Inferno.VersionControl.Types VCObjectHash, showVCObjectType, ) +import Network.Wai (Middleware) import Network.Wai.Handler.Warp ( defaultSettings, runSettings, @@ -68,9 +69,11 @@ import Servant.Typed.Error liftTypedError, ) -newtype VCServerError = VCServerError {serverError :: Ops.VCStoreError} +data VCServerError + = VCServerError {serverError :: Ops.VCStoreError} + | VCOtherError {otherError :: T.Text} deriving (Generic, Show) - deriving newtype (ToJSON, FromJSON) + deriving anyclass (ToJSON, FromJSON, Exception) type GetThrowingVCStoreError resp ty = GetTypedError resp ty VCServerError @@ -117,7 +120,7 @@ vcServer toHandler = pushFunctionH meta@VCMeta {obj = (f, t)} = Ops.storeVCObject meta {obj = VCFunction f t} fetchVCObjects hs = - Map.fromList <$> (forM hs $ \h -> (h,) <$> Ops.fetchVCObject h) + Map.fromList <$> forM hs (\h -> (h,) <$> Ops.fetchVCObject h) runServer :: forall m env config. @@ -138,7 +141,7 @@ runServer :: runServer withEnv runOp = do readServerConfig "config.yml" >>= \case Left err -> putStrLn err - Right serverConfig -> runServerConfig withEnv runOp serverConfig + Right serverConfig -> runServerConfig (const id) withEnv runOp serverConfig runServerConfig :: forall m env config. @@ -152,11 +155,12 @@ runServerConfig :: ToJSON (Ops.Group m), Ops.InfernoVCOperations VCServerError m ) => + (env -> Middleware) -> (forall x. config -> IOTracer T.Text -> (env -> IO x) -> IO x) -> (forall x. m x -> env -> ExceptT VCServerError IO x) -> config -> IO () -runServerConfig withEnv runOp serverConfig = do +runServerConfig middleware withEnv runOp serverConfig = do let host = serverConfig ^. the @"serverHost" . to T.unpack . to fromString port = serverConfig ^. the @"serverPort" settingsWithTimeout = setTimeout 300 defaultSettings @@ -170,6 +174,8 @@ runServerConfig withEnv runOp serverConfig = do runExceptT (runOp (Ops.deleteAutosavedVCObjectsOlderThan cutoff) env) >>= \case Left (VCServerError {serverError}) -> traceWith @IOTracer serverTracer (ThrownVCStoreError serverError) + Left (VCOtherError {otherError}) -> + traceWith @IOTracer serverTracer (ThrownVCOtherError otherError) Right _ -> pure () print ("running..." :: String) -- Cleanup stale autosave scripts in a separate thread every hour: @@ -178,8 +184,9 @@ runServerConfig withEnv runOp serverConfig = do runSettings (setPort port $ setHost host settingsWithTimeout) $ ungzipRequest $ gzip def $ - serve (Proxy :: Proxy (VersionControlAPI a g)) $ - vcServer (liftIO . liftTypedError . flip runOp env) + middleware env $ + serve (Proxy :: Proxy (VersionControlAPI a g)) $ + vcServer (liftIO . liftTypedError . flip runOp env) withLinkedAsync_ :: IO a -> IO b -> IO b withLinkedAsync_ f g = withAsync f $ \h -> link h >> g diff --git a/inferno-vc/test/Spec.hs b/inferno-vc/test/Spec.hs index c106464..fab57d4 100644 --- a/inferno-vc/test/Spec.hs +++ b/inferno-vc/test/Spec.hs @@ -15,12 +15,12 @@ import Test.Hspec main :: IO () main = withSystemTempDirectory "vc_store_" $ \vcPath -> do - putStrLn $ "Store is at: " ++ (show vcPath) - + putStrLn $ "Store is at: " ++ show vcPath putStr "Starting Inferno VC..." _ <- forkIO $ runServerConfig + (const id) FSOps.withEnv (FSOps.runInfernoVCFilesystemM @Int @Int) ServerConfig