[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

@@ -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
 

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

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)

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

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

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

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