From 6d2a33aad5ad7c13c432322c4201e5004abfeb0b Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Tue, 27 Feb 2024 14:10:11 +0100
Subject: add webserver
---
app/Main.hs | 133 ++++++++++++++++++++++++++++++++++++++++++++++----
feed-nomath-org.cabal | 13 ++++-
2 files changed, 135 insertions(+), 11 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index 99daa6e..729666b 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,24 +1,44 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
+import Data.Time.Calendar
import Conduit
+import Control.Applicative
import Control.Exception
+import Data.Binary.Builder
+import Data.Function
+import Data.List
import Data.Maybe
+import Data.Ord
import Data.Text qualified as T
+import Data.Time.Clock
+import Data.Time.Format.ISO8601
import Data.XML.Types
import Network.HTTP.Conduit
+import Network.HTTP.Types
+import Network.Wai.Conduit
+import Network.Wai.Handler.Warp
import Text.Atom.Conduit.Parse
import Text.Atom.Conduit.Render
import Text.Atom.Types
+import Text.Blaze
+import Text.Blaze.Html.Renderer.Utf8
+import Text.Hamlet
+import Text.Printf
import Text.XML.Stream.Parse
import Text.XML.Stream.Render
import Text.XML.Unresolved (elementToEvents)
+import UnliftIO.Concurrent (forkFinally)
+import UnliftIO.MVar
env_FEED_TITLE :: T.Text
env_FEED_TITLE = "code.nomath.org"
@@ -28,9 +48,10 @@ env_FEED_ID = "code.nomath.org"
env_FEED_URLS :: [String]
env_FEED_URLS =
- [ "https://code.nomath.org/anissue/atom",
+ [ "https://code.nomath.org/abuilder/atom",
+ "https://code.nomath.org/anissue/atom",
"https://code.nomath.org/apaperless/atom",
- "https://code.nomath.org/abuilder/atom",
+ "https://code.nomath.org/feed-nomath-org/atom",
"https://code.nomath.org/infra/atom",
"https://code.nomath.org/json2sql/atom",
"https://code.nomath.org/nomath-org/atom",
@@ -39,14 +60,79 @@ env_FEED_URLS =
main :: IO ()
main = do
- manager <- newManager tlsManagerSettings
- runResourceT do
- feeds <- mapM (getFeed manager) env_FEED_URLS
+ runSettings
+ ( defaultSettings
+ & setPort 8080
+ & setBeforeMainLoop do
+ printf "listening on 8080..\n"
+ )
+ app
+
+app :: Application
+app req resp = do
+ resp . responseStream status200 [] $ \write flush -> do
+ feed <- runConduitRes do
+ manager <- liftIO (newManager tlsManagerSettings)
+ feeds <- mapM (lift . getFeed manager) env_FEED_URLS
+ pure $ merge feeds
+ write $ renderHtmlBuilder [shamlet|<html><head><body>#{feed}|]
+
+instance ToMarkup AtomFeed where
+ toMarkup AtomFeed {..} =
+ [shamlet|
+ <h1>#{feedTitle}
+ #{groupedEntries}
+ |]
+ where
+ groupedEntries =
+ map
+ (\es -> let e = head es in (utctDay (entryUpdated e), es))
+ (groupBy ((==) `on` (utctDay . entryUpdated)) feedEntries)
+
+instance ToMarkup (Day, [AtomEntry]) where
+ toMarkup (day, es) =
+ [shamlet|
+ <h2>#{show day}
+ #{es}
+ |]
+
+instance ToMarkup AtomEntry where
+ toMarkup AtomEntry {..} =
+ [shamlet|
+ <div>
+ <div>#{entryTitle}
+ <div>#{fromMaybe (AtomPlainText TypeText "") entrySummary}
+ <div>#{fromMaybe (AtomContentInlineText TypeText "") entryContent}
+ |]
+
+instance ToMarkup AtomContent where
+ toMarkup (AtomContentInlineText TypeText t) = toMarkup t
+ toMarkup (AtomContentInlineOther "text" t) = toMarkup t
+ toMarkup c = error (show c)
+
+instance ToMarkup AtomText where
+ toMarkup (AtomPlainText TypeText t) = toMarkup t
+ toMarkup (AtomPlainText TypeHTML t) = toMarkup t
+ toMarkup (AtomXHTMLText e) = toMarkup e
+
+instance ToMarkup Element where
+ toMarkup = toMarkup . show
+
+instance ToMarkup UTCTime where
+ toMarkup = toMarkup . formatShow iso8601Format
+
+instance (ToMarkup a) => ToMarkup [a] where
+ toMarkup = mconcat . map toMarkup
+
+{-
+resp . responseStream status200 [] $ \write _ -> do
+ runConduitRes do
+ manager <- liftIO (newManager tlsManagerSettings)
+ feeds <- mapM (lift . getFeed manager) env_FEED_URLS
let feed = merge feeds
- runConduit do
- renderAtomFeed feed
- .| renderBytes def
- .| sinkFile "output.atom"
+ renderAtomFeed feed
+ .| renderBytes def
+ .| mapM_C (liftIO . write . fromByteString)-}
merge :: [AtomFeed] -> AtomFeed
merge feeds =
@@ -54,7 +140,25 @@ merge feeds =
{ feedAuthors = concatMap (.feedAuthors) feeds,
feedCategories = concatMap (.feedCategories) feeds,
feedContributors = concatMap (.feedContributors) feeds,
- feedEntries = concatMap (.feedEntries) feeds,
+ feedEntries =
+ reverse
+ ( sortOn
+ entryUpdated
+ ( concatMap
+ ( \feed ->
+ map
+ ( \feedEntry ->
+ feedEntry
+ { entryTitle =
+ case (feed.feedTitle, feedEntry.entryTitle) of
+ (AtomPlainText TypeText t, AtomPlainText TypeText u) -> AtomPlainText TypeText (t <> ": " <> u)
+ }
+ )
+ feed.feedEntries
+ )
+ feeds
+ )
+ ),
feedGenerator = Nothing,
feedIcon = Nothing,
feedId = env_FEED_ID,
@@ -66,6 +170,15 @@ merge feeds =
feedUpdated = minimum (map (.feedUpdated) feeds)
}
+getFeedsConcurrently :: Manager -> [String] -> ResourceT IO [AtomFeed]
+getFeedsConcurrently manager =
+ mapM
+ ( \url -> do
+ m <- newEmptyMVar
+ _ <- forkFinally (getFeed manager url) (putMVar m)
+ either throwM pure =<< takeMVar m
+ )
+
data ParserError = ParserError String
deriving (Show)
diff --git a/feed-nomath-org.cabal b/feed-nomath-org.cabal
index 9678557..861203b 100644
--- a/feed-nomath-org.cabal
+++ b/feed-nomath-org.cabal
@@ -13,14 +13,25 @@ executable feed-nomath-org
main-is: Main.hs
hs-source-dirs: app
default-language: GHC2021
- ghc-options: -Wall
+ ghc-options: -Wall -threaded
build-depends:
atom-conduit,
base,
+ binary,
+ blaze-html,
+ blaze-markup,
bytestring,
conduit,
http-conduit,
+ http-types,
resourcet,
+ shakespeare,
+ stm,
text,
+ time,
+ unliftio,
+ wai,
+ wai-conduit,
+ warp,
xml-conduit,
xml-types
--
cgit v1.2.3