generate feed from repositories

author: Alexander Foremny <aforemny@posteo.de> 2024-03-01 09:46:36 +0100
committer: Alexander Foremny <aforemny@posteo.de> 2024-03-01 15:32:46 +0100
commit: ea152cdf66aaab165178c4fcfa575fc4b898bc44 (patch)
tree: b7e3535fb0d96bfee33db92f72cb159cdc3e8c5e
parent: 6d2a33aad5ad7c13c432322c4201e5004abfeb0b (diff)
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
author	Alexander Foremny <aforemny@posteo.de>	2024-03-01 09:46:36 +0100
committer	Alexander Foremny <aforemny@posteo.de>	2024-03-01 15:32:46 +0100
commit	ea152cdf66aaab165178c4fcfa575fc4b898bc44 (patch)
tree	b7e3535fb0d96bfee33db92f72cb159cdc3e8c5e
parent	6d2a33aad5ad7c13c432322c4201e5004abfeb0b (diff)