I was able to sit down this morning and extract an example of what I’m trying to do without too much extraneous stuff included.
Servant is responsible for making the backend API available and there’s a frontend using Hyperbole . What I’d like to do is get the site being served with the Raw endpoint up and running with access to the Env record like the jwks endpoint
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Monad.Reader ( asks, ReaderT(runReaderT) )
import Crypto.JOSE.JWK ( JWKSet )
import Data.Aeson as A ( decode )
import Data.ByteString.Lazy.UTF8 ( fromString )
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T (pack)
import Data.Text.IO as TIO ( putStrLn )
import Effectful ( type (:>) )
import Network.Wai ( Request, Application )
import Network.Wai.Handler.Warp (run)
import Safe (readMay)
import Servant
( type (:>),
Context((:.), EmptyContext),
GenericMode(type (:-)),
serveDirectoryWebApp,
JSON,
Raw,
RawM,
Get,
Handler )
import Servant.API.Generic (Generic)
import Servant.Server.Generic
( genericServeTWithContext, AsServerT )
import System.Environment qualified as SE
( getArgs
, lookupEnv
)
import System.Exit ( exitWith, ExitCode(ExitFailure) )
import System.IO
( stdout, hSetBuffering, BufferMode(LineBuffering) )
import Web.Atomic.CSS ( Styleable((~)), gap )
import Web.Hyperbole
( HyperView (..)
, Hyperbole
, Page
, View
, ViewAction
, ViewId
, button
, col
, el
, hyper
, liveApp
, quickStartDocument
, row
, runPage
, text
)
--------------------------------------------------------------------------------
-- | https://github.com/haskell-servant/servant/issues/1466#issue-1022726666
infix 0 `As`
type As api mode = mode :- api
--------------------------------------------------------------------------------
-- | Primary router. Controls the delegation to subApis for Hyperbole and Servant
data Routes mode = Routes
{ icon ::
-- \| Static folder for favicon
"icon"
Servant.:> Raw
`As` mode
, jwks ::
-- \| Serve jwks endpoint
"jwks"
Servant.:> Get '[JSON] JWKSet
`As` mode
, newSite ::
"newsite"
Servant.:> RawM
`As` mode
, hyperSite ::
-- \| Delegates to Hyperbole router
"site"
Servant.:> Raw
`As` mode
}
deriving stock (Generic)
record :: Routes (AsServerT AppM)
record =
Routes
{ icon = serveDirectoryWebApp "icon"
, jwks = jwksServe
, newSite = undefined
, hyperSite = return appBase
}
--------------------------------------------------------------------------------
jwksServe :: AppM JWKSet
jwksServe = asks getJwks
--------------------------------------------------------------------------------
type AppM = ReaderT Env Handler
data AppConfig = AppConfig
{ pgpool :: Text
, baseDir :: FilePath
}
-- | Application environment
data Env = Env
{ env :: JWKSet
, req :: Request
, config :: AppConfig
}
getConfig :: Env -> AppConfig
getConfig Env{config = c} = c
getJwks :: Env -> JWKSet
getJwks Env{env = e} = e
getReq :: Env -> Request
getReq Env{req = r} = r
--------------------------------------------------------------------------------
-- | Natural transformation from AppM to Handler
nt :: Env -> AppM a -> Handler a
nt e appM = runReaderT appM e
--------------------------------------------------------------------------------
appBase :: Application
appBase = liveApp quickStartDocument $ runPage page
page :: (Hyperbole Effectful.:> es) => Page es '[Counter]
page = do
pure $ hyper Counter (viewCount 0)
data Counter = Counter
deriving (Generic, ViewId)
instance HyperView Counter es where
data Action Counter
= Increment Int
| Decrement Int
deriving (Generic, ViewAction)
update (Increment n) = do
pure $ viewCount (n + 1)
update (Decrement n) = do
pure $ viewCount (n - 1)
viewCount :: Int -> View Counter ()
viewCount n = row $ do
col ~ gap 10 $ do
el $ text $ T.pack $ show n
row ~ gap 10 $ do
button (Decrement n) "Decrement"
button (Increment n) "Increment"
--------------------------------------------------------------------------------
defaultPort :: Int
defaultPort = 3000
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
-- args <- SE.getArgs
port <- do
mStr <- SE.lookupEnv "PORT"
pure $ fromMaybe @Int defaultPort (readMay =<< mStr)
j <- do
jwkset <- SE.lookupEnv "JWKS_PUB"
case jwkset of
Nothing -> error "JWKS environment not detected"
Just js -> case (A.decode (fromString js) :: Maybe JWKSet) of
Nothing -> do
TIO.putStrLn $ T.pack "JWKSet could not be parsed"
exitWith $ ExitFailure 2
Just x -> pure x
let app req = do
--
let runtimeEnv =
Env
{ env = j
, req = req
, config = undefined
}
serverContext = env Servant.:. EmptyContext
genericServeTWithContext (nt runtimeEnv) record serverContext req
run port app
build-depends: base ^>=4.21.0.0
, aeson
, atomic-css
, effectful-core
, hyperbole
, jose
, mtl
, safe
, servant
, servant-multipart
, servant-server
, text
, utf8-string
, wai
, warp
This would be run by supplying a JWKS_PUB environment variable containing a list of public key material, but any JSON object will work. Ex. with nushell:
with-env { JWKS_PUB:'{
"keys": [
{
"e": "AQAB",
"kid": "2025-12-16 23:15:42.123230612 UTC",
"kty": "RSA",
"n": "xyz123"
}
]
}' } { cabal run }
)