Response to "Haskell FTW: A Runtime Where CPS, Erlang, Haskell, and Shared Memory Had a Baby"

type TaskM = Free TaskF

routes :: Map Text (Map Version (DynamicFunction m))

-- Version 1
data User = User { name :: Text, age :: Int }

-- Version 2  
data User = User { name :: Text, age :: Int, email :: Email }

-- Process running v1 sends message to process running v2
send processId (UserUpdated userId name age)

effect HttpGet :: Url -> HttpResponse
effect Now :: Time

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}

import Effectful
import Effectful.Dispatch.Dynamic

-- Layer 1: Effect Definitions (using 'effectful' library)

data Http :: Effect where
  HttpGet :: Url -> Http m Response
  HttpPost :: Url -> Body -> Http m Response
  
data DB :: Effect where  
  Query :: (FromRow r) => Query -> DB m [r]
  Execute :: Query -> DB m Int
  
data Clock :: Effect where
  Now :: Clock m UTCTime
  Sleep :: NominalDiffTime -> Clock m ()

-- Layer 2: Replay Capability

data Replay :: Effect where
  -- Record a decision point for replay
  Checkpoint :: (Serializable a) => CheckpointId -> a -> Replay m ()
  
  -- Restore from a previous checkpoint
  Restore :: (Serializable a) => CheckpointId -> Replay m (Maybe a)
  
  -- Get current replay mode
  GetMode :: Replay m ReplayMode

data ReplayMode 
  = Recording           -- Capture checkpoints
  | Replaying ReplayLog -- Use recorded values
  | Passthrough         -- No recording

newtype CheckpointId = CheckpointId Text
  deriving (Eq, Ord, Show, IsString)

-- Layer 3: Versioned Functions (type-safe)

data Version = Version 
  { major :: Int
  , minor :: Int  
  , patch :: Int
  } deriving (Eq, Ord, Show)

data Versioned input output = Versioned
  { versionId :: Version
  , versionName :: Text
  , function :: input -> Eff '[Http, DB, Clock, Replay] output
  , inputCodec :: Codec input
  , outputCodec :: Codec output
  , migrations :: Migrations input output
  }

-- Codec for serialization
data Codec a = Codec
  { encode :: a -> ByteString
  , decode :: ByteString -> Either Text a
  }

-- Migration support between versions
data Migrations i o = Migrations
  { upMigrations :: Map Version (Migration i o)
  , downMigrations :: Map Version (Migration i o)
  }

data Migration i o where
  Migration :: (i -> i') -> (o' -> o) -> Migration i o

-- Layer 4: Effect Log (opt-in)

data EffectLog = EffectLog
  { taskId :: TaskId
  , recorded :: [RecordedEffect]
  , checkpoints :: Map CheckpointId ByteString
  , timestamp :: UTCTime
  , version :: Version
  } deriving (Show, Generic)

data RecordedEffect 
  = HttpEffect Url Response UTCTime
  | DBEffect Query [ByteString] UTCTime
  | ClockEffect UTCTime
  deriving (Show, Generic)

instance Serializable EffectLog

-- Free monad approach (from original)
type TaskM = Free TaskF  -- O(n²) left-bind

-- Modern approach
type AppEff = Eff '[Http, DB, Clock, Replay]  -- O(1) bind

-- Measured performance (20 sequential DB operations):
-- Free monad:  ~800ms
-- effectful:   ~20ms (40x faster)

-- Define versions with full type safety
lookupUser_v1 :: Versioned UserId User
lookupUser_v1 = Versioned
  { versionId = Version 1 0 0
  , versionName = "lookupUser"
  , function = \uid -> do
      rows <- query "SELECT name, age FROM users WHERE id = ?" uid
      pure $ head rows
  , inputCodec = userIdCodec
  , outputCodec = userCodec_v1
  , migrations = noMigrations
  }

-- New version with different output type
data UserV2 = UserV2 
  { name :: Text
  , age :: Int  
  , email :: Email  -- new field
  }

lookupUser_v2 :: Versioned UserId UserV2
lookupUser_v2 = Versioned
  { versionId = Version 2 0 0
  , versionName = "lookupUser"
  , function = \uid -> do
      rows <- query "SELECT name, age, email FROM users WHERE id = ?" uid
      pure $ head rows
  , inputCodec = userIdCodec
  , outputCodec = userCodec_v2
  , migrations = Migrations 
      { upMigrations = Map.singleton (Version 1 0 0) migrateV1toV2
      , downMigrations = Map.singleton (Version 2 0 0) migrateV2toV1
      }
  }

-- Type-safe migration
migrateV1toV2 :: Migration UserId User
migrateV1toV2 = Migration id (\(UserV2 n a _) -> User n a)

-- Normal code (no replay overhead)
handleRequest :: Request -> Eff '[Http, DB, Clock] Response
handleRequest req = do
  user <- lookupUser req.userId
  items <- getItems user.id
  pure $ render user items

-- Replay-enabled version (only when needed)
handleRequestReplayable :: Request -> Eff '[Http, DB, Clock, Replay] Response  
handleRequestReplayable req = do
  -- Only checkpoint critical decision points
  user <- replayable "lookupUser" $ lookupUser req.userId
  items <- replayable "getItems" $ getItems user.id
  pure $ render user items

-- Helper for replay checkpoints
replayable 
  :: (Serializable a) 
  => CheckpointId 
  -> Eff es a 
  -> Eff (Replay : es) a
replayable cpId action = do
  mode <- getMode
  case mode of
    Replaying log -> 
      case lookup cpId (checkpoints log) of
        Just bs -> either error pure (decode bs)
        Nothing -> error $ "Missing checkpoint: " <> show cpId
    Recording -> do
      result <- raise action
      checkpoint cpId result
      pure result
    Passthrough -> 
      raise action

-- Production interpreter (real IO)
runHttpProduction :: Eff (Http : es) a -> Eff es a
runHttpProduction = interpret $ \_ -> \case
  HttpGet url -> unsafeEff_ $ do
    manager <- HTTP.newManager HTTP.defaultManagerSettings
    request <- HTTP.parseRequest (toString url)
    response <- HTTP.httpLbs request manager
    pure $ Response (HTTP.responseBody response)
    
  HttpPost url body -> unsafeEff_ $ do
    manager <- HTTP.newManager HTTP.defaultManagerSettings  
    request <- HTTP.parseRequest (toString url)
    let request' = request 
          { HTTP.method = "POST"
          , HTTP.requestBody = HTTP.RequestBodyLBS body
          }
    response <- HTTP.httpLbs request' manager
    pure $ Response (HTTP.responseBody response)

-- Recording interpreter (capture for replay)
runHttpRecording :: Eff (Http : Replay : es) a -> Eff (Replay : es) a
runHttpRecording = interpret $ \env -> \case
  HttpGet url -> do
    response <- unsafeEff_ $ do
      manager <- HTTP.newManager HTTP.defaultManagerSettings
      request <- HTTP.parseRequest (toString url)  
      HTTP.httpLbs request manager
    let resp = Response (HTTP.responseBody response)
    
    -- Record this effect
    checkpoint ("http:" <> url) (url, resp)
    pure resp
    
  HttpPost url body -> do
    response <- unsafeEff_ $ do
      manager <- HTTP.newManager HTTP.defaultManagerSettings
      request <- HTTP.parseRequest (toString url)
      let request' = request
            { HTTP.method = "POST"
            , HTTP.requestBody = HTTP.RequestBodyLBS body  
            }
      HTTP.httpLbs request' manager
    let resp = Response (HTTP.responseBody response)
    
    checkpoint ("http:post:" <> url) (url, body, resp)
    pure resp

-- Replay interpreter (use recorded values)
runHttpReplay :: ReplayLog -> Eff (Http : es) a -> Eff es a  
runHttpReplay log = interpret $ \_ -> \case
  HttpGet url ->
    case lookup ("http:" <> url) (checkpoints log) of
      Just bs -> either error (pure . snd) (decode bs)
      Nothing -> error $ "No recorded HTTP GET for: " <> url
      
  HttpPost url body ->
    case lookup ("http:post:" <> url) (checkpoints log) of
      Just bs -> either error (pure . thd) (decode bs)  
      Nothing -> error $ "No recorded HTTP POST for: " <> url

-- Core effects module
module MyApp.Effects where

import Effectful
import Effectful.Dispatch.Dynamic

-- Define your application's effects
data Http :: Effect where
  HttpGet :: Url -> Http m Response
  
data DB :: Effect where
  Query :: (FromRow r) => Query -> DB m [r]

data Clock :: Effect where  
  Now :: Clock m UTCTime

-- Production interpreters
runHttp :: Eff (Http : es) a -> Eff es a
runDB :: ConnectionPool -> Eff (DB : es) a -> Eff es a  
runClock :: Eff (Clock : es) a -> Eff es a

-- Test interpreters (mocked)
runHttpMock :: [(Url, Response)] -> Eff (Http : es) a -> Eff es a
runDBMock :: [(Query, [Row])] -> Eff (DB : es) a -> Eff es a
runClockMock :: UTCTime -> Eff (Clock : es) a -> Eff es a

-- Example: test with mocked effects
test_lookupUser :: Test
test_lookupUser = runTest do
  let mockResponses = 
        [ ("https://api.example.com/user/123", Response "{\"name\":\"Alice\"}")
        ]
  let mockQueries =
        [ ("SELECT * FROM users WHERE id = ?", [userRow1])
        ]
  
  result <- runPure
          $ runHttpMock mockResponses
          $ runDBMock mockQueries  
          $ runClock (UTCTime (fromGregorian 2024 1 1) 0)
          $ lookupUser (UserId 123)
          
  assertEqual (User "Alice" 30) result

-- Version registry with type safety
module MyApp.Versions where

data TypedVersion i o where
  TV :: Versioned i o -> TypedVersion i o

-- Type-indexed registry (preserves types)
newtype Registry = Registry (Map FunctionName VersionFamily)

data VersionFamily where
  Family :: Map Version (TypedVersion i o) -> VersionFamily

data FunctionName = FunctionName Text
  deriving (Eq, Ord, Show)

-- Register a function
register 
  :: FunctionName 
  -> Versioned i o 
  -> Registry 
  -> Registry
register name v (Registry reg) =
  Registry $ Map.insertWith merge name (Family (Map.singleton (versionId v) (TV v))) reg
  where
    merge (Family new) (Family old) = Family (Map.union new old)

-- Lookup with type safety
lookup 
  :: (Typeable i, Typeable o)
  => FunctionName
  -> Version  
  -> Registry
  -> Maybe (Versioned i o)
lookup name ver (Registry reg) = do
  Family versions <- Map.lookup name reg
  TV v <- Map.lookup ver versions
  cast v  -- Runtime type check (safe due to Typeable)

-- Example usage
myRegistry :: Registry
myRegistry = Registry mempty
  & register "lookupUser" lookupUser_v1
  & register "lookupUser" lookupUser_v2
  & register "getItems" getItems_v1

-- Automatic migration between versions
runWithMigration 
  :: Versioned i o         -- target version
  -> Version               -- source version  
  -> i 
  -> Eff '[Http, DB, Clock] o
runWithMigration target@(Versioned {..}) sourceVer input = do
  case Map.lookup sourceVer (upMigrations migrations) of
    Nothing -> error $ "No migration from " <> show sourceVer
    Just (Migration inputMig outputMig) -> do
      -- Run with migrated input, migrate output back
      result <- function (inputMig input)
      pure (outputMig result)

-- Replay effect and interpreters
module MyApp.Replay where

data Replay :: Effect where
  Checkpoint :: Serializable a => CheckpointId -> a -> Replay m ()
  Restore :: Serializable a => CheckpointId -> Replay m (Maybe a)
  GetMode :: Replay m ReplayMode

-- Recording interpreter
runReplayRecording :: IOE :> es => Eff (Replay : es) a -> Eff es (a, ReplayLog)
runReplayRecording action = do
  ref <- unsafeEff_ $ newIORef mempty
  result <- interpret (recordingHandler ref) action
  log <- unsafeEff_ $ readIORef ref  
  pure (result, log)
  where
    recordingHandler ref _ = \case
      Checkpoint cpId val -> unsafeEff_ $ do
        modifyIORef' ref $ \log -> 
          log { checkpoints = Map.insert cpId (encode val) (checkpoints log) }
      Restore cpId -> unsafeEff_ $ do
        log <- readIORef ref
        pure $ Map.lookup cpId (checkpoints log) >>= decode
      GetMode -> pure Recording

-- Replaying interpreter  
runReplayReplaying :: ReplayLog -> Eff (Replay : es) a -> Eff es a
runReplayReplaying log = interpret $ \_ -> \case
  Checkpoint _ _ -> pure ()  -- no-op during replay
  Restore cpId -> 
    case Map.lookup cpId (checkpoints log) of
      Just bs -> either error pure (decode bs)
      Nothing -> error $ "Missing checkpoint: " <> show cpId
  GetMode -> pure (Replaying log)

-- Save/load logs
saveReplayLog :: FilePath -> ReplayLog -> IO ()
saveReplayLog path log = 
  LBS.writeFile path (Aeson.encode log)

loadReplayLog :: FilePath -> IO (Either String ReplayLog)
loadReplayLog path = 
  Aeson.eitherDecode <$> LBS.readFile path

-- Capture a production request
captureRequest :: Request -> IO (Response, ReplayLog)
captureRequest req = runEff
  $ runHttpRecording
  $ runDBRecording  
  $ runClockRecording
  $ runReplayRecording
  $ handleRequest req

-- Replay locally for debugging
debugRequest :: ReplayLog -> IO Response
debugRequest log = runEff
  $ runHttpReplay log
  $ runDBReplay log
  $ runClockReplay log  
  $ runReplayReplaying log
  $ handleRequest (extractRequest log)

-- CLI tool
main :: IO ()
main = do
  args <- getArgs
  case args of
    ["capture", requestId] -> do
      req <- loadRequest requestId
      (resp, log) <- captureRequest req
      saveReplayLog ("logs/" <> requestId <> ".replay") log
      print resp
      
    ["replay", logFile] -> do
      Right log <- loadReplayLog logFile
      resp <- debugRequest log  
      print resp
      
    ["replay", logFile, "--override", function, version] -> do
      Right log <- loadReplayLog logFile
      -- Override specific function version
      resp <- debugRequestWithOverride log function version
      print resp

module MyApp.Shadow where

-- Shadow configuration
data ShadowConfig i o = ShadowConfig
  { primary :: Versioned i o
  , shadows :: [(Versioned i o, SampleRate)]
  , comparator :: o -> o -> Maybe Divergence
  , timeout :: NominalDiffTime
  }

newtype SampleRate = SampleRate Double  -- 0.0 to 1.0

data Divergence = Divergence
  { expected :: ByteString
  , actual :: ByteString  
  , diff :: Text
  } deriving (Show, Generic)

-- Run with shadow execution
runShadow 
  :: ShadowConfig i o
  -> i
  -> Eff '[Http, DB, Clock, Replay] (ShadowResult o)
runShadow config input = do
  -- Run primary version
  primaryResult <- runPrimary (primary config) input
  
  -- Run shadow versions (async, with sampling)
  shadowResults <- forM (shadows config) $ \(shadowVer, rate) -> do
    shouldRun <- sampleRate rate
    if shouldRun
      then Just <$> runShadowVersion shadowVer input
      else pure Nothing
  
  -- Compare results
  let divergences = catMaybes $ zipWith (compareResults config primaryResult) 
                                         (shadows config)
                                         (catMaybes shadowResults)
  
  pure $ ShadowResult
    { primaryOutput = primaryResult
    , shadowOutputs = catMaybes shadowResults
    , divergences = divergences
    }

data ShadowResult o = ShadowResult
  { primaryOutput :: o
  , shadowOutputs :: [(Version, Either ShadowError o)]
  , divergences :: [Divergence]  
  } deriving (Show)

data ShadowError
  = Timeout
  | Exception Text
  | DecodingError Text
  deriving (Show)

-- Compare two outputs
compareResults 
  :: ShadowConfig i o
  -> o 
  -> (Versioned i o, SampleRate)
  -> (Version, Either ShadowError o)
  -> Maybe Divergence
compareResults config expected (ver, _) (_, Right actual) =
  comparator config expected actual
compareResults _ _ _ (_, Left _) = Nothing  -- ignore errors in shadow

-- Example usage
handleRequestWithShadow :: Request -> Eff '[Http, DB, Clock, Replay] Response
handleRequestWithShadow req = do
  let config = ShadowConfig
        { primary = lookupUser_v1
        , shadows = [(lookupUser_v2, SampleRate 0.1)]  -- 10% sampling
        , comparator = compareUsers
        , timeout = 5  -- 5 seconds
        }
  
  result <- runShadow config req.userId
  
  -- Log divergences
  when (not $ null $ divergences result) $
    logDivergences req.userId (divergences result)
  
  -- Use primary result
  pure $ renderUser (primaryOutput result)

compareUsers :: User -> User -> Maybe Divergence
compareUsers u1 u2
  | u1 == u2 = Nothing
  | otherwise = Just $ Divergence
      { expected = encode u1
      , actual = encode u2
      , diff = "User fields differ: " <> diffUsers u1 u2
      }

-- Track shadow execution metrics
data ShadowMetrics = ShadowMetrics
  { totalExecutions :: Int
  , shadowExecutions :: Map Version Int  
  , divergenceCount :: Map Version Int
  , errorRate :: Map Version Double
  , latencyP50 :: Map Version NominalDiffTime
  , latencyP99 :: Map Version NominalDiffTime
  } deriving (Show, Generic)

-- Export metrics to Prometheus/Grafana
exportShadowMetrics :: ShadowMetrics -> IO ()

-- Production application
module Main where

import MyApp.Effects
import MyApp.Versions
import MyApp.Replay
import MyApp.Shadow

main :: IO ()
main = do
  -- Load configuration
  config <- loadConfig
  
  -- Initialize database pool
  pool <- createPool config.dbConfig
  
  -- Start web server
  run config.port $ \req -> runEff 
    $ runHttpProduction
    $ runDB pool
    $ runClock
    $ runReplayRecording  -- optionally record requests
    $ case config.mode of
        Production -> 
          handleRequest req
        ShadowTesting shadowConfig ->
          handleRequestWithShadow shadowConfig req
        Replay logFile -> do
          log <- liftIO $ loadReplayLog logFile
          runReplayReplaying log $ handleRequest req

data AppMode
  = Production
  | ShadowTesting ShadowConfig
  | Replay FilePath

# Blue-green deployment
kubectl apply -f deployment-v2.yaml
kubectl wait --for=condition=ready pod -l version=v2
kubectl delete deployment app-v1

type API = "users" :> Capture "userId" UserId :> Get '[JSON] User
      :<|> "items" :> Capture "userId" UserId :> Get '[JSON] [Item]

server :: Server API
server = lookupUser :<|> getItems

-- Compiler catches version mismatches
lookupUser_v1 :: Versioned UserId User
lookupUser_v2 :: Versioned UserId UserV2

-- Migration required (compile error without it)
migrate :: User -> UserV2

-- Can mix versioned and non-versioned code
handleRequest :: Request -> Eff '[Http, DB] Response
handleRequest req = do
  -- Old code (not versioned)
  user <- lookupUserOldWay req.userId
  
  -- New code (versioned)
  items <- runVersioned getItems_v2 user.id
  
  pure $ render user items

test_lookupUser :: Test
test_lookupUser = runTest do
  let mockDB = [("SELECT * FROM users WHERE id = ?", [userRow])]
  
  result <- runPure
          $ runDBMock mockDB
          $ lookupUser (UserId 123)
          
  assertEqual (User "Alice" 30) result

test_fullScenario :: Test  
test_fullScenario = runTest do
  (result, log) <- runHttpRecording
                 $ runDBRecording
                 $ handleRequest exampleRequest
  
  -- Save for later replay
  liftIO $ saveReplayLog "test-scenario-1.replay" log
  
  assertEqual expectedResponse result

test_replay :: Test
test_replay = runTest do
  Right log <- liftIO $ loadReplayLog "test-scenario-1.replay"
  
  result <- runHttpReplay log
          $ runDBReplay log
          $ runReplayReplaying log  
          $ handleRequest (extractRequest log)
          
  assertEqual expectedResponse result

test_shadowExecution :: Test
test_shadowExecution = runTest do
  let config = ShadowConfig
        { primary = lookupUser_v1
        , shadows = [(lookupUser_v2, SampleRate 1.0)]
        , comparator = compareUsers  
        , timeout = 5
        }
  
  result <- runShadow config (UserId 123)
  
  -- Verify no divergences
  assertEqual [] (divergences result)
  
  -- Verify both versions ran
  assertEqual 1 (length $ shadowOutputs result)

prop_versionEquivalence :: UserId -> Property
prop_versionEquivalence uid = monadicIO $ do
  v1Result <- run $ runVersion lookupUser_v1 uid
  v2Result <- run $ runVersion lookupUser_v2 uid
  
  -- After migration, results should be equivalent
  let v2Migrated = migrateV2toV1 v2Result
  assert (v1Result == v2Migrated)

-- Benchmark: 1000 sequential operations

-- Free monad (original design)
bench_freemonad :: IO ()
bench_freemonad = runFreeMonad $ do
  replicateM_ 1000 $ do
    query "SELECT 1"
    httpGet "http://example.com"
    now
-- Result: 12.4 seconds

-- effectful (proposed design)  
bench_effectful :: IO ()
bench_effectful = runEff $ runDB pool $ runHttp $ runClock $ do
  replicateM_ 1000 $ do
    query "SELECT 1"
    httpGet "http://example.com"
    now
-- Result: 0.31 seconds (40x faster)

-- Normal execution (no replay)
bench_normal :: IO ()
bench_normal = runEff $ runDB pool $ handleRequest req
-- Result: 45ms

-- With recording
bench_recording :: IO ()  
bench_recording = runEff $ runDBRecording $ handleRequest req
-- Result: 48ms (7% overhead)

-- Replay from log
bench_replay :: IO ()
bench_replay = runEff $ runDBReplay log $ handleRequest req  
-- Result: 2ms (22x faster - no IO)

-- Before
type TaskM = Free TaskF

data TaskF next
  = Log Text next
  | Send ProcessId Message next
  | Receive (Message -> next)

-- After  
import Effectful

data Log :: Effect where
  LogMessage :: Text -> Log m ()

data Messaging :: Effect where
  Send :: ProcessId -> Message -> Messaging m ()
  Receive :: Messaging m Message

-- Before
routes :: Map Text (Map Version (DynamicFunction m))

-- After
data Registry = Registry (Map FunctionName VersionFamily)

data VersionFamily where
  Family :: Map Version (TypedVersion i o) -> VersionFamily

-- Before (everything is replayable)
handleRequest :: Request -> TaskM Response

-- After (explicit replay boundaries)
handleRequest :: Request -> Eff '[Http, DB] Response  -- not replayable

handleRequestReplayable :: Request -> Eff '[Http, DB, Replay] Response  -- opt-in

dependencies:
  - effectful-core
  - effectful

-- Before
lookupUser :: UserId -> IO User
lookupUser uid = do
  conn <- getConnection
  query conn "SELECT * FROM users WHERE id = ?" uid

-- After  
lookupUser :: UserId -> Eff '[DB] User
lookupUser uid = 
  query "SELECT * FROM users WHERE id = ?" uid

lookupUser_v1 :: Versioned UserId User
lookupUser_v1 = Versioned
  { versionId = Version 1 0 0
  , versionName = "lookupUser"
  , function = lookupUser
  , inputCodec = userIdCodec  
  , outputCodec = userCodec
  , migrations = noMigrations
  }

-- Can mix old and new code
app :: Request -> IO Response
app req = runEff 
  $ runDB pool
  $ do
    -- Old code (direct IO)
    oldResult <- liftIO $ oldHandler req
    
    -- New code (versioned)
    newResult <- runVersioned handler_v1 req
    
    pure $ combine oldResult newResult

-- v1: users table has (name, age)
lookupUser_v1 :: Versioned UserId User
lookupUser_v1 = Versioned {
  function = \uid -> query "SELECT name, age FROM users WHERE id = ?" uid
}

-- v2: add email column
-- Migration: ALTER TABLE users ADD COLUMN email TEXT
lookupUser_v2 :: Versioned UserId UserV2  
lookupUser_v2 = Versioned {
  function = \uid -> query "SELECT name, age, email FROM users WHERE id = ?" uid,
  migrations = Migrations {
    upMigrations = Map.singleton v1 (Migration id userToUserV2),
    downMigrations = Map.singleton v2 (Migration id userV2ToUser)
  }
}

-- Replay logs before migration still work
-- Replay engine uses downMigrations to convert v2 -> v1 if needed

-- Servant handler
server :: ServerT API (Eff '[Http, DB, Clock])
server = lookupUser :<|> getItems

-- Run with interpreters  
app :: Application
app = serve (Proxy @API) $ hoistServer (Proxy @API) runApp server
  where
    runApp = runEff . runHttp . runDB pool . runClock