{-# 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 = Nothing,
                                entryTitle = AtomPlainText TypeText (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