generator/Site/Model.hs

   1 module Site.Model where
   2
   3 import Commonmark.Simple qualified as Markdown
   4 import Data.Aeson (FromJSON (..), Options (..), defaultOptions, genericParseJSON, withText)
   5 import Data.Char qualified as Char
   6 import Data.List qualified as List
   7 import Data.Map.Strict qualified as Map
   8 import Data.Set qualified as Set
   9 import Data.Text qualified as Text
  10 import Data.Time qualified as Time
  11 import Ema (Ema (..))
  12 import Ema qualified
  13 import Graphics.ThumbnailPlus qualified as Thumb
  14 import Network.URI.Slug (Slug (..), decodeSlug, encodeSlug)
  15 import PyF
  16 import Relude
  17 import Relude.Unsafe qualified as Unsafe
  18 import Text.Blaze.Html5 ((!))
  19 import Text.Blaze.Html5 qualified as H
  20 import Text.Blaze.Html5.Attributes qualified as A
  21 import Text.Pandoc.Definition (Pandoc (..))
  22 import Prelude ()
  23
  24 import Site.Lang
  25 import Utils.Html
  26
  27 domainName :: Text
  28 domainName = "sourcephile.fr"
  29
  30 orgName :: Text
  31 orgName = "Sourcephile"
  32
  33 -- * Type 'Model'
  34
  35 {- | The state used to generate the site.
  36  Changing the model automatically changes the view.
  37 -}
  38 data Model = Model
  39   { modelTime :: Maybe Time.UTCTime
  40   , modelPosts :: Map [Slug] Page
  41   , modelSpecials :: Map [Slug] Page
  42   , modelPictures :: Map [Slug] [(Thumb.Size, FilePath)]
  43   , modelLocalLinks :: Map [Slug] (Set LocalLink)
  44   }
  45
  46 backLinks :: HasCallStack => LocalLink -> Map [Slug] (Set LocalLink) -> Set [Slug]
  47 backLinks page =
  48   Map.foldMapWithKey
  49     ( \k lls ->
  50         if Set.member page lls
  51           then Set.singleton k
  52           else mempty
  53     )
  54 -- ** Type 'Page'
  55 data Page = Page
  56   { pageMeta :: Meta
  57   , pageDoc :: Pandoc
  58   , pageLocalLinks :: Set LocalLink
  59   }
  60
  61 -- *** Type 'LocalLink'
  62 newtype LocalLink = LocalLink [Slug]
  63   deriving (Eq, Ord, Show)
  64
  65 localLink :: HasCallStack => [Slug] -> Text -> LocalLink
  66 localLink base target = LocalLink
  67   case Text.span (== '/') target of
  68     (Text.isPrefixOf "/" -> True, absTarget) ->
  69       go $ decodeSlugs absTarget
  70     ("", relTarget) ->
  71       go $ base <> decodeSlugs relTarget
  72   where
  73     go = \case
  74       s : ".." : ss -> go ss
  75       ".." : ss -> go ss
  76       s : ss -> s : go ss
  77       [] -> []
  78 -- *** Type 'Meta'
  79 data Meta = Meta
  80   { metaAuthors :: Maybe (NonEmpty Entity)
  81   , metaLang :: Lang
  82   , metaPublished :: Maybe Time.Day
  83   , metaLisense :: Maybe Text
  84   , metaSummary :: Maybe Markdown
  85   , metaTitle :: Text
  86   , metaUpdated :: Maybe Time.Day
  87   , metatags :: Maybe (NonEmpty Tag)
  88   , metaDiscussion :: Maybe Discussion
  89   }
  90   deriving (Show, Generic)
  91 instance FromJSON Meta where
  92   parseJSON =
  93     genericParseJSON
  94       defaultOptions
  95         { fieldLabelModifier = \case
  96             (drop 4 -> c : cs) -> Char.toLower c : cs
  97             _ -> error ""
  98         }
  99
 100 -- | 'metaTags can't be a list to be able to derive FromJSON
 101 metaTags :: Meta -> [Tag]
 102 metaTags = maybe [] toList . metatags
 103
 104 -- **** Type 'Markdown'
 105 data Markdown = Markdown
 106   { markdownText :: Text
 107   , markdownPandoc :: Pandoc
 108   }
 109   deriving (Show)
 110 instance FromJSON Markdown where
 111   parseJSON = withText "Markdown" $ \markdownText ->
 112     case Markdown.parseMarkdown "" markdownText of
 113       Right markdownPandoc -> pure Markdown{..}
 114       Left err -> fail (toString err)
 115
 116 -- **** Type 'Discussion'
 117 data Discussion = Discussion
 118   { discussionUrl :: Text
 119   , discussionMail :: Text
 120   }
 121   deriving (Show, Eq, Ord, Generic)
 122 instance FromJSON Discussion where
 123   parseJSON =
 124     genericParseJSON
 125       defaultOptions
 126         { fieldLabelModifier = \case
 127             (drop 10 -> c : cs) -> Char.toLower c : cs
 128             _ -> error ""
 129         }
 130
 131 -- **** Type 'Entity'
 132 data Entity = Entity
 133   { entityName :: Text
 134   , entityMail :: Maybe Text
 135   }
 136   deriving (Show, Eq, Ord, Generic)
 137 instance FromJSON Entity where
 138   parseJSON =
 139     genericParseJSON
 140       defaultOptions
 141         { fieldLabelModifier = \case
 142             (drop 6 -> c : cs) -> Char.toLower c : cs
 143             _ -> error ""
 144         }
 145
 146 -- **** Type 'Tag'
 147 newtype Tag = Tag {unTag :: Text}
 148   deriving stock (Show, Eq, Ord, Generic)
 149   deriving (FromJSON) via Text
 150
 151 allTags :: HasCallStack => Model -> [Tag]
 152 allTags =
 153   reverse
 154     . (Unsafe.head <$>)
 155     . List.sortOn List.length
 156     . List.group
 157     . List.sort
 158     . List.concat
 159     . (metaTags . pageMeta <$>)
 160     . Map.elems
 161     . modelPosts
 162
 163 -- * Type 'Route'
 164 data Route
 165   = RouteFeeds
 166   | RouteFilter Filter
 167   | RouteFilterAtom Filter
 168   | RoutePage [Slug]
 169   | RouteSpecial [Slug]
 170   deriving (Show, Eq)
 171
 172 hrefRoute :: HasCallStack => Model -> Route -> H.Attribute
 173 hrefRoute model route = A.href $ H.textValue $ {-"/" <>-} Ema.routeUrl model (Right @FilePath route)
 174
 175 absoluteLink :: HasCallStack => Model -> Either FilePath Route -> Text
 176 absoluteLink model route = [fmt|https://{domainName}/{Ema.routeUrl model route}|]
 177
 178 encodeSlugs :: HasCallStack => [Slug] -> Text
 179 encodeSlugs slugs = Text.concat $ "/" : List.intersperse "/" (encodeSlug <$> slugs)
 180
 181 decodeSlugs :: HasCallStack => Text -> [Slug]
 182 decodeSlugs = (decodeSlug <$>) . Text.splitOn "/"
 183
 184 routeElem :: HasCallStack => Model -> Route -> H.Html -> H.Html
 185 routeElem model route =
 186   H.a
 187     ! hrefRoute model route
 188     ! classes
 189       [ "hover:bg-blue-600"
 190       , "inline-block"
 191       , "p-4"
 192       , "text-white"
 193       ]
 194
 195 instance Ema (Either FilePath Route) where
 196   type ModelFor (Either FilePath Route) = Model
 197
 198   -- Where to generate this Route.
 199   -- Called by Ema.routeUrl
 200   encodeRoute model@Model{..} = either id $ \case
 201     RoutePage page
 202       | Just{} <- Map.lookup page modelPosts ->
 203         html ("post" : page)
 204     RouteSpecial page
 205       | Just{} <- Map.lookup page modelSpecials ->
 206         html page
 207     RouteFilter Filter{filterTag = Nothing, filterLang = Nothing} ->
 208       html ["list", "tag"]
 209     RouteFilter filt@Filter{..}
 210       | maybe True (`elem` allTagsModel) filterTag ->
 211         html $ "list" : encodeFilter filt
 212     RouteFeeds -> html ["feeds"]
 213     RouteFilterAtom filt@Filter{..}
 214       | maybe True (`elem` allTagsModel) filterTag ->
 215         pathOf "xml" $ "feed" : encodeFilter filt
 216     _notFound ->
 217       --error [fmt|Route {notFound:s} does not exist.|]
 218       html ["not-found"]
 219     where
 220       allTagsModel = allTags model
 221       html = pathOf "html"
 222       pathOf suffix = toString . (<> "." <> suffix) . encodeSlugs
 223
 224   -- Which route does this filepath correspond to?
 225   decodeRoute Model{..} filePath@(toText -> route)
 226     -- Files
 227     | Text.isPrefixOf "static/" route = Just $ Left filePath
 228     -- XML
 229     | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".xml" route =
 230       case slugs of
 231         "feed" : (decodeFilter -> Just filt) ->
 232           Just $ Right $ RouteFilterAtom filt
 233         _ -> Nothing
 234     -- HTML
 235     | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".html" route =
 236       case slugs of
 237         ["feeds"] -> Just $ Right RouteFeeds
 238         "list" : (decodeFilter -> Just filt) ->
 239           Just $ Right $ RouteFilter filt
 240         ["post"] -> Just $ Right $ RouteFilter noFilter
 241         "post" : pageName
 242           | Map.member pageName modelPosts ->
 243             Just $ Right $ RoutePage pageName
 244         pageName
 245           | Map.member pageName modelSpecials ->
 246             Just $ Right $ RouteSpecial pageName
 247         _ -> Nothing
 248     -- 404
 249     | otherwise = Nothing
 250
 251   -- The routes to statically generate
 252   -- (not used by the live-server).
 253   allRoutes model =
 254     [Left "static", Right RouteFeeds]
 255     <> allPages
 256     <> allSpecials
 257     <> feeds
 258     <> lists
 259     where
 260       allPages = Right . RoutePage <$> Map.keys (modelPosts model)
 261       allSpecials = Right . RouteSpecial <$> Map.keys (modelSpecials model)
 262       allIndices =
 263         [ Filter{..}
 264         | filterLang <- Nothing : (Just <$> [minBound ..])
 265         , filterTag <- Nothing : (Just <$> toList (allTags model))
 266         ]
 267       feeds = Right . RouteFilterAtom <$> allIndices
 268       lists = Right . RouteFilter <$> allIndices
 269
 270 -- ** Type 'Filter'
 271
 272 -- Because the static site cannot afford
 273 -- to generate all intersecting categories,
 274 -- therefore select only a few whose intersection makes sense.
 275 data Filter = Filter
 276   { filterLang :: Maybe Lang
 277   , filterTag :: Maybe Tag
 278   }
 279   deriving (Show, Eq)
 280
 281 noFilter :: Filter
 282 noFilter =
 283   Filter
 284     { filterLang = Nothing
 285     , filterTag = Nothing
 286     }
 287
 288 encodeFilter :: HasCallStack => Filter -> [Slug]
 289 encodeFilter Filter{..} =
 290   decodeSlug <$> case filterTag of
 291     Nothing -> langTag
 292     Just tag -> ["tag", unTag tag] <> langTag
 293   where
 294     langTag = textOfLang <$> maybeToList filterLang
 295
 296 decodeFilter :: HasCallStack => [Slug] -> Maybe Filter
 297 decodeFilter = \case
 298   ["all", parseLang . encodeSlug -> filterLang] -> Just noFilter{filterLang}
 299   ["tag"] -> Just noFilter
 300   ["tag", Just . Tag . encodeSlug -> filterTag, parseLang . encodeSlug -> filterLang] -> Just Filter{..}
 301   ["tag", Just . Tag . encodeSlug -> filterTag] -> Just Filter{filterLang = Nothing, ..}
 302   _ -> Nothing
 303
 304 -- * Type 'Content'
 305 data Content = Content
 306   { contentTitle :: Maybe Text
 307   , contentHtml :: H.Html
 308   -- , contentLang :: Maybe Lang
 309   }