4r-feed: reorganize modules

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

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
+  }

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

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

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

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) "<message>" 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

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) "<message>" 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
+            }

flake.nix

@@ -116,8 +116,7 @@
           thisNative = this "ghc922";
        in
       {
-        packages = {
-          inherit thisNative;
+        packages = thisNative // {
           default = thisNative._4r;
         };