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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Conduit
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.Atom.Conduit.Render
import Text.Atom.Types
import Text.Blaze
import Text.Blaze.Html.Renderer.Utf8
import Text.Cassius
import Text.Hamlet
import Text.Printf
import Text.XML.Stream.Render
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 req resp = do
if
| rawPathInfo req == "/feed" ->
resp
. responseStream
status200
[ ("content-type", "application/atom+xml")
]
$ \write _ -> do
commits <-
reverse . sortOn (.createdAt)
<$> getCommitsConcurrently env_REPOSITORIES
feedUpdated <- getCurrentTime
runConduit $
renderAtomFeed
AtomFeed
{ feedAuthors = [],
feedCategories = [],
feedContributors = [],
feedEntries =
map
( \commit ->
AtomEntry
{ entryAuthors = [],
entryCategories = [],
entryContent =
AtomContentInlineText
TypeText
<$> (snd commit.message),
entryContributors = [],
entryId =
"feed.nomath.org/"
<> commit.repository
<> "/"
<> commit.hash,
entryLinks = [],
entryPublished = Nothing,
entryRights = Nothing,
entrySource = Nothing,
entrySummary =
Just
. AtomPlainText TypeText
. fromMaybe "(no further content)"
$ snd commit.message,
entryTitle =
AtomPlainText
TypeText
( (commit.repository <> " ")
<> (commit.branch <> ": ")
<> fst commit.message
),
entryUpdated = commit.createdAt
}
)
commits,
feedGenerator = Nothing,
feedIcon = Nothing,
feedId = "https://feed.nomath.org",
feedLinks = [],
feedLogo = Nothing,
feedRights = Nothing,
feedSubtitle = Nothing,
feedTitle = AtomPlainText TypeText "feed.nomath.org",
feedUpdated = feedUpdated
}
.| renderBuilder def
.| mapM_C write
| rawPathInfo req == "/" ->
resp
. responseStream
status200
[ ("content-type", "text/html")
]
$ \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>
<link rel=alternate type=application/atom+xml href=/feed>
<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}
|]
| otherwise -> resp (responseLBS status404 [] "Not found")
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
|
