diff --git a/4r-feed/4r-feed.cabal b/4r-feed/4r-feed.cabal index 67a14cf..3e39df0 100644 --- a/4r-feed/4r-feed.cabal +++ b/4r-feed/4r-feed.cabal @@ -42,10 +42,16 @@ common c -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wmissing-export-lists -Wincomplete-record-updates -Wmissing-deriving-strategies + -O2 -threaded "-with-rtsopts=-I0 -N2" executable 4r-feed import: c main-is: Main.hs + other-modules: Feed.V1.Core + Feed.V1.Server + Feed.V1.Spec + Feed.V1.Topic + Servant.API.ContentTypes.AtomFeed hs-source-dirs: . build-depends: , 4r-api diff --git a/4r-feed/Feed/V1/Core.hs b/4r-feed/Feed/V1/Core.hs new file mode 100644 index 0000000..297bbc5 --- /dev/null +++ b/4r-feed/Feed/V1/Core.hs @@ -0,0 +1,15 @@ +module Feed.V1.Core (App, AppEnv(..)) where + +import Relude + +import Api.Types (Topic) +import Data.Cache (Cache) +import Servant.Client.Streaming +import Servant.Server + +type App = ReaderT AppEnv Handler + +data AppEnv = AppEnv + { clientEnv :: ClientEnv + , topicCache :: Cache Integer Topic + } diff --git a/4r-feed/Feed/V1/Server.hs b/4r-feed/Feed/V1/Server.hs new file mode 100644 index 0000000..66a0fa7 --- /dev/null +++ b/4r-feed/Feed/V1/Server.hs @@ -0,0 +1,40 @@ +module Feed.V1.Server (mkServer) where + +import Relude +import Relude.Extra.Tuple (fmapToSnd) + +import Data.Cache (newCache) +import Feed.V1.Core (App, AppEnv(..)) +import Feed.V1.Spec (FeedApi, feedApi) +import Feed.V1.Topic (feedTopicCached) +import Network.HTTP.Client qualified as Http +import Servant.Client.Streaming +import Servant.Server +import System.Clock + +defProxy :: Http.Proxy +defProxy = Http.Proxy "127.0.0.1" 4444 + +server :: ServerT FeedApi App +server = feedTopicCached + +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 + topicCache <- newCache $ Just TimeSpec{nsec = 0, sec} + + clientEnv <- do + manager' <- + liftIO $ + Http.newManager $ + Http.defaultManagerSettings + & (Http.managerSetProxy $ Http.proxyEnvironmentNamed "I2P_HTTP_PROXY" $ Just defProxy) + pure $ mkClientEnv manager' (BaseUrl Http "4rum.i2p" 80 "") + + let caches = AppEnv{clientEnv, topicCache} + pure $ hoistServer feedApi (`runReaderT` caches) server diff --git a/4r-feed/Feed/V1/Spec.hs b/4r-feed/Feed/V1/Spec.hs new file mode 100644 index 0000000..84c2549 --- /dev/null +++ b/4r-feed/Feed/V1/Spec.hs @@ -0,0 +1,23 @@ +module Feed.V1.Spec (FeedApi, feedApi) where + +import Relude + +import Api.Types (Topic) +import Servant.API +import Servant.API.ContentTypes.AtomFeed (AtomFeed) + +{- | Mimics 4rum's schema with additions + - /topic/:topic_id - Subscribe to a topic + - /sections/:section_id?ignore_topic=:topic_id - Subscribe to all topics in `section_id` ignoring `topic_id` + - /sections/:section_id/new - Subscribe to new topics in `section_id` (returns only initial post) + - /sections/all?ignore_thread=:section_id&ignore_topic=:topic_id - Subscribe to topics in all threads sans `section_id` ignoring `topic_id` +-} +type FeedApi = + "v1" :> "topic" :> Capture "topic_id" Integer :> Get '[AtomFeed] Topic + +-- :<|> "sections" :> Capture "section_id" Integer :> QueryParams "ignore_topic" Integer :> Get '[AtomFeed] FeedThread +-- :<|> "sections" :> Capture "section_id" Integer :> "new" :> Get '[AtomFeed] FeedThread +-- :<|> "sections" :> "all" :> QueryParams "ignore_thread" Integer :> QueryParams "ignore_topic" Integer :> Get '[AtomFeed] FeedThread + +feedApi :: Proxy FeedApi +feedApi = Proxy diff --git a/4r-feed/Feed/V1/Topic.hs b/4r-feed/Feed/V1/Topic.hs new file mode 100644 index 0000000..2f235bc --- /dev/null +++ b/4r-feed/Feed/V1/Topic.hs @@ -0,0 +1,35 @@ +module Feed.V1.Topic (feedTopicCached) where + +import Relude + +import Api (getTopic') +import Api.Types (GetTopic(..), Topic) +import Control.Monad.Except (throwError) +import Data.Cache (fetchWithCache) +import Feed.V1.Core +import Network.HTTP.Types (statusCode) +import Servant.Client.Streaming +import Servant.Server (ServerError(..), err500) + +feedTopic :: Integer -> App Topic +feedTopic topic_id = do + appEnv <- ask + result <- liftIO $ runClientM (getTopic' GetTopic{topic_id}) appEnv.clientEnv + -- TODO: add logging of errors + case result of + Right ok -> pure ok + Left (FailureResponse _ remoteErr) -> + throwError + ServerError + { errHTTPCode = remoteErr.responseStatusCode.statusCode + , errReasonPhrase = "4rum.i2p returned error" + , errBody = remoteErr.responseBody + , errHeaders = toList remoteErr.responseHeaders + } + Left _clientErr -> do + throwError err500 + +feedTopicCached :: Integer -> App Topic +feedTopicCached topic_id = do + appEnv <- ask + fetchWithCache appEnv.topicCache topic_id feedTopic diff --git a/4r-feed/Main.hs b/4r-feed/Main.hs index f2306e9..2b865ac 100644 --- a/4r-feed/Main.hs +++ b/4r-feed/Main.hs @@ -3,129 +3,14 @@ module Main (main) where import Relude -import Relude.Extra.Tuple (fmapToSnd) -import Api -import Api.Types -import Commonmark -import Commonmark.Extensions.Strikethrough -import Commonmark.Extensions.PipeTable -import Control.Monad.Except (throwError) -import Data.Cache (Cache, newCache, fetchWithCache) -import Network.HTTP.Client qualified as Http +import Feed.V1.Spec (FeedApi) +import Feed.V1.Server qualified as V1 import Network.Wai.Cli -import Network.HTTP.Media ((//)) -import Network.HTTP.Types (statusCode) -import Servant.API -import Servant.Client.Streaming hiding ((//)) import Servant.Server -import System.Clock -import System.IO.Unsafe (unsafePerformIO) -import Text.Atom.Feed -import Text.Atom.Feed.Export -data AtomFeed - -instance Accept AtomFeed where - contentType _ = "application" // "atom+xml" - -class IsAtomFeed a where - toAtomFeed :: a -> Feed - -instance IsAtomFeed a => MimeRender AtomFeed a where - mimeRender _ = toAtomFeed - >>> textFeed - >>> fromMaybe (error "Error serializing feed to XML") - >>> encodeUtf8 - --- | Mimics 4rum's schema with additions --- - /topic/:topic_id - Subscribe to a topic --- - /thread/:thread_id?ignore_topic=:topic_id - Subscribe to all topics in `thread_id` ignoring `topic_id` --- - /thread/:thread_id/new - Subscribe to new topics in `thread_id` (returns only initial post) --- - /thread/all?ignore_thread=:thread_id&ignore_topic=:topic_id - Subscribe to topics in all threads sans `thread_id` ignoring `topic_id` -type FeedApi = - "topic" :> Capture "topic_id" Integer :> Get '[AtomFeed] Topic - -- :<|> "thread" :> Capture "thread_id" Integer :> QueryParams "ignore_topic" Integer :> Get '[AtomFeed] FeedThread - -- :<|> "thread" :> Capture "thread_id" Integer :> "new" :> Get '[AtomFeed] FeedThread - -- :<|> "thread" :> "all" :> QueryParams "ignore_thread" Integer :> QueryParams "ignore_topic" Integer :> Get '[AtomFeed] FeedThread - -feedApi :: Proxy FeedApi -feedApi = Proxy - -renderCommonmarkViaHtml :: Text -> Text -renderCommonmarkViaHtml content = - commonmarkWith (defaultSyntaxSpec <> strikethroughSpec <> pipeTableSpec) "" content - & runIdentity - & either (const content) (toStrict . renderHtml @()) - - -instance IsAtomFeed Topic where - toAtomFeed Topic{thread, post} = - feed { feedIcon = Just "http://4rum.i2p/favicon.ico" - , feedEntries - } - where - posts = threadHeadToPost thread : post - feed = nullFeed ("http://4rum.i2p/topic/" <> show thread.info.id) - (TextString thread.info.thrname) - thread.info.last_activity_date - feedEntries = postToEntry <$> posts - postToEntry ThreadPost{id = post_id, name, date, message} = - (nullEntry ("http://4rum.i2ptopic/" <> show thread.info.id <> "#" <> show post_id) - (TextString name) - date) - { entryContent = Just . HTMLContent . renderCommonmarkViaHtml $ message - } - -defProxy :: Http.Proxy -defProxy = Http.Proxy "127.0.0.1" 4444 - -clientEnv :: ClientEnv -clientEnv = unsafePerformIO do - manager' <- liftIO $ - Http.newManager $ - Http.defaultManagerSettings - & (Http.managerSetProxy $ Http.proxyEnvironmentNamed "I2P_HTTP_PROXY" $ Just defProxy) - pure $ mkClientEnv manager' (BaseUrl Http "4rum.i2p" 80 "") - -feedTopic :: Integer -> App Topic -feedTopic topic_id = do - result <- liftIO $ runClientM (getTopic' GetTopic{topic_id}) clientEnv - -- TODO: add logging of errors - case result of - Right ok -> pure ok - Left (FailureResponse _ remoteErr) -> - throwError ServerError { errHTTPCode = remoteErr.responseStatusCode.statusCode - , errReasonPhrase = "4rum.i2p returned error" - , errBody = remoteErr.responseBody - , errHeaders = toList remoteErr.responseHeaders - } - Left _clientErr -> do - throwError err500 - -feedTopicCached :: Integer -> App Topic -feedTopicCached topic_id = do - caches <- ask - fetchWithCache caches.topicCache topic_id feedTopic - -type App = ReaderT Caches Handler - -server :: ServerT FeedApi App -server = feedTopicCached - -newtype Caches = Caches - { topicCache :: Cache Integer Topic - } +apiProxy :: Proxy FeedApi +apiProxy = Proxy main :: IO () -main = 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 - topicCache <- newCache $ Just TimeSpec {nsec = 0, sec} - let caches = Caches {topicCache} - serve feedApi (hoistServer feedApi (`runReaderT` caches) server) - & defWaiMain +main = V1.mkServer >>= defWaiMain . serve apiProxy diff --git a/4r-feed/Servant/API/ContentTypes/AtomFeed.hs b/4r-feed/Servant/API/ContentTypes/AtomFeed.hs new file mode 100644 index 0000000..c45c069 --- /dev/null +++ b/4r-feed/Servant/API/ContentTypes/AtomFeed.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE Strict #-} + +module Servant.API.ContentTypes.AtomFeed ( + IsAtomFeed (toAtomFeed) + , AtomFeed +) where + +import Relude + +import Api.Types +import Commonmark +import Commonmark.Extensions.PipeTable +import Commonmark.Extensions.Strikethrough +import Network.HTTP.Media ((//)) +import Servant.API.ContentTypes +import Text.Atom.Feed +import Text.Atom.Feed.Export + +class IsAtomFeed a where + toAtomFeed :: a -> Feed + +data AtomFeed + +instance Accept AtomFeed where + contentType _ = "application" // "atom+xml" + +instance IsAtomFeed a => MimeRender AtomFeed a where + mimeRender _ = + toAtomFeed + >>> textFeed + >>> fromMaybe (error "Error serializing feed to XML") + >>> encodeUtf8 + +renderCommonmarkViaHtml :: Text -> Text +renderCommonmarkViaHtml content = + commonmarkWith (defaultSyntaxSpec <> strikethroughSpec <> pipeTableSpec) "" content + & runIdentity + & either (const content) (toStrict . renderHtml @()) + +-- Instance for Api.Topic + +instance IsAtomFeed Topic where + toAtomFeed Topic{thread, post} = + feed + { feedIcon = Just "http://4rum.i2p/favicon.ico" + , feedEntries + } + where + posts = threadHeadToPost thread : post + feed = + nullFeed + ("http://4rum.i2p/topic/" <> show thread.info.id) + (TextString $ "4rum - " <> thread.info.thrname) + thread.info.last_activity_date + feedEntries = postToEntry <$> posts + postToEntry ThreadPost{id = post_id, name, date, message} = + let entry = + nullEntry + ("http://4rum.i2ptopic/" <> show thread.info.id <> "#" <> show post_id) + (TextString name) + date + in entry + { entryContent = Just . HTMLContent . renderCommonmarkViaHtml $ message + } diff --git a/flake.nix b/flake.nix index 2deaac2..0689740 100644 --- a/flake.nix +++ b/flake.nix @@ -116,8 +116,7 @@ thisNative = this "ghc922"; in { - packages = { - inherit thisNative; + packages = thisNative // { default = thisNative._4r; };