From ea152cdf66aaab165178c4fcfa575fc4b898bc44 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
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|<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) =
+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|
+ <html lang=en>
+ <head>
+ <meta charset=utf-8>
+ <title>feed.nomath.org</title>
+ <link rel=icon href=https://static.nomath.org/favicon.ico>
+ <meta name=viewport content="width=device-width, initial-scale=1">
+ <link rel=stylesheet type=text/css href=https://static.nomath.org/base.css>
+ <style type=text/css>
+ #{renderCss css}
+ <body>
+ <h1>feed.nomath.org
+ #{commitsPerDay}
+ |]
+
+css :: Css
+css =
+ [cassius|
+ .commit-wrapper
+ display: flex
+ flex-flow: column nowrap
+ gap: 8px
+ .commit
+ border: 1px solid black
+ padding: 2px 4px
+ .commit__title
+ font-weight: bold
+ |]
+ []
+
+data Commit = Commit
+ { repository :: T.Text,
+ branch :: T.Text,
+ hash :: T.Text,
+ createdAt :: UTCTime,
+ message :: (T.Text, Maybe T.Text),
+ author :: T.Text,
+ committer :: T.Text
+ }
+ deriving (Show)
+
+instance ToMarkup (Day, [Commit]) where
+ toMarkup (day, commits) =
[shamlet|
- <h2>#{show day}
- #{es}
+ <h2>#{day}
+ <div .commit-wrapper>
+ $forall commit <- commits
+ #{commit}
|]
-instance ToMarkup AtomEntry where
- toMarkup AtomEntry {..} =
+instance ToMarkup Commit where
+ toMarkup Commit {..} =
[shamlet|
- <div>
- <div>#{entryTitle}
- <div>#{fromMaybe (AtomPlainText TypeText "") entrySummary}
- <div>#{fromMaybe (AtomContentInlineText TypeText "") entryContent}
+ <div .commit>
+ <div .commit__title>
+ <span>#{repository} #{branch}:
+ <span>#{fst message}
+ $maybe message <- (snd message)
+ <p .commit__message>#{message}
+ <div .commit__meta>
+ <span>by
+ <span>#{author}
+ <span>on
+ <span>#{createdAt}
|]
-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
+instance ToMarkup Day where
toMarkup = toMarkup . show
instance ToMarkup UTCTime where
@@ -124,102 +142,43 @@ instance ToMarkup UTCTime where
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
+getCommitsConcurrently :: [FilePath] -> IO [Commit]
+getCommitsConcurrently =
+ fmap concat
+ . mapM
+ ( \url -> do
+ m <- newEmptyMVar
+ _ <- forkFinally (getCommits url) (putMVar m)
+ either throwIO pure =<< takeMVar m
+ )
+
+getCommits :: FilePath -> IO [Commit]
+getCommits url = do
+ repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = url}
+ G.runRepository GB.lgFactory repo do
+ refs <- filter ("refs/heads/" `T.isPrefixOf`) <$> G.listReferences
+ concat
+ <$> mapM
+ ( \ref -> do
+ Just oid <- G.resolveReference ref
+ mapM
+ ( \cid -> do
+ commit <- G.lookupCommit cid
+ pure
+ Commit
+ { repository = T.pack (takeBaseName url),
+ branch = fromMaybe ref (T.stripPrefix "refs/heads/" ref),
+ hash = G.renderOid (untag commit.commitOid),
+ createdAt = zonedTimeToUTC commit.commitAuthor.signatureWhen,
+ message = second (ap (flip if' Nothing . T.null) Just . T.drop 2) (T.breakOn "\n\n" commit.commitLog),
+ author = commit.commitAuthor.signatureName,
+ committer = commit.commitCommitter.signatureName
+ }
)
- ),
- 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)
+ =<< G.listCommits Nothing (Tagged oid)
+ )
+ refs
-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 -- <feed>
- 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")
- ]
+if' :: Bool -> a -> a -> a
+if' True x _ = x
+if' False _ x = x
diff --git a/default.nix b/default.nix
index c0a928f..8e9b004 100644
--- a/default.nix
+++ b/default.nix
@@ -2,7 +2,6 @@
let
haskellPackages = pkgs.haskellPackages.override {
overrides = self: super: {
- atom-conduit = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendPatch super.atom-conduit ./atom-conduit.patch);
feed-nomath-org = self.callCabal2nix "feed-nomath-org" ./. { };
};
};
@@ -12,7 +11,6 @@ rec {
shell = haskellPackages.shellFor {
packages = _: [
feed-nomath-org
- haskellPackages.atom-conduit
];
buildInputs = [
haskellPackages.cabal2nix
@@ -21,5 +19,10 @@ rec {
];
withHoogle = true;
withHaddock = true;
+ shellHook = ''
+ REPOSITORIES=${pkgs.lib.concatStringsSep ":" [
+ "../feed-nomath-org"
+ ]}; export REPOSITORIES
+ '';
};
}
diff --git a/feed-nomath-org.cabal b/feed-nomath-org.cabal
index 861203b..a84b10c 100644
--- a/feed-nomath-org.cabal
+++ b/feed-nomath-org.cabal
@@ -15,23 +15,17 @@ executable feed-nomath-org
default-language: GHC2021
ghc-options: -Wall -threaded
build-depends:
- atom-conduit,
base,
- binary,
blaze-html,
blaze-markup,
- bytestring,
- conduit,
- http-conduit,
+ filepath,
+ gitlib,
+ gitlib-libgit2,
http-types,
- resourcet,
shakespeare,
- stm,
+ split,
+ tagged,
text,
time,
- unliftio,
- wai,
wai-conduit,
warp,
- xml-conduit,
- xml-types
--
cgit v1.2.3