mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
5cb5668295
The new pantry version in lts-22.6 was not compatible with the database and/or config on the stackage server.
107 lines
3.6 KiB
Haskell
107 lines
3.6 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
module Data.WebsiteContent
|
|
( WebsiteContent (..)
|
|
, StackRelease (..)
|
|
, Post (..)
|
|
, loadWebsiteContent
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
import CMarkGFM
|
|
import Data.GhcLinks
|
|
import Data.Yaml
|
|
import System.FilePath (takeFileName)
|
|
import Text.Blaze.Html (preEscapedToHtml)
|
|
import Types
|
|
|
|
data WebsiteContent = WebsiteContent
|
|
{ wcHomepage :: !Html
|
|
, wcAuthors :: !Html
|
|
, wcOlderReleases :: !Html
|
|
, wcGhcLinks :: !GhcLinks
|
|
, wcStackReleases :: ![StackRelease]
|
|
, wcPosts :: !(Vector Post)
|
|
, wcSpamPackages :: !(Set PackageNameP)
|
|
-- ^ Packages considered spam which should not be displayed.
|
|
}
|
|
|
|
data Post = Post
|
|
{ postTitle :: !Text
|
|
, postSlug :: !Text
|
|
, postAuthor :: !Text
|
|
, postTime :: !UTCTime
|
|
, postDescription :: !Text
|
|
, postBody :: !Html
|
|
}
|
|
|
|
loadWebsiteContent :: FilePath -> IO WebsiteContent
|
|
loadWebsiteContent dir = do
|
|
wcHomepage <- readHtml "homepage.html"
|
|
wcAuthors <- readHtml "authors.html"
|
|
wcOlderReleases <- readHtml "older-releases.html" `catchIO`
|
|
\_ -> readMarkdown "older-releases.md"
|
|
wcGhcLinks <- readGhcLinks $ dir </> "stackage-cli"
|
|
wcStackReleases <- decodeFileEither (dir </> "stack" </> "releases.yaml")
|
|
>>= either throwIO return
|
|
wcPosts <- loadPosts (dir </> "posts") `catchAny` \e -> do
|
|
putStrLn $ "Error loading posts: " ++ tshow e
|
|
return mempty
|
|
wcSpamPackages <- decodeFileEither (dir </> "spam-packages.yaml")
|
|
>>= either throwIO (return . setFromList)
|
|
return WebsiteContent {..}
|
|
where
|
|
readHtml fp = fmap preEscapedToMarkup $ readFileUtf8 $ dir </> fp
|
|
readMarkdown fp = fmap (preEscapedToHtml . commonmarkToHtml
|
|
[optSmart]
|
|
[extTable, extAutolink])
|
|
$ readFileUtf8 $ dir </> fp
|
|
|
|
loadPosts :: FilePath -> IO (Vector Post)
|
|
loadPosts dir =
|
|
fmap (sortBy (\x y -> postTime y `compare` postTime x))
|
|
$ runConduitRes
|
|
$ sourceDirectory dir
|
|
.| concatMapC (stripSuffix ".md")
|
|
.| mapMC loadPost
|
|
.| sinkVector
|
|
where
|
|
loadPost :: FilePath -> ResourceT IO Post
|
|
loadPost noExt = handleAny (\e -> throwString $ "Could not parse " ++ noExt ++ ".md: " ++ show e) $ do
|
|
bs <- readFile $ noExt ++ ".md"
|
|
let slug = pack $ takeFileName noExt
|
|
text = filter (/= '\r') $ decodeUtf8 bs
|
|
(frontmatter, body) <-
|
|
case lines text of
|
|
"---":rest ->
|
|
case break (== "---") rest of
|
|
(frontmatter, "---":body) -> return (unlines frontmatter, unlines body)
|
|
_ -> error "Missing closing --- on frontmatter"
|
|
_ -> error "Does not start with --- frontmatter"
|
|
case Data.Yaml.decodeEither' $ encodeUtf8 frontmatter of
|
|
Left e -> throwIO e
|
|
Right mkPost -> return $ mkPost slug $ preEscapedToHtml $ commonmarkToHtml
|
|
[optSmart]
|
|
[extTable, extAutolink]
|
|
body
|
|
|
|
instance (slug ~ Text, body ~ Html) => FromJSON (slug -> body -> Post) where
|
|
parseJSON = withObject "Post" $ \o -> do
|
|
postTitle <- o .: "title"
|
|
postAuthor <- o .: "author"
|
|
postTime <- o .: "timestamp"
|
|
postDescription <- o .: "description"
|
|
return $ \postSlug postBody -> Post {..}
|
|
|
|
data StackRelease = StackRelease
|
|
{ srName :: !Text
|
|
, srPattern :: !Text
|
|
}
|
|
instance FromJSON StackRelease where
|
|
parseJSON = withObject "StackRelease" $ \o -> StackRelease
|
|
<$> o .: "name"
|
|
<*> o .: "pattern"
|