1 module Site.Model where
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
13 import Graphics.ThumbnailPlus qualified as Thumb
14 import Network.URI.Slug (Slug (..), decodeSlug, encodeSlug)
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 (..))
28 domainName = "sourcephile.fr"
31 orgName = "Sourcephile"
35 {- | The state used to generate the site.
36 Changing the model automatically changes the view.
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)
46 backLinks :: HasCallStack => LocalLink -> Map [Slug] (Set LocalLink) -> Set [Slug]
50 if Set.member page lls
58 , pageLocalLinks :: Set LocalLink
61 -- *** Type 'LocalLink'
62 newtype LocalLink = LocalLink [Slug]
63 deriving (Eq, Ord, Show)
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
71 go $ base <> decodeSlugs relTarget
74 s : ".." : ss -> go ss
80 { metaAuthors :: Maybe (NonEmpty Entity)
82 , metaPublished :: Maybe Time.Day
83 , metaLisense :: Maybe Text
84 , metaSummary :: Maybe Markdown
86 , metaUpdated :: Maybe Time.Day
87 , metatags :: Maybe (NonEmpty Tag)
88 , metaDiscussion :: Maybe Discussion
90 deriving (Show, Generic)
91 instance FromJSON Meta where
95 { fieldLabelModifier = \case
96 (drop 4 -> c : cs) -> Char.toLower c : cs
100 -- | 'metaTags can't be a list to be able to derive FromJSON
101 metaTags :: Meta -> [Tag]
102 metaTags = maybe [] toList . metatags
104 -- **** Type 'Markdown'
105 data Markdown = Markdown
106 { markdownText :: Text
107 , markdownPandoc :: Pandoc
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)
116 -- **** Type 'Discussion'
117 data Discussion = Discussion
118 { discussionUrl :: Text
119 , discussionMail :: Text
121 deriving (Show, Eq, Ord, Generic)
122 instance FromJSON Discussion where
126 { fieldLabelModifier = \case
127 (drop 10 -> c : cs) -> Char.toLower c : cs
131 -- **** Type 'Entity'
134 , entityMail :: Maybe Text
136 deriving (Show, Eq, Ord, Generic)
137 instance FromJSON Entity where
141 { fieldLabelModifier = \case
142 (drop 6 -> c : cs) -> Char.toLower c : cs
147 newtype Tag = Tag {unTag :: Text}
148 deriving stock (Show, Eq, Ord, Generic)
149 deriving (FromJSON) via Text
151 allTags :: HasCallStack => Model -> [Tag]
155 . List.sortOn List.length
159 . (metaTags . pageMeta <$>)
167 | RouteFilterAtom Filter
169 | RouteSpecial [Slug]
172 hrefRoute :: HasCallStack => Model -> Route -> H.Attribute
173 hrefRoute model route = A.href $ H.textValue $ {-"/" <>-} Ema.routeUrl model (Right @FilePath route)
175 absoluteLink :: HasCallStack => Model -> Either FilePath Route -> Text
176 absoluteLink model route = [fmt|https://{domainName}/{Ema.routeUrl model route}|]
178 encodeSlugs :: HasCallStack => [Slug] -> Text
179 encodeSlugs slugs = Text.concat $ "/" : List.intersperse "/" (encodeSlug <$> slugs)
181 decodeSlugs :: HasCallStack => Text -> [Slug]
182 decodeSlugs = (decodeSlug <$>) . Text.splitOn "/"
184 routeElem :: HasCallStack => Model -> Route -> H.Html -> H.Html
185 routeElem model route =
187 ! hrefRoute model route
189 [ "hover:bg-blue-600"
195 instance Ema (Either FilePath Route) where
196 type ModelFor (Either FilePath Route) = Model
198 -- Where to generate this Route.
199 -- Called by Ema.routeUrl
200 encodeRoute model@Model{..} = either id $ \case
202 | Just{} <- Map.lookup page modelPosts ->
205 | Just{} <- Map.lookup page modelSpecials ->
207 RouteFilter Filter{filterTag = Nothing, filterLang = Nothing} ->
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
217 --error [fmt|Route {notFound:s} does not exist.|]
220 allTagsModel = allTags model
222 pathOf suffix = toString . (<> "." <> suffix) . encodeSlugs
224 -- Which route does this filepath correspond to?
225 decodeRoute Model{..} filePath@(toText -> route)
227 | Text.isPrefixOf "static/" route = Just $ Left filePath
229 | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".xml" route =
231 "feed" : (decodeFilter -> Just filt) ->
232 Just $ Right $ RouteFilterAtom filt
235 | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".html" route =
237 ["feeds"] -> Just $ Right RouteFeeds
238 "list" : (decodeFilter -> Just filt) ->
239 Just $ Right $ RouteFilter filt
240 ["post"] -> Just $ Right $ RouteFilter noFilter
242 | Map.member pageName modelPosts ->
243 Just $ Right $ RoutePage pageName
245 | Map.member pageName modelSpecials ->
246 Just $ Right $ RouteSpecial pageName
249 | otherwise = Nothing
251 -- The routes to statically generate
252 -- (not used by the live-server).
254 [Left "static", Right RouteFeeds]
260 allPages = Right . RoutePage <$> Map.keys (modelPosts model)
261 allSpecials = Right . RouteSpecial <$> Map.keys (modelSpecials model)
264 | filterLang <- Nothing : (Just <$> [minBound ..])
265 , filterTag <- Nothing : (Just <$> toList (allTags model))
267 feeds = Right . RouteFilterAtom <$> allIndices
268 lists = Right . RouteFilter <$> allIndices
272 -- Because the static site cannot afford
273 -- to generate all intersecting categories,
274 -- therefore select only a few whose intersection makes sense.
276 { filterLang :: Maybe Lang
277 , filterTag :: Maybe Tag
284 { filterLang = Nothing
285 , filterTag = Nothing
288 encodeFilter :: HasCallStack => Filter -> [Slug]
289 encodeFilter Filter{..} =
290 decodeSlug <$> case filterTag of
292 Just tag -> ["tag", unTag tag] <> langTag
294 langTag = textOfLang <$> maybeToList filterLang
296 decodeFilter :: HasCallStack => [Slug] -> Maybe Filter
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, ..}
305 data Content = Content
306 { contentTitle :: Maybe Text
307 , contentHtml :: H.Html
308 -- , contentLang :: Maybe Lang