{-# 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" env_FEED_ID :: T.Text env_FEED_ID = "code.nomath.org" env_FEED_URLS :: [String] env_FEED_URLS = [ "https://code.nomath.org/abuilder/atom", "https://code.nomath.org/anissue/atom", "https://code.nomath.org/apaperless/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", "https://code.nomath.org/static-nomath-org/atom" ] main :: IO () main = do 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|#{feed}|] instance ToMarkup AtomFeed where toMarkup AtomFeed {..} = [shamlet|

#{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|

#{show day} #{es} |] instance ToMarkup AtomEntry where toMarkup AtomEntry {..} = [shamlet|
#{entryTitle}
#{fromMaybe (AtomPlainText TypeText "") entrySummary}
#{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 renderAtomFeed feed .| renderBytes def .| mapM_C (liftIO . write . fromByteString)-} merge :: [AtomFeed] -> AtomFeed merge feeds = AtomFeed { feedAuthors = concatMap (.feedAuthors) feeds, feedCategories = concatMap (.feedCategories) feeds, feedContributors = concatMap (.feedContributors) 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, feedLinks = concatMap (.feedLinks) feeds, feedLogo = Nothing, feedRights = Nothing, feedSubtitle = Nothing, feedTitle = AtomPlainText TypeText env_FEED_TITLE, 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) instance Exception ParserError getFeed :: Manager -> String -> ResourceT IO AtomFeed getFeed manager url = do request <- parseRequest url response <- http request manager fromMaybe (throw (ParserError url)) <$> runConduit do responseBody response .| parseBytes def .| massage .| atomFeed massage :: ConduitT Event Event (ResourceT IO) () massage = do await >>= \case Nothing -> pure () Just e -> do yield e -- BeginDocument await >>= \case Nothing -> pure () Just e -> do yield e -- yieldMany (elementToEvents idE) yieldMany (elementToEvents updatedE) mapC id where idE = -- TODO(id) Element "{http://www.w3.org/2005/Atom}id" [] [ NodeContent (ContentText "TODO") ] updatedE = -- TODO(updated) Element "{http://www.w3.org/2005/Atom}updated" [] [ NodeContent (ContentText "1970-01-01T00:00:00Z") ]