From be0d2865027f3d67c947dae3acc05f716e2bf959 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 17 Oct 2023 09:38:04 +0100 Subject: [PATCH] Using the feed library for generating the RSS feed (#18) * [ rss ] use feed library to generate RSS * [ rss ] keep track of pubdate for items * [ fix ] Correct equality check * [ fix ] revert debug filename change * update haskell-action * [ ci ] stay with GHC 9.6 * [ ci ] another attempt to not deploy on PRs * [ ci ] another attempt at only deploying on main --- .github/workflows/generate-website.yml | 10 +- MSPweb.cabal | 34 ++++-- OneOhOne.hs | 150 +++++++++++++++---------- 3 files changed, 117 insertions(+), 77 deletions(-) diff --git a/.github/workflows/generate-website.yml b/.github/workflows/generate-website.yml index 9a6d65d..40c75b2 100644 --- a/.github/workflows/generate-website.yml +++ b/.github/workflows/generate-website.yml @@ -11,8 +11,6 @@ jobs: build-and-deploy: runs-on: ubuntu-latest - env: - DEPLOY: ${{ github.event_name != 'pull_request' && github.ref == 'refs/heads/master' }} steps: ##### Setup ############################################## - name: Checkout repository @@ -29,9 +27,9 @@ jobs: - name: Install cabal and GHC if: github.event_name != 'schedule' && steps.changes.outputs.haskell-changed == 'true' - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@v2 with: - ghc-version: 'latest' + ghc-version: '9.6' cabal-version: 'latest' - name: Cache cabal and executables @@ -62,7 +60,7 @@ jobs: ##### Deployment ######################################### - name: Deploy to branch - if: ${{ env.DEPLOY }} + if: github.ref == 'refs/heads/main' uses: s0/git-publish-subdir-action@develop env: REPO: self @@ -71,7 +69,7 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - name: Trigger pull at website - if: ${{ env.DEPLOY }} + if: github.ref == 'refs/heads/main' shell: bash env: PASSPHRASE: ${{ secrets.WEBHOOK_PASSPHRASE }} diff --git a/MSPweb.cabal b/MSPweb.cabal index 7f0218f..bdb91c7 100644 --- a/MSPweb.cabal +++ b/MSPweb.cabal @@ -8,17 +8,33 @@ build-type: Simple cabal-version: >= 1.10 executable Generate - main-is: Generate.hs - build-depends: base, filepath, directory, pandoc >= 2.0, text - default-language: Haskell2010 + main-is: Generate.hs + build-depends: base, + filepath, + directory, + pandoc >= 2.0, + text + default-language: Haskell2010 executable Generate101 - main-is: Generate101.hs - other-modules: OneOhOne - build-depends: base, time, regex-pcre-builtin, array, aeson, bytestring - default-language: Haskell2010 + main-is: Generate101.hs + other-modules: OneOhOne + build-depends: base, + containers, + directory, + time, + regex-pcre-builtin, + array, + aeson, + bytestring, + text, + xml-types, + feed + default-language: Haskell2010 executable GeneratePeople - main-is: GeneratePeople.hs - build-depends: base, yaml, bytestring + main-is: GeneratePeople.hs + build-depends: base, + yaml, + bytestring default-language: Haskell2010 diff --git a/OneOhOne.hs b/OneOhOne.hs index 24dd755..3e5275f 100644 --- a/OneOhOne.hs +++ b/OneOhOne.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, OverloadedStrings, LambdaCase, TupleSections #-} module OneOhOne where import Data.Time +import System.Directory import Data.List +import Data.Maybe import Data.Ord import Data.Foldable import Control.Arrow @@ -15,6 +17,19 @@ import Text.Regex.PCRE import GHC.Generics import Data.Aeson +import qualified Data.Text.Lazy as LT +import qualified Data.Text as T + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.XML.Types +import Text.Feed.Types +import Text.RSS.Syntax +import Text.RSS.Export +import Text.Feed.Import +import Text.Feed.Query + -- constants usualTime :: TimeOfDay usualTime = TimeOfDay 14 0 0 @@ -84,7 +99,8 @@ subRegex regexp inp repl = compiled :: MatchText String -> String -> String compiled = compile 0 repl findrefs where -- bre matches a backslash then capture either a backslash or some digits - bre = makeRegex "\\\\(\\\\|[0-9]+)" :: Regex + bre :: Regex + bre = makeRegex ("\\\\(\\\\|[0-9]+)" :: String) findrefs = map (\m -> (fst (m!1),snd (m!0))) (matchAllText bre repl) go _i str [] = str go i str (m:ms) = @@ -231,57 +247,66 @@ generateRSS :: [(Int,Talk)] -> FilePath -- ^ Output path -> IO () generateRSS ts out = do - let content = concatMap processEntry ts - header = unlines ["", - "", - " ", - " ", - " MSP101 Seminar", - " http://msp.cis.strath.ac.uk/msp101.html", - " MSP101 is an ongoing series of informal talks by visiting academics or members of the MSP group.", - " en-gb"] - footer = unlines [" ", ""] - writeFile out (header ++ content ++ footer) - where processEntry (i,(Talk date speaker inst speakerurl insturl title abstract location material)) - = let rsstitle = (showGregorian $ utctDay date) ++ ": " ++ speaker ++ bracket inst - abstr = if (null abstract) then "" else "

Abstract

" ++ (nl2br abstract) ++ "

" - desc = unlines ["

" ++ (createLink speakerurl speaker) ++ (bracket (createLink insturl inst)) ++ "

", - "

" ++ title ++ "

", - abstr, - "" ++ (show date) ++ "
" ++ location ++ "
"] - in - unlines [" ", - " " ++ rsstitle ++ "", - " ", - " http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i) ++ "", - " "] - processEntry (i,(DepartmentalSeminar date speaker inst speakerurl insturl title abstract location)) - = let rsstitle = (showGregorian $ utctDay date) ++ " Departmental seminar " ++ ": " ++ speaker ++ bracket inst - abstr = if (null abstract) then "" else "

Abstract

" ++ (nl2br abstract) ++ "

" - desc = unlines ["

" ++ (createLink speakerurl speaker) ++ (bracket (createLink insturl inst)) ++ "

", - "

" ++ title ++ "

", - abstr, - "" ++ (show date) ++ "
" ++ location ++ "
"] - in - unlines [" ", - " " ++ rsstitle ++ "", - " ", - " http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i) ++ "", - " "] - processEntry (i,(SpecialEvent date title url location locationurl description)) - = let rsstitle = (showGregorian $ utctDay date) ++ ": " ++ title - abstr = if (null description) then "" else "

" ++ (nl2br description) ++ "

" - desc = unlines ["

" ++ (createLink url title) ++ (bracket location) ++ "

", - "

" ++ title ++ "

", - abstr, - "" ++ (show date) ++ "
" ++ (createLink locationurl location) ++ "
"] - in - unlines [" ", - " " ++ rsstitle ++ "", - " ", - " http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i) ++ "", - " "] - processEntry (i,(BasicTalk date speaker inst speakerurl insturl title abstract location material)) = processEntry (i, (Talk date speaker inst speakerurl insturl ("MSP 101: " ++ title) abstract location material)) -- for now + oldItemsMap <- doesFileExist out >>= \case + True -> parseFeedFromFile out >>= \case + Just f -> let is = getFeedItems f + in pure $ Map.fromList $ concatMap (\ x -> maybeToList ((,x) . snd <$> getItemId x)) is + _ -> pure Map.empty + _ -> pure Map.empty + now <- T.pack . formatTime defaultTimeLocale "%a, %_d %b %Y %H:%M:%S %z" <$> getZonedTime + let channel = (nullChannel "MSP101 Seminar" "https://msp.cis.strath.ac.uk/msp101.rss") + { rssDescription = "MSP101 is an ongoing series of informal talks by visiting academics or members of the MSP group." + , rssLanguage = Just "en-gb" + , rssLastUpdate = Just now + , rssChannelOther = [Element "atom:link" [("href", ["https://msp.cis.strath.ac.uk/msp101.rss"]), ("rel", ["self"]), ("type", ["application/rss+xml"])] []] + , rssItems = map (processEntry now oldItemsMap) ts + } + let feed = (nullRSS "MSP101 Seminar" "https://msp.cis.strath.ac.uk/msp101.rss") + { rssAttrs = [("xmlns:atom",["http://www.w3.org/2005/Atom"])] + , rssChannel = channel } + case textRSS feed of + Just t -> writeFile out (LT.unpack t) + Nothing -> putStrLn "Error: Could not generate RSS feed!" + where + gatherData :: Talk -> (String, String) + gatherData (Talk date speaker inst speakerurl insturl title abstract location material) + = let rsstitle = (showGregorian $ utctDay date) ++ ": " ++ speaker ++ bracket inst + abstr = if (null abstract) then "" else "

Abstract

" ++ (nl2br abstract) ++ "

" + desc = concat ["

" ++ (createLink speakerurl speaker) ++ (bracket (createLink insturl inst)) ++ "

", + "

" ++ title ++ "

", + abstr, + "

" ++ (show date) ++ "
" ++ location ++ "

"] + in (rsstitle, desc) + gatherData (DepartmentalSeminar date speaker inst speakerurl insturl title abstract location) + = let rsstitle = (showGregorian $ utctDay date) ++ " Departmental seminar: " ++ speaker ++ bracket inst + abstr = if (null abstract) then "" else "

Abstract

" ++ (nl2br abstract) ++ "

" + desc = concat ["

" ++ (createLink speakerurl speaker) ++ (bracket (createLink insturl inst)) ++ "

", + "

" ++ title ++ "

", + abstr, + "

" ++ (show date) ++ "
" ++ location ++ "
"] + in (rsstitle, desc) + gatherData (SpecialEvent date title url location locationurl description) + = let rsstitle = (showGregorian $ utctDay date) ++ ": " ++ title + abstr = if (null description) then "" else "

" ++ (nl2br description) ++ "

" + desc = concat ["

" ++ (createLink url title) ++ (bracket location) ++ "

", + "

" ++ title ++ "

", + abstr, + "

" ++ (show date) ++ "
" ++ (createLink locationurl location) ++ "

"] + in (rsstitle, desc) + gatherData (BasicTalk date speaker inst speakerurl insturl title abstract location material) + = gatherData (Talk date speaker inst speakerurl insturl ("MSP 101: " ++ title) abstract location material) -- for now + + processEntry :: T.Text -> Map T.Text Item -> (Int, Talk) -> RSSItem + processEntry now is (i,x) = + let (rsstitle, desc) = gatherData x + guid = T.pack ("http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i)) + itemBarTime = (nullItem (T.pack rsstitle)) { rssItemDescription = Just (T.pack desc), rssItemGuid = Just (nullPermaGuid guid) } + time = case Map.lookup guid is of + Just i@(Text.Feed.Types.RSSItem ri) | Just oldTime <-getItemPublishDateString i -> if equalRSSItems ri itemBarTime then oldTime else now + _ -> now + in itemBarTime { rssItemPubDate = Just time } + equalRSSItems :: RSSItem -> RSSItem -> Bool + equalRSSItems a b = rssItemTitle a == rssItemTitle b && rssItemDescription a == rssItemDescription b generateICS :: [(Int,Talk)] @@ -295,18 +320,18 @@ generateICS ts out = do "X-WR-CALDESC: MSP101 seminar series"] footer = unlines ["END:VCALENDAR"] writeFile out (header ++ content ++ footer) - where gatherData (Talk date speaker inst speakerurl insturl title abstract location material) + where gatherData :: Talk -> (String, UTCTime, String, String, String) + gatherData (Talk date speaker inst speakerurl insturl title abstract location material) = let desc = unlines ["Speaker: " ++ speaker ++ " " ++ (bracket inst), "Title: " ++ title ++ "\n", abstract] - end = addUTCTime (60*60::NominalDiffTime) date - in (desc, end, date, location, title, "") + in (desc, date, location, title, "") gatherData (DepartmentalSeminar date speaker inst speakerurl insturl title abstract location) = let desc = unlines ["Speaker: " ++ speaker ++ " " ++ (bracket inst), "Title: " ++ title ++ "\n", abstract] - end = addUTCTime (60*60::NominalDiffTime) date - in (desc, end, date, location, title, "Departmental seminar: ") + in (desc, date, location, title, "Departmental seminar: ") gatherData (SpecialEvent date title url location locationurl description) - = let end = addUTCTime (60*60::NominalDiffTime) date - in (description, end, date, location, title, "Event: ") - gatherData (BasicTalk date speaker inst speakerurl insturl title abstract location material) = gatherData (Talk date speaker inst speakerurl insturl ("MSP 101: " ++ title) abstract location material) -- for now + = (description, date, location, title, "Event: ") + gatherData (BasicTalk date speaker inst speakerurl insturl title abstract location material) + = gatherData (Talk date speaker inst speakerurl insturl ("MSP 101: " ++ title) abstract location material) -- for now + escape :: String -> String escape [] = [] escape ('\\':xs) = "\\\\" ++ (escape xs) @@ -315,7 +340,8 @@ generateICS ts out = do escape (',':' ':xs) = "\\, " ++ (escape xs) escape (x:xs) = x:(escape xs) processEntry now (i,x) - = let (desc, end, date, location, title, kindEvent) = gatherData x + = let (desc, date, location, title, kindEvent) = gatherData x + end = addUTCTime (60*60::NominalDiffTime) date t = escape . html2text in unlines ["BEGIN:VEVENT",