kv-servant-server.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

import Control.Concurrent.STM (atomically, modifyTVar, newTVarIO, readTVarIO)
import Control.Monad.IO.Class (liftIO)
import GHC.TypeLits (SomeSymbol (..), Symbol, someSymbolVal)
import Network.Wai.Handler.Warp (run)
import Servant (HasServer, Proxy (..), Server, serve)
import Servant.API (Capture, Get, NoContent (..), PlainText, (:<|>) (..), (:>))

data SomeServer
  = forall api. HasServer api '[] => SomeServer (Proxy api) (Server api)

type SetAPI =
  "set" :> Capture "key" String :> Capture "value" String :> Get '[PlainText] NoContent

type GetAPI (key :: Symbol) =
  "get" :> key :> Get '[PlainText] String

setServer :: ((SomeServer -> SomeServer) -> IO ()) -> SomeServer
setServer modifyServer = SomeServer (Proxy @SetAPI) \key value -> do
  liftIO do modifyServer (withGetHandler key value)
  pure NoContent

withGetHandler :: String -> String -> SomeServer -> SomeServer
withGetHandler key value (SomeServer (Proxy :: Proxy api) handler) =
  case someSymbolVal key of
    SomeSymbol (Proxy :: Proxy key) ->
      SomeServer (Proxy @(GetAPI key :<|> api)) (pure value :<|> handler)

main :: IO ()
main = mdo
  serverVar <- newTVarIO (setServer (atomically . modifyTVar serverVar))
  run 8080 \req respond -> do
    SomeServer api handler <- readTVarIO serverVar
    serve api handler req respond

package.yaml

name: erlchat-test

dependencies:
  - base >= 4.12 && < 5
  - servant
  - servant-server
  - warp
  - stm

executables:
  erlchat-test:
    main: Main.hs