From ea152cdf66aaab165178c4fcfa575fc4b898bc44 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Fri, 1 Mar 2024 09:46:36 +0100 Subject: generate feed from repositories --- app/Main.hs | 309 ++++++++++++++++++++++---------------------------- default.nix | 7 +- feed-nomath-org.cabal | 16 +-- 3 files changed, 144 insertions(+), 188 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 729666b..6462846 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,121 +1,139 @@ {-# 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.Arrow hiding (app) +import Control.Concurrent import Control.Exception -import Data.Binary.Builder +import Control.Monad import Data.Function import Data.List +import Data.List.Split import Data.Maybe -import Data.Ord +import Data.Tagged import Data.Text qualified as T +import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format.ISO8601 -import Data.XML.Types -import Network.HTTP.Conduit +import Data.Time.LocalTime +import Git qualified as G +import Git.Libgit2 qualified as GB 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 System.Environment +import System.FilePath +import System.IO.Unsafe import Text.Blaze import Text.Blaze.Html.Renderer.Utf8 +import Text.Cassius 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" - ] + +env_REPOSITORIES :: [String] +env_REPOSITORIES = + splitOn ":" (unsafePerformIO (getEnv "REPOSITORIES")) + +env_PORT :: Int +env_PORT = + maybe 8080 read (unsafePerformIO (lookupEnv "PORT")) main :: IO () main = do runSettings ( defaultSettings - & setPort 8080 + -- XXX contrary to documentation, this enables both IPv4 and IPv6 + & setHost "!6" + & setPort env_PORT & setBeforeMainLoop do - printf "listening on 8080..\n" + printf "listening on %d..\n" env_PORT ) 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) = +app _ resp = do + resp . responseStream status200 [] $ \write _ -> do + commits <- + reverse . sortOn (.createdAt) + <$> getCommitsConcurrently env_REPOSITORIES + let commitsPerDay = + (map (\xs -> (utctDay . (.createdAt) $ head xs, xs))) $ + groupBy ((==) `on` (utctDay . (.createdAt))) commits + write $ + renderHtmlBuilder + [shamlet| + + + + feed.nomath.org + + + +