From f96387f48dd234d6d3edb8b93a3139e2a9381d44 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 18:08:08 +0100 Subject: [PATCH 1/8] [ rss ] use feed library to generate RSS --- MSPweb.cabal | 32 ++++++++---- OneOhOne.hs | 134 +++++++++++++++++++++++++++------------------------ 2 files changed, 93 insertions(+), 73 deletions(-) diff --git a/MSPweb.cabal b/MSPweb.cabal index 7f0218f..283638a 100644 --- a/MSPweb.cabal +++ b/MSPweb.cabal @@ -8,17 +8,31 @@ 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, + 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..fff0550 100644 --- a/OneOhOne.hs +++ b/OneOhOne.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} module OneOhOne where import Data.Time @@ -15,6 +15,13 @@ 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.XML.Types +import Text.RSS.Syntax +import qualified Text.RSS.Export as Export + -- constants usualTime :: TimeOfDay usualTime = TimeOfDay 14 0 0 @@ -84,7 +91,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,58 +239,55 @@ 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 - + now <- 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 (T.pack now) + , rssChannelOther = [Element "atom:link" [("href", ["https://msp.cis.strath.ac.uk/msp101.rss"]), ("rel", ["self"]), ("type", ["application/rss+xml"])] []] + , rssItems = map processEntry 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 Export.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 :: (Int, Talk) -> RSSItem + processEntry (i,x) = let (rsstitle, desc) = gatherData x in + (nullItem (T.pack rsstitle)) + { rssItemDescription = Just (T.pack desc) + , rssItemGuid = Just (nullPermaGuid (T.pack ("http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i)))) + } generateICS :: [(Int,Talk)] -> FilePath -- ^ Output path @@ -294,19 +299,19 @@ generateICS ts out = do "X-WR-CALNAME: MSP101", "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) + writeFile (out ++ "2") (header ++ content ++ footer) + 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 +320,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", From 3523099b00b307da8cbb6fac111598a3ac505734 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 19:40:42 +0100 Subject: [PATCH 2/8] [ rss ] keep track of pubdate for items --- MSPweb.cabal | 2 ++ OneOhOne.hs | 44 ++++++++++++++++++++++++++++++++------------ 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/MSPweb.cabal b/MSPweb.cabal index 283638a..bdb91c7 100644 --- a/MSPweb.cabal +++ b/MSPweb.cabal @@ -20,6 +20,8 @@ executable Generate101 main-is: Generate101.hs other-modules: OneOhOne build-depends: base, + containers, + directory, time, regex-pcre-builtin, array, diff --git a/OneOhOne.hs b/OneOhOne.hs index fff0550..4ee0982 100644 --- a/OneOhOne.hs +++ b/OneOhOne.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# 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 @@ -18,9 +20,15 @@ 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 qualified Text.RSS.Export as Export +import Text.RSS.Export +import Text.Feed.Import +import Text.Feed.Query -- constants usualTime :: TimeOfDay @@ -239,18 +247,24 @@ generateRSS :: [(Int,Talk)] -> FilePath -- ^ Output path -> IO () generateRSS ts out = do - now <- formatTime defaultTimeLocale "%a, %_d %b %Y %H:%M:%S %z" <$> getZonedTime + 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 (T.pack now) + , 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 ts + , 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 Export.textRSS feed of + case textRSS feed of Just t -> writeFile out (LT.unpack t) Nothing -> putStrLn "Error: Could not generate RSS feed!" where @@ -282,12 +296,18 @@ generateRSS ts out = do 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 :: (Int, Talk) -> RSSItem - processEntry (i,x) = let (rsstitle, desc) = gatherData x in - (nullItem (T.pack rsstitle)) - { rssItemDescription = Just (T.pack desc) - , rssItemGuid = Just (nullPermaGuid (T.pack ("http://msp.cis.strath.ac.uk/msp101.html#" ++ (show i)))) - } + 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 && rssItemContent a == rssItemContent b + generateICS :: [(Int,Talk)] -> FilePath -- ^ Output path From ef47449f989f6346a822685231610acbdd2625bd Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 20:17:16 +0100 Subject: [PATCH 3/8] [ fix ] Correct equality check --- OneOhOne.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/OneOhOne.hs b/OneOhOne.hs index 4ee0982..c153d4f 100644 --- a/OneOhOne.hs +++ b/OneOhOne.hs @@ -306,7 +306,7 @@ generateRSS ts out = do _ -> now in itemBarTime { rssItemPubDate = Just time } equalRSSItems :: RSSItem -> RSSItem -> Bool - equalRSSItems a b = rssItemTitle a == rssItemTitle b && rssItemContent a == rssItemContent b + equalRSSItems a b = rssItemTitle a == rssItemTitle b && rssItemDescription a == rssItemDescription b generateICS :: [(Int,Talk)] From fd85245478f10c05560af2dfbbb4b9e785f2e7a8 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 20:26:26 +0100 Subject: [PATCH 4/8] [ fix ] revert debug filename change --- OneOhOne.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/OneOhOne.hs b/OneOhOne.hs index c153d4f..3e5275f 100644 --- a/OneOhOne.hs +++ b/OneOhOne.hs @@ -319,7 +319,7 @@ generateICS ts out = do "X-WR-CALNAME: MSP101", "X-WR-CALDESC: MSP101 seminar series"] footer = unlines ["END:VCALENDAR"] - writeFile (out ++ "2") (header ++ content ++ footer) + writeFile out (header ++ content ++ footer) 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] From 838016979d57ea4a6ca626b6ff8a59ed98ac9435 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 20:59:32 +0100 Subject: [PATCH 5/8] update haskell-action --- .github/workflows/generate-website.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/generate-website.yml b/.github/workflows/generate-website.yml index 9a6d65d..93edafa 100644 --- a/.github/workflows/generate-website.yml +++ b/.github/workflows/generate-website.yml @@ -29,7 +29,7 @@ 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' cabal-version: 'latest' From b7069f4177326ab87bc0c9cd5e9370d16fe1d621 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 21:08:43 +0100 Subject: [PATCH 6/8] [ ci ] stay with GHC 9.6 --- .github/workflows/generate-website.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/generate-website.yml b/.github/workflows/generate-website.yml index 93edafa..c25f324 100644 --- a/.github/workflows/generate-website.yml +++ b/.github/workflows/generate-website.yml @@ -31,7 +31,7 @@ jobs: if: github.event_name != 'schedule' && steps.changes.outputs.haskell-changed == 'true' uses: haskell-actions/setup@v2 with: - ghc-version: 'latest' + ghc-version: '9.6' cabal-version: 'latest' - name: Cache cabal and executables From 8fb8ddf21f23bd6ce75ba037db77eaf69e2971a5 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 16 Oct 2023 23:25:55 +0100 Subject: [PATCH 7/8] [ ci ] another attempt to not deploy on PRs --- .github/workflows/generate-website.yml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/.github/workflows/generate-website.yml b/.github/workflows/generate-website.yml index c25f324..945dac6 100644 --- a/.github/workflows/generate-website.yml +++ b/.github/workflows/generate-website.yml @@ -11,10 +11,12 @@ jobs: build-and-deploy: runs-on: ubuntu-latest - env: - DEPLOY: ${{ github.event_name != 'pull_request' && github.ref == 'refs/heads/master' }} steps: ##### Setup ############################################## + - name: Are we a pull request? + uses: 8BitJonny/gh-get-current-pr@2.2.0 + id: PR + - name: Checkout repository uses: actions/checkout@v3 @@ -62,7 +64,7 @@ jobs: ##### Deployment ######################################### - name: Deploy to branch - if: ${{ env.DEPLOY }} + if: steps.PR.outputs.pr_found == 'true' uses: s0/git-publish-subdir-action@develop env: REPO: self @@ -71,7 +73,7 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - name: Trigger pull at website - if: ${{ env.DEPLOY }} + if: steps.PR.outputs.pr_found == 'true' shell: bash env: PASSPHRASE: ${{ secrets.WEBHOOK_PASSPHRASE }} From 0af12c6f6514885ac94fd7ba50f40e4d2e6bf708 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 17 Oct 2023 08:58:24 +0100 Subject: [PATCH 8/8] [ ci ] another attempt at only deploying on main --- .github/workflows/generate-website.yml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/.github/workflows/generate-website.yml b/.github/workflows/generate-website.yml index 945dac6..40c75b2 100644 --- a/.github/workflows/generate-website.yml +++ b/.github/workflows/generate-website.yml @@ -13,10 +13,6 @@ jobs: runs-on: ubuntu-latest steps: ##### Setup ############################################## - - name: Are we a pull request? - uses: 8BitJonny/gh-get-current-pr@2.2.0 - id: PR - - name: Checkout repository uses: actions/checkout@v3 @@ -64,7 +60,7 @@ jobs: ##### Deployment ######################################### - name: Deploy to branch - if: steps.PR.outputs.pr_found == 'true' + if: github.ref == 'refs/heads/main' uses: s0/git-publish-subdir-action@develop env: REPO: self @@ -73,7 +69,7 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - name: Trigger pull at website - if: steps.PR.outputs.pr_found == 'true' + if: github.ref == 'refs/heads/main' shell: bash env: PASSPHRASE: ${{ secrets.WEBHOOK_PASSPHRASE }}