Servant with Polysemy

polyservant.hs

{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |

module Main where

import           Data.Aeson
import qualified Data.Text as T
import           Polysemy  (embed, Members, Sem, Member, Embed, interpret, runM, makeSem)
import           Polysemy.IO
import           GHC.Generics                (Generic)
import           Polysemy.Reader (Reader, runReader, ask)
import           Network.Wai.Handler.Warp    (run)
import           Servant  

newtype Name = Name T.Text
  deriving (Show, Generic)

instance FromJSON Name
instance ToJSON Name


data Config = Config { name :: T.Text }



data Logger m a where
  Loggit :: String -> Logger m ()

makeSem ''Logger


runLogger :: Member (Embed IO) r => Sem (Logger ': r) a -> Sem r a
runLogger = interpret $ \case
  Loggit msg -> do
    embed $ putStrLn msg


type Api = "name" :> Get '[JSON] Name
           :<|> "name" :> ReqBody '[JSON] Name :> Post '[JSON] Name


routes :: Proxy Api
routes = Proxy


server :: Members '[Reader Config, Logger] r
       => ServerT Api (Sem r)
server = get :<|> post
  where
    get :: Members '[Reader Config, Logger] r => Sem r (Name)
    get = do
      loggit "Get da ponk"
      c <- ask
      return $ Name (name c)

    post :: Member (Logger) r => Name -> Sem r (Name)
    post ook = do
      loggit "Set da ponk"
      return $ Name "yay"



nt :: Sem '[Reader Config, Logger, Embed IO, Embed Handler] x
   -> Servant.Handler x
nt m = runM $ embedToMonadIO @Servant.Handler $ runLogger $ runReader (Config { name = "ook" } ) m



mainServer :: ServerT Api Servant.Handler
mainServer = hoistServer routes nt server


app :: Application
app = serve routes mainServer
 
main :: IO ()
main = do
  putStrLn "Starting on 3000"
  run 3000 app