2023-04-15 23:30:38 -04:00
|
|
|
#! /usr/bin/env nix-shell
|
|
|
|
#! nix-shell -p "haskellPackages.ghcWithPackages (ps: with ps; [dhall neat-interpolation random])"
|
|
|
|
#! nix-shell -i runghc
|
2023-05-08 17:38:50 -04:00
|
|
|
|
2023-04-15 23:30:38 -04:00
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
-- enter in repl:
|
|
|
|
-- :set -XOverloadedStrings
|
|
|
|
|
|
|
|
import Control.Monad (forM, forM_, replicateM, unless, when)
|
|
|
|
import Data.List (sort)
|
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Data.Text.IO as TIO
|
2023-08-08 17:26:50 -04:00
|
|
|
import Data.Time.Calendar (Day, addDays, diffDays, toGregorian)
|
2023-04-15 23:30:38 -04:00
|
|
|
import Data.Time.Clock (UTCTime (utctDay), getCurrentTime)
|
|
|
|
import Dhall (FromDhall, Generic, auto, input)
|
|
|
|
import NeatInterpolation (text)
|
2023-04-16 15:28:41 -04:00
|
|
|
-- https://hackage.haskell.org/package/neat-interpolation-0.3.2.1/docs/NeatInterpolation.html
|
2023-04-15 23:30:38 -04:00
|
|
|
import System.Directory (createDirectoryIfMissing, doesFileExist,
|
|
|
|
listDirectory)
|
|
|
|
import System.IO.Unsafe (unsafePerformIO)
|
2023-08-08 17:26:50 -04:00
|
|
|
import System.Random (Random (randoms), mkStdGen)
|
2023-04-16 15:28:41 -04:00
|
|
|
|
2023-04-15 23:30:38 -04:00
|
|
|
|
|
|
|
{-
|
2023-04-16 15:28:41 -04:00
|
|
|
Config, loaded from a dhall file
|
2023-04-15 23:30:38 -04:00
|
|
|
-}
|
2023-04-16 15:28:41 -04:00
|
|
|
data Config = Config
|
|
|
|
{ adjectives1 :: [Text]
|
|
|
|
, adjectives2 :: [Text]
|
|
|
|
, looks :: [Text]
|
|
|
|
, sealImagesPath :: FilePath
|
|
|
|
, postsOutputPath :: FilePath
|
|
|
|
, startDate :: Day
|
2023-08-08 17:26:50 -04:00
|
|
|
, seed :: Int
|
2023-04-16 15:28:41 -04:00
|
|
|
} deriving (Generic, Show)
|
|
|
|
instance FromDhall Config
|
|
|
|
|
2023-04-15 23:30:38 -04:00
|
|
|
|
|
|
|
{-
|
2023-04-16 15:28:41 -04:00
|
|
|
Main function
|
2023-04-15 23:30:38 -04:00
|
|
|
-}
|
2023-04-16 15:28:41 -04:00
|
|
|
main :: IO ()
|
|
|
|
main = do
|
|
|
|
putStrLn "Starting blog post generation script"
|
|
|
|
|
|
|
|
config <- input auto "./config.dhall"
|
|
|
|
let postsOutputPath' = postsOutputPath config
|
|
|
|
putStrLn "Validated config successfully"
|
|
|
|
|
|
|
|
createDirectoryIfMissing True postsOutputPath'
|
2023-05-08 17:38:50 -04:00
|
|
|
generateAllBlogPosts config
|
2023-04-16 15:28:41 -04:00
|
|
|
putStrLn $ "Generated blog posts successfully to " <> postsOutputPath'
|
|
|
|
|
2023-04-15 23:30:38 -04:00
|
|
|
|
2023-04-16 15:28:41 -04:00
|
|
|
{-
|
|
|
|
For all the blog posts
|
|
|
|
Write them to file
|
|
|
|
-}
|
2023-05-08 17:38:50 -04:00
|
|
|
generateAllBlogPosts :: Config -> IO ()
|
|
|
|
generateAllBlogPosts config = forM_ allBlogPosts' writeToFile'
|
|
|
|
where
|
|
|
|
allBlogPosts' = allBlogPosts config
|
|
|
|
writeToFile' = writeToFile config
|
2023-04-16 15:28:41 -04:00
|
|
|
|
|
|
|
allBlogPosts :: Config -> [(FilePath, Text)]
|
2023-05-08 17:38:50 -04:00
|
|
|
allBlogPosts config = map createSealText zippedDates
|
2023-04-16 15:28:41 -04:00
|
|
|
where
|
2023-08-08 17:26:50 -04:00
|
|
|
createSealText = uncurry3 $ sealText config
|
|
|
|
zippedDates = zip3 [1..] randomNumbers (allDatesSince (startDate config))
|
|
|
|
randomNumbers = randoms (mkStdGen (seed config))
|
|
|
|
|
|
|
|
-- | Converts a curried function to a function on a triple.
|
|
|
|
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
|
|
|
|
uncurry3 f (a,b,c) = f a b c
|
2023-04-16 15:28:41 -04:00
|
|
|
|
2023-05-08 17:38:50 -04:00
|
|
|
allDatesSince :: Day -> [Day]
|
|
|
|
allDatesSince startDate = map (`addDays` startDate) [0..daysSinceStart]
|
|
|
|
where
|
|
|
|
daysSinceStart = diffDays today startDate
|
|
|
|
{-# NOINLINE today #-}
|
|
|
|
today = unsafePerformIO $ utctDay <$> getCurrentTime
|
2023-04-16 15:28:41 -04:00
|
|
|
|
|
|
|
writeToFile :: Config -> (FilePath, Text) -> IO()
|
|
|
|
writeToFile config (fp, txt) = do
|
|
|
|
fileExists <- doesFileExist fp'
|
|
|
|
unless fileExists (write fp' txt)
|
|
|
|
where
|
|
|
|
write = TIO.writeFile
|
|
|
|
fp' = postsOutputPath config <> "/" <> fp
|
|
|
|
|
|
|
|
|
|
|
|
{-
|
|
|
|
Returns a filePath, and a corresponding random blog post
|
|
|
|
-}
|
2023-08-08 17:26:50 -04:00
|
|
|
sealText :: Config -> Integer -> Int -> Day -> (FilePath, Text)
|
|
|
|
sealText config n rand date = ( fileName', bp )
|
2023-04-15 23:30:38 -04:00
|
|
|
where
|
|
|
|
fileName' =
|
|
|
|
show date <> "-"
|
|
|
|
<> "seal-post-"
|
|
|
|
<> show n
|
|
|
|
<> ".markdown"
|
|
|
|
date' = T.pack . show $ date
|
|
|
|
title = T.pack $ "Seal Post Number " <> show n
|
|
|
|
title' = T.replace " " "-" title
|
2023-05-08 17:38:50 -04:00
|
|
|
sealImagesPath' = sealImagesPath config
|
2023-04-16 15:28:41 -04:00
|
|
|
|
2023-04-15 23:30:38 -04:00
|
|
|
bp = blogPost' (toGregorian date)
|
|
|
|
|
|
|
|
blogPost' :: (Integer, Int, Int) -> Text
|
|
|
|
blogPost' (_, 09, 26) =
|
|
|
|
blogPost
|
|
|
|
title
|
|
|
|
"Birthdayingly gaze at"
|
|
|
|
"spoiled"
|
|
|
|
"older"
|
|
|
|
"birthdaySeal.jpg"
|
|
|
|
date
|
2023-05-08 17:38:50 -04:00
|
|
|
sealImagesPath'
|
2023-04-15 23:30:38 -04:00
|
|
|
|
|
|
|
blogPost' (_, 04, 01) =
|
|
|
|
blogPost
|
|
|
|
title
|
|
|
|
"Foolishly look at"
|
|
|
|
"beautiful"
|
|
|
|
"supermodel, singing"
|
2023-09-26 09:46:01 -04:00
|
|
|
"_singerSeal.jpg"
|
2023-04-15 23:30:38 -04:00
|
|
|
date
|
2023-05-08 17:38:50 -04:00
|
|
|
sealImagesPath'
|
2023-04-15 23:30:38 -04:00
|
|
|
|
|
|
|
blogPost' (_, _, _) =
|
|
|
|
blogPost
|
|
|
|
title
|
2023-08-08 17:26:50 -04:00
|
|
|
(randomPull rand (looks config))
|
|
|
|
(randomPull rand (adjectives1 config))
|
|
|
|
(randomPull rand (adjectives2 config))
|
|
|
|
(randomPull rand (unsafeListDirContents sealImagesPath'))
|
2023-04-15 23:30:38 -04:00
|
|
|
date
|
2023-05-08 17:38:50 -04:00
|
|
|
sealImagesPath'
|
2023-08-08 17:26:50 -04:00
|
|
|
where
|
|
|
|
randomPull r txts = txts !! (rand `mod` l)
|
|
|
|
where l = length txts - 1
|
|
|
|
|
|
|
|
{-
|
|
|
|
Blog post format
|
|
|
|
-}
|
|
|
|
blogPost
|
|
|
|
:: Text
|
|
|
|
-> Text
|
|
|
|
-> Text
|
|
|
|
-> Text
|
|
|
|
-> Text
|
|
|
|
-> Day
|
|
|
|
-> FilePath
|
|
|
|
-> Text
|
|
|
|
blogPost title see adj1 adj2 seal date imagesPath =
|
|
|
|
let imagesPath' = T.pack imagesPath
|
|
|
|
in
|
|
|
|
[text|
|
|
|
|
---
|
|
|
|
title: $title
|
|
|
|
---
|
|
|
|
|
|
|
|
$see this $adj1, $adj2 seal!
|
|
|
|
<img
|
|
|
|
src="/$imagesPath'/$seal"
|
|
|
|
alt="A picture of a $adj1, $adj2 seal! <3"
|
|
|
|
width="400"
|
|
|
|
/>
|
|
|
|
|]
|
2023-04-15 23:30:38 -04:00
|
|
|
|
|
|
|
|
|
|
|
{-
|
2023-04-16 15:28:41 -04:00
|
|
|
Utils
|
2023-04-15 23:30:38 -04:00
|
|
|
-}
|
|
|
|
unsafeListDirContents :: FilePath -> [Text]
|
2023-08-08 17:18:22 -04:00
|
|
|
unsafeListDirContents = map T.pack . drop 2 . sort . unsafePerformIO . listDirectory
|
|
|
|
-- ^^^^^^
|
|
|
|
-- drop 2 used to remove the birthday and singer photos
|
|
|
|
-- TODO: find a better way to hardcode this
|
2023-04-16 15:28:41 -04:00
|
|
|
|
|
|
|
prettyPrint :: Show a => [a] -> IO ()
|
|
|
|
prettyPrint = putStr . unlines . map show
|