summaryrefslogtreecommitdiffstats
path: root/app/Main.hs
blob: a3d1355b316947403b60d5f41302f76b7d339877 (plain)
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