{-# 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"