[ new ] Generate recent publications from PURE, and news from a yaml …

…file

.github/workflows/generate-website.yml

@@ -59,6 +59,9 @@ jobs:
       - name: Generate 101
         run: Generate101
 
+      - name: Generate News
+        run: GenerateNews
+
       - name: Generate website
         run: Generate
 

Generate.hs

@@ -126,7 +126,7 @@ substitute template env = loop template []
           let varNm = reverse varAcc in
           case lookup varNm env of
             Nothing  -> loop cs acc
-            Just val -> loop cs (reverse val ++ acc)
+            Just val -> loop cs (reverse (substitute val env) ++ acc)
       getVar (c:cs) varAcc acc = getVar cs (c:varAcc) acc
 
 -- | Check the input string to determine if it starts with a header of

GenerateNews.hs

@@ -0,0 +1,151 @@
+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
+module Main where
+
+import Prelude hiding (div)
+import GHC.Generics
+import Data.Yaml
+
+import Data.List
+import Data.Maybe
+import Data.Function
+
+-- import Data.ByteString.Lazy (ByteString)
+-- import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as BS
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Control.Applicative
+
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+import Network.HTTP.Types.Status
+
+import Data.Time
+import Data.Time.Format
+
+import Text.Feed.Types
+import Text.Feed.Import
+import Text.Feed.Query
+
+import Html
+
+------------------------------------------------------------------------------
+-- number of days to cut off old news
+oldCutoff :: Integer
+oldCutoff = 365 * 5
+------------------------------------------------------------------------------
+
+
+data NewsDate
+  = OneDate Day
+  | DateRange Day Day
+  deriving (Show, Eq)
+
+startDate :: NewsDate -> Day
+startDate (OneDate d) = d
+startDate (DateRange s e) = s
+
+newsDateToHTML :: NewsDate -> HTML
+newsDateToHTML (OneDate day) = formatTime defaultTimeLocale "%e %B %Y" day
+newsDateToHTML (DateRange start end) =
+  let (sy, sm, sd) = toGregorian start
+      (ey, em, ed) = toGregorian end
+      wholeMonths = sd == 1 && ed == gregorianMonthLength ey em
+  in case (sy == ey, sm == em, sd == ed, wholeMonths) of
+    (True, True, True, _) -> newsDateToHTML (OneDate start)
+    (True, True, False, True)   -> fmt "%B %Y" end
+    (True, True, False, False)  -> fmt "%e" start ++ dash ++ fmt "%e %B %Y" end
+    (True, False, False, True)  -> fmt "%B" start ++ dash ++ fmt "%B %Y" end
+    (True, False, False, False) -> fmt "%e %B" start ++ dash ++ fmt "%e %B %Y" end
+    (_, _, _, True)             -> fmt "%B %Y" start ++ dash ++ fmt "%B %Y" end
+    _                           -> fmt "%e %B %Y" start ++ dash ++ fmt "%e %B %Y" end
+  where fmt = formatTime defaultTimeLocale
+        dash = " – "
+
+instance Ord NewsDate where
+  compare = compare `on` startDate
+
+data News = News
+  { date :: NewsDate
+  , desc :: String
+  }
+  deriving (Show, Eq)
+
+instance FromJSON News where
+  parseJSON = withObject "News" $ \ v -> do
+    desc <- v .: "description"
+    date <- single v <|> range v
+    pure (News date desc)
+    where
+      single v = do
+        date <- v .: "date" >>= parseTimeM True defaultTimeLocale "%e %B %Y"
+        pure (OneDate date)
+      range  v = do
+        start <- v .: "start" >>= parseTimeM True defaultTimeLocale "%e %B %Y"
+        end <- v .: "end" >>= parseTimeM True defaultTimeLocale "%e %B %Y"
+        pure (DateRange start end)
+
+
+newsToHTML :: News -> HTML
+newsToHTML n = ddt (newsDateToHTML (date n), desc n)
+
+generateNews :: FilePath -> IO (HTML            -- current news
+                               , [(Year, HTML)] -- old news, grouped by year
+                               )
+generateNews file = do
+  now <- getCurrentTime
+  f <- BS.readFile file
+  case decodeEither' f of
+    Left err ->
+      error (show err)
+    Right news -> do
+      let (old, new) = partition (\ x -> date x < OneDate (addDays (-oldCutoff) (utctDay now))) news
+      let oldGrouped = groupBy (\ a b -> startYear a == startYear b) old
+      pure (dlist new, map (\ x -> (startYear (head x), dlist x)) oldGrouped)
+    where
+      startYear x = let (y,_,_) = toGregorian (startDate (date x)) in y
+      dlist [] = ""
+      dlist x = tag "dl" (unlines (map newsToHTML x))
+
+------------------------------------------------------------------------------
+pubsRSS :: Request
+pubsRSS = parseRequest_ "https://pureportal.strath.ac.uk/en/organisations/mathematically-structured-programming/publications/?format=rss"
+
+getPureRSS :: Int -- number of entries
+           -> IO [Item]
+getPureRSS n = do
+  manager <- newManager tlsManagerSettings
+  res <- httpLbs pubsRSS manager
+  case statusIsSuccessful (responseStatus res) of
+    False -> pure []
+    True -> do
+      case parseFeedSource (responseBody res) of
+        Nothing -> pure []
+        Just feed -> pure $ take n $ reverse $ sortOn (getItemPublishDate :: Item -> Maybe (Maybe UTCTime)) (feedItems feed)
+
+
+itemToHTML :: Item -> Maybe HTML
+itemToHTML i = do
+  -- title <- T.unpack <$> getItemTitle i
+  -- link <- T.unpack <$> getItemLink i
+  -- title and link are included in the description
+  desc <- T.unpack <$> getItemDescription i
+  pure desc
+
+main :: IO ()
+main = do
+
+  rss <- getPureRSS 5
+  let header = "### default.html(section.news=current,headtags=<link rel='stylesheet' href='{{rootPath}}css/pure.css' type='text/css'/>)\n<!-- DO NOT EDIT THIS FILE DIRECTLY — EDIT _news.yaml AND RUN GenerateNews.hs INSTEAD -->"
+  let items = catMaybes $ map itemToHTML rss
+  let pubs = if (null items) then "" else
+        div "recent-pubs" $
+        (h2 "Recent MSP publications") ++
+        (ulist items) ++
+        p ("See the " ++ (anchor "https://pureportal.strath.ac.uk/en/organisations/mathematically-structured-programming" "MSP PURE page") ++ " for a full list of recent papers, grants, etc.")
+  (newNews, oldNews) <- generateNews "_news.yaml"
+  let news = h2 "News" ++ newNews ++ if null oldNews then "" else h3 "Older News" ++ p ("See here for " ++ anchor "old-news.html" "older news" ++ ".")
+  let oldPage = h2 "Older news" ++ concatMap (\ (y, ds) -> h3 (show y) ++ ds) oldNews
+  writeFile "news.html" (header ++ pubs ++ news)
+  if null oldNews then pure () else writeFile "old-news.html" (header ++ oldPage)

Html.hs

@@ -2,19 +2,35 @@ module Html where
 
 type HTML = String
 
+tag :: String -> HTML -> HTML
+tag t content = "<" ++ t ++ ">" ++ content ++ "</" ++ t ++ ">"
+
 div :: String -> HTML -> HTML
 div klass content =
   "<div class=\"" ++ klass ++ "\">" ++ content ++ "</div>"
 
+hn :: Int -> HTML -> HTML
+hn n = tag ("h" ++ show n)
+
 h5 :: HTML -> HTML
-h5 content = "<h5>" ++ content ++ "</h5>"
+h5 = hn 5
+
+h3 :: HTML -> HTML
+h3 = hn 3
+
+h2 :: HTML -> HTML
+h2 = hn 2
 
 p :: HTML -> HTML
-p content = "<p>" ++ content ++ "</p>"
+p = tag "p"
 
 ulist :: [HTML] -> HTML
 ulist items = "<ul>" ++ concatMap (\item -> "<li>" ++ item ++ "</li>") items ++ "</ul>"
 
+
+ddt :: (HTML, HTML) -> HTML
+ddt (term, desc) = "<dt>" ++ term ++ "</dt><dd>" ++ desc ++ "</dd>"
+
 anchor :: String -> HTML -> HTML
 anchor url content = "<a href=\"" ++ url ++ "\">" ++ content ++ "</a>"
 

MSPweb.cabal

@@ -39,3 +39,17 @@ executable GeneratePeople
                     yaml,
                     bytestring
   default-language: Haskell2010
+
+executable GenerateNews
+  main-is:          GenerateNews.hs
+  other-modules:    Html
+  build-depends:    base,
+                    yaml,
+                    bytestring,
+                    http-client,
+                    http-client-tls,
+                    http-types,
+                    time,
+                    feed,
+                    text
+  default-language: Haskell2010

Makefile

@@ -32,13 +32,15 @@ default: local
 
 local:
 	runghc Generate101.hs
+	runghc GenerateNews.hs
 	runghc Generate.hs
 
 compile:
 	cabal build --builddir _dist
 
 local-compiled:
 	`cabal list-bin --builddir _dist Generate101`
+	`cabal list-bin --builddir _dist GenerateNews`
 	`cabal list-bin --builddir _dist Generate`