diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 309 |
1 files changed, 134 insertions, 175 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 |