1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Control.Arrow hiding (app)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Function
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Tagged
import Data.Text qualified as T
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format.ISO8601
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 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
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
-- XXX contrary to documentation, this enables both IPv4 and IPv6
& setHost "!6"
& setPort env_PORT
& setBeforeMainLoop do
printf "listening on %d..\n" env_PORT
)
app
app :: Application
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>#{day}
<div .commit-wrapper>
$forall commit <- commits
#{commit}
|]
instance ToMarkup Commit where
toMarkup Commit {..} =
[shamlet|
<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 Day where
toMarkup = toMarkup . show
instance ToMarkup UTCTime where
toMarkup = toMarkup . formatShow iso8601Format
instance (ToMarkup a) => ToMarkup [a] where
toMarkup = mconcat . map toMarkup
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
}
)
=<< G.listCommits Nothing (Tagged oid)
)
refs
if' :: Bool -> a -> a -> a
if' True x _ = x
if' False _ x = x
|
