63 lines
2.1 KiB
Haskell
63 lines
2.1 KiB
Haskell
module Feed.V1.Server (mkServer) where
|
|
|
|
import Relude hiding (runReader)
|
|
import Relude.Extra.Tuple (fmapToSnd)
|
|
|
|
import Api.V1.Types
|
|
import Data.Cache (newCache)
|
|
import Data.List (isSuffixOf)
|
|
import Feed.V1.Core (App)
|
|
import Feed.V1.Section (feedSectionCached)
|
|
import Feed.V1.Spec (FeedApi, feedApi)
|
|
import Feed.V1.Topic (feedTopicCached)
|
|
import Polysemy (embedToFinal, raiseUnder, runFinal)
|
|
import Polysemy.Embed (runEmbedded)
|
|
import Polysemy.Error (runError)
|
|
import Network.HTTP.Client qualified as Http
|
|
import Polysemy.Reader (runReader)
|
|
import Servant.API ((:<|>) ((:<|>)))
|
|
import Servant.Client.Streaming
|
|
import Servant.Polysemy.Client (runServantClientWith)
|
|
import Servant.Server
|
|
import System.Clock
|
|
|
|
defProxy :: Http.Proxy
|
|
defProxy = Http.Proxy "127.0.0.1" 4444
|
|
|
|
server :: ServerT FeedApi App
|
|
server = feedTopicCached . GetTopic :<|> feedSectionCached
|
|
|
|
mkServer :: IO (Server FeedApi)
|
|
mkServer = do
|
|
let cacheVarName = "4R_FEED_CACHE"
|
|
secMbRaw <- lookupEnv cacheVarName
|
|
sec <- case readEither `fmapToSnd` secMbRaw of
|
|
Nothing -> pure 3600
|
|
Just (_, Right ok) -> pure ok
|
|
Just (secRaw, Left e) -> fail $ "Failed to parse " <> cacheVarName <> "=" <> secRaw <> ": " <> toString e
|
|
cache <- newCache $ Just TimeSpec{nsec = 0, sec}
|
|
|
|
baseUrl <- lookupEnv "4RUM_BASE_URL" >>= maybe (pure (BaseUrl Http "4rum.i2p" 80 "")) parseBaseUrl
|
|
clientEnv <- do
|
|
manager' <-
|
|
liftIO $
|
|
Http.newManager $
|
|
Http.defaultManagerSettings
|
|
& if ".i2p" `isSuffixOf` baseUrl.baseUrlHost
|
|
then Http.managerSetProxy $ Http.proxyEnvironmentNamed "I2P_HTTP_PROXY" $ Just defProxy
|
|
else id
|
|
pure $ mkClientEnv manager' baseUrl
|
|
|
|
let interpreter :: App a -> Handler a
|
|
interpreter =
|
|
runReader cache
|
|
>>> raiseUnder
|
|
>>> runServantClientWith clientEnv
|
|
>>> runError
|
|
>>> (>>= either (error . (show :: ClientError -> Text)) pure)
|
|
>>> raiseUnder
|
|
>>> runEmbedded (liftIO @Handler)
|
|
>>> embedToFinal @Handler
|
|
>>> runFinal
|
|
pure $ hoistServer feedApi interpreter server
|