diff options
| author |  Alexander Foremny <aforemny@posteo.de> | 2024-02-27 14:10:11 +0100 |
|---|---|---|
| committer | Alexander Foremny <aforemny@posteo.de> | 2024-02-27 14:19:12 +0100 |
| commit | 6d2a33aad5ad7c13c432322c4201e5004abfeb0b (patch) | |
| tree | e36a8cf349e202f521a3c6cb58d82bc528692984 | |
| parent | 6245475c407a118ba167e11744665616b0e90b3c (diff) | |
add webserver
| -rw-r--r-- | app/Main.hs | 133 | ||||
| -rw-r--r-- | 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 |