~jack/jackkelly-name

ref: 8de6f1521045b2fbc086cb30d9fc901d7170ab5a jackkelly-name/src/Blog/Archives.hs -rw-r--r-- 6.3 KiB
8de6f152Jack Kelly Import site code from unified repo 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
{-# LANGUAGE TupleSections #-}

module Blog.Archives (blogArchives) where

import           Blog.Posts (blogPostContext, blogPostsPattern)
import           Blog.Util (baseBlogContext, parseBlogDate)
import           Control.Lens (_1, _2, _3, view)
import           Data.Aeson (Value(..))
import           Data.Foldable (for_)
import           Data.Functor ((<&>))
import           Data.HashMap.Lazy ((!))
import           Data.List (sortBy)
import qualified Data.Map as M
import           Data.Map.Monoidal (MonoidalMap)
import qualified Data.Map.Monoidal as MM
import           Data.Ord (comparing)
import qualified Data.Text as T
import           Data.Time (defaultTimeLocale, months, toGregorian)
import           Formatting ((%), (%.), formatToString, int, left)
import           Hakyll
import           Site (Url(..), sectionLabel)

type Post = (Identifier, Metadata)
type PostsByDay
  = MonoidalMap Integer
     (MonoidalMap Int
      (MonoidalMap Int [Post]))

blogArchives :: Tags -> Rules ()
blogArchives tags = do
  postsByDay <- splitByDay <$> getAllMetadata blogPostsPattern
  archiveIndex postsByDay tags
  yearArchives postsByDay tags
  monthArchives postsByDay tags

splitByDay :: [(Identifier, Metadata)] -> PostsByDay
splitByDay = foldMap postToMap . sortBy (comparing postDate)
  where
    postDate (_, meta) =
      let String date = meta ! "date"
      in parseBlogDate $ T.unpack date

    postToMap post =
      let (year, month, day) = toGregorian $ postDate post
      in MM.singleton year . MM.singleton month $ MM.singleton day [post]

archiveIndex :: PostsByDay -> Tags -> Rules ()
archiveIndex postsByDay tags = create ["blog/archives/index.html"] $ do
  route idRoute
  compile $ do
    let
      tagItems :: Compiler [Item (String, Url, Int)]
      tagItems = sequenceA $ tagsMap tags <&> \(tag, idents) ->
        makeItem (tag, Url $ "/blog/archives/" <> tag, length idents)

      tagContext :: Context (String, Url, Int)
      tagContext = mconcat
        [ field "tag" $ pure . view _1 . itemBody
        , field "url" $ pure . unUrl . view _2 . itemBody
        , field "count" $ pure . show . view _3 . itemBody
        ]

      monthContext :: Context (String, Url, Int)
      monthContext = mconcat
        [ field "month" $ pure . view _1 . itemBody
        , field "url" $ pure . ('/':) .unUrl . view _2 . itemBody
        , field "count" $ pure . show . view _3 . itemBody
        ]

      monthItems :: Integer -> Compiler [Item (String, Url, Int)]
      monthItems year = sequenceA
        [ makeItem (monthName m, Url $ monthArchiveUrl y m, length posts)
        | (y, m, posts) <- reverse postsByMonth
        , y == year
        ]

      postsByMonth = foldMap collectMonthYear $ toAscList postsByDay

      yearContext :: Context (Integer, Url)
      yearContext = mconcat
        [ field "year" $ pure . show . view _1 . itemBody
        , field "url" $ pure . ('/':) . unUrl . view _2 . itemBody
        , listFieldWith "months" monthContext $ monthItems . view _1 . itemBody
        ]

      yearItems :: Compiler [Item (Integer, Url)]
      yearItems = sequenceA $ reverse (MM.keys postsByDay) <&> \year ->
        makeItem (year, Url $ yearArchiveUrl year)

      context = mconcat
        [ listField "tags" tagContext tagItems
        , listField "years" yearContext yearItems
        , constField "title" $ sectionLabel ["Blog", "All Posts"]
        , baseBlogContext
        ]

    makeItem ""
      >>= loadAndApplyTemplate "templates/blog/archives.html" context
      >>= loadAndApplyTemplate "templates/default.html" context
      >>= relativizeUrls

yearArchives :: PostsByDay -> Tags -> Rules ()
yearArchives postsByDay tags =
  for_ (toAscList postsByYear) $ \(year, posts) ->
    create [fromFilePath $ yearArchiveUrl year] $ do
      route idRoute
      compile $ do
        sortedPosts <- traverse load (fst <$> posts)
          >>= recentFirst
        postContext <- blogPostContext tags

        let context = mconcat
              [ constField "title" $
                  sectionLabel ["Blog", "Archives for " ++ show year]
              , listField "posts" postContext (pure sortedPosts)
              , baseBlogContext
              ]

        makeItem ""
          >>= loadAndApplyTemplate "templates/blog/year_archive.html" context
          >>= loadAndApplyTemplate "templates/default.html" context
          >>= relativizeUrls

  where
    postsByYear = collectYear <$> postsByDay

    collectYear :: MonoidalMap Int (MonoidalMap Int [Post]) -> [Post]
    collectYear = concatMap (concat . MM.elems) . MM.elems

monthArchives :: PostsByDay -> Tags -> Rules ()
monthArchives postsByDay tags = do
  for_ postsByMonth $ \(year, month, posts) ->
    let monthId = fromFilePath $ monthArchiveUrl year month
    in create [monthId] $ do
      route idRoute
      compile $ do
        sortedPosts <- traverse (`loadSnapshot` "content") (fst <$> posts)
          >>= recentFirst
        postContext <- blogPostContext tags

        let
          monthLabel = monthName month ++ " " ++ show year
          title = sectionLabel ["Blog", "Archives for " ++ monthLabel]
          context = mconcat
            [ listField "posts" postContext (pure sortedPosts)
            , constField "title" title
            , baseBlogContext
            ]

        makeItem ""
          >>= loadAndApplyTemplate "templates/blog/month_archive.html" context
          >>= loadAndApplyTemplate "templates/default.html" context
          >>= relativizeUrls

  where
    postsByMonth = foldMap collectMonthYear $ toAscList postsByDay

monthName :: Int -> String
monthName month = fst $ months defaultTimeLocale !! (month - 1)

monthArchiveUrl :: Integer -> Int -> String
monthArchiveUrl = formatToString pat where
  pat = "blog/archives/" % int % "/" % (left 2 '0' %. int) % "/index.html"

yearArchiveUrl :: Integer -> String
yearArchiveUrl year = "blog/archives/" ++ show year ++ "/index.html"

collectMonthYear
  :: (Integer, MonoidalMap Int (MonoidalMap Int [Post]))
  -> [(Integer, Int, [Post])]
collectMonthYear (year, postsForYear) =
  let collectMonth :: (Int, MonoidalMap Int [Post]) -> (Integer, Int, [Post])
      collectMonth (month, postsForMonth) =
        (year, month, mconcat $ MM.elems postsForMonth)
  in collectMonth <$> toAscList postsForYear

-- Not present in monoidal-containers-0.3.1.0, which is what
-- nixos-18.09 provides.
toAscList :: MonoidalMap k a -> [(k, a)]
toAscList = M.toAscList . MM.getMonoidalMap