generator/Site/Update.hs

   1 module Site.Update where
   2
   3 import Commonmark.Simple qualified as Markdown
   4 import Control.Monad.Logger (MonadLoggerIO, logErrorNS, logInfoNS)
   5 import Control.Monad.Trans.Resource (MonadResource, runResourceT)
   6 import Data.Char qualified as Char
   7 import Data.LVar (LVar)
   8 import Data.List qualified as List
   9 import Data.List.Split (splitOn)
  10 import Data.Map.Strict qualified as Map
  11 import Data.Set qualified as Set
  12 import Data.Some (Some)
  13 import Data.Text qualified as Text
  14 import Data.Time qualified as Time
  15 import Data.Time.Clock.POSIX qualified as Time
  16 import Ema.CLI qualified
  17 import Graphics.ThumbnailPlus qualified as Thumb
  18 import Network.URI.Slug (Slug, decodeSlug)
  19 import PyF
  20 import Relude
  21 import System.Directory qualified as FS
  22 import System.FilePath ((</>))
  23 import System.FilePath qualified as FS
  24 import System.IO.Error qualified as IO
  25 import System.Process (readProcess)
  26 import System.UnionMount qualified as Watch
  27 import Text.Pandoc.Definition qualified as Pandoc
  28 import Text.Pandoc.Walk qualified as Pandoc
  29 import Text.Read (read)
  30 import UnliftIO (MonadUnliftIO)
  31 import Prelude ()
  32
  33 import Site.Model
  34
  35 data Watch
  36   = -- | A file generated by flake.nix
  37     Watch_LastModified
  38   | Watch_Static_Pics
  39   | Watch_Special_Markdown
  40   | Watch_Posts_Markdown
  41   deriving (Eq, Show, Ord)
  42
  43 updateModel ::
  44   (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
  45   Some Ema.CLI.Action ->
  46   LVar Model ->
  47   m ()
  48 updateModel _ model =
  49   void
  50     . Watch.mountOnLVar
  51       "."
  52       [ (Watch_LastModified, "lastModified")
  53       , (Watch_Static_Pics, "static/pics/**/*.jpg")
  54       , (Watch_Special_Markdown, "special/**/*.md")
  55       , (Watch_Posts_Markdown, "posts/**/*.md")
  56       ]
  57       {-ignored-}
  58       [ "*~"
  59       , ".*"
  60       , "*.swp"
  61       , "*.swx"
  62       , "drafts/*"
  63       , "static/thumbs/**"
  64       ]
  65       {-current-} model
  66       {-initial-} Model
  67         { modelTime = Nothing
  68         , modelPosts = mempty
  69         , modelSpecials = mempty
  70         , modelPictures = mempty
  71         , modelLocalLinks = mempty
  72         }
  73     $ \case
  74       Watch_LastModified -> \filePath -> \case
  75         Watch.Delete -> pure $ \m -> m{modelTime = Nothing}
  76         Watch.Refresh _refreshAction () -> do
  77           lastMod <- readFile filePath
  78           modelTime <-
  79             either error (pure . Just) $
  80               Time.parseTimeM True Time.defaultTimeLocale "%s" lastMod
  81           pure $ \m -> m{modelTime}
  82       Watch_Static_Pics -> \filePath ->
  83         let slugs = (decodeSlug <$>) $ Text.splitOn "/" $ toText filePath
  84          in let thumbsDir = FS.joinPath $ ["static", "thumbs"] <> List.drop 2 (FS.splitPath filePath)
  85              in \case
  86                   Watch.Delete -> do
  87                     logInfoNS domainName [fmt|Removing thumbsDir {thumbsDir}|]
  88                     liftIO $ FS.removeDirectoryRecursive thumbsDir
  89                     pure $ \m -> m{modelPictures = Map.delete slugs (modelPictures m)}
  90                   Watch.Refresh refreshAction () ->
  91                     case refreshAction of
  92                       Watch.New -> do
  93                         thumbs <- runResourceT $ createThumbnails thumbsDir filePath
  94                         pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)}
  95                       Watch.Update -> do
  96                         thumbs <- runResourceT $ createThumbnails thumbsDir filePath
  97                         pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)}
  98                       Watch.Existing -> do
  99                         dirEither <- liftIO $ IO.tryIOError $ FS.listDirectory thumbsDir
 100                         thumbs <- case dirEither of
 101                           Left err
 102                             | IO.isDoesNotExistError err ->
 103                               runResourceT $ createThumbnails thumbsDir filePath
 104                             | otherwise -> error [fmt|{err:s}|]
 105                           Right dir ->
 106                             return $
 107                               List.sortOn (Thumb.width . fst) $
 108                                 dir <&> \fp -> (thumbSizeFromFilePath fp, thumbsDir </> fp)
 109                         pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)}
 110       Watch_Posts_Markdown -> \filePath ->
 111         loadMarkdown filePath $ \f m -> m{modelPosts = f (modelPosts m)}
 112       Watch_Special_Markdown -> \filePath ->
 113         loadMarkdown filePath $ \f m -> m{modelSpecials = f (modelSpecials m)}
 114
 115 loadMarkdown ::
 116   MonadIO m =>
 117   MonadLoggerIO m =>
 118   FilePath ->
 119   ((Map [Slug] Page -> Map [Slug] Page) -> Model -> Model) ->
 120   Watch.FileAction () ->
 121   m (Model -> Model)
 122 loadMarkdown filePath modifyModel =
 123   let pageSlugs =
 124         (decodeSlug <$>) $
 125           List.drop 1 $
 126             Text.splitOn "/" $
 127               toText $
 128                 FS.dropExtension filePath
 129    in \case
 130         Watch.Delete -> pure $ modifyModel $ Map.delete pageSlugs
 131         Watch.Refresh _refreshAction () -> do
 132           fileContent <- Relude.readFileText filePath
 133           Markdown.parseMarkdownWithFrontMatter
 134             Markdown.fullMarkdownSpec
 135             filePath
 136             fileContent
 137             & \case
 138               Right (Just Meta{..}, pageDoc) -> do
 139                 -- Get default Meta values from Git commits
 140                 -- in case their not specified within the Mardown FrontMatter.
 141                 -- Does not work within pure nix build because there is not .git there.
 142                 (authorDate, commitDate, authorName, authorMail) <-
 143                   liftIO (gitLog "%ad\n%cd\n%an\n%ae\n" filePath) <&> \case
 144                     (List.lines -> [log_ad, log_cd, log_an, log_ae]) ->
 145                       ( gregorianOfEpoch <$> readMaybe @Integer log_ad
 146                       , gregorianOfEpoch <$> readMaybe @Integer log_cd
 147                       , Just $ toText log_an
 148                       , Just $ toText log_ae
 149                       )
 150                     _ -> (Nothing, Nothing, Nothing, Nothing)
 151                 let pageLocalLinks =
 152                       (`Pandoc.query` pageDoc) $ \case
 153                         Pandoc.Link _attrs _label (uri, _title)
 154                           | not (Text.isInfixOf ":" uri) -> do
 155                             -- keep only local URIs
 156                             Set.singleton $ localLink pageSlugs uri
 157                         _inl -> Set.empty
 158                 pure $ \model ->
 159                   modifyModel
 160                     ( Map.insert
 161                         pageSlugs
 162                         Page
 163                           { pageMeta =
 164                               Meta
 165                                 { metaPublished = metaPublished <|> authorDate
 166                                 , metaUpdated = metaUpdated <|> commitDate
 167                                 , metaAuthors =
 168                                     metaAuthors
 169                                       <|> ( authorName <&> \entityName ->
 170                                               pure
 171                                                 Entity
 172                                                   { entityName
 173                                                   , entityMail = authorMail
 174                                                   }
 175                                           )
 176                                 , ..
 177                                 }
 178                           , pageDoc
 179                           , pageLocalLinks
 180                           }
 181                     )
 182                     model{modelLocalLinks = Map.insert pageSlugs pageLocalLinks (modelLocalLinks model)}
 183               {-
 184               pure $ modifyModel $ Map.insert pageSlugs Page {pageMeta = Meta{..}, ..}
 185               -}
 186               Left err -> id <$ logErrorNS domainName [fmt|Parse error on {filePath}: {err}|]
 187               _ -> id <$ logErrorNS domainName [fmt|Failed to parse Meta on {filePath}|]
 188
 189 createThumbnails ::
 190   MonadResource m =>
 191   MonadLoggerIO m =>
 192   FilePath ->
 193   FilePath ->
 194   m [(Thumb.Size, FilePath)]
 195 createThumbnails thumbsDir picPath = do
 196   liftIO $ FS.createDirectoryIfMissing True thumbsDir
 197   Thumb.createThumbnails thumbsConfig picPath >>= \case
 198     Thumb.CreatedThumbnails thumbs _releaseKeys -> do
 199       logInfoNS domainName [fmt|Creating {List.length thumbs} thumbs in {thumbsDir}|]
 200       liftIO $ do
 201         forM thumbs $ \thumb -> do
 202           let dest = thumbsDir </> thumbName thumb
 203           FS.copyFile (Thumb.thumbFp thumb) dest
 204           return (Thumb.thumbSize thumb, dest)
 205     err -> do
 206       logErrorNS domainName [fmt|Error: {show err :: String}|]
 207       return []
 208   where
 209     thumbsConfig =
 210       Thumb.Configuration
 211         { Thumb.maxFileSize = 10 * 1024 * 1024
 212         , Thumb.maxImageSize = Thumb.Size 4096 4096
 213         , Thumb.reencodeOriginal = Thumb.Never
 214         , Thumb.thumbnailSizes = List.map (\s -> (Thumb.Size s s, Nothing)) thumbSizes
 215         , Thumb.temporaryDirectory = FS.getTemporaryDirectory
 216         }
 217
 218 thumbSizes :: [Int]
 219 thumbSizes = [300, 800]
 220
 221 thumbName :: Thumb.Thumbnail -> String
 222 thumbName Thumb.Thumbnail{thumbSize = Thumb.Size{..}, ..} =
 223   [fmt|{width}x{height}.{(Char.toLower <$> show @String thumbFormat)}|]
 224
 225 thumbSizeFromFilePath :: FilePath -> Thumb.Size
 226 thumbSizeFromFilePath fp =
 227   case splitOn "x" $ List.reverse $ List.takeWhile (/= '-') $ List.reverse $ FS.takeBaseName fp of
 228     [w, h] -> Thumb.Size (read w) (read h)
 229     _ -> error [fmt|Cannot parse thumb's sizes from filepath: {fp}|]
 230
 231 utcOfEpoch :: Integral a => a -> Time.UTCTime
 232 utcOfEpoch = Time.posixSecondsToUTCTime . fromIntegral
 233 gregorianOfEpoch :: Integral a => a -> Time.Day
 234 gregorianOfEpoch = Time.utctDay . utcOfEpoch
 235
 236 gitLog :: String -> FilePath -> IO String
 237 gitLog format filePath =
 238   readProcess
 239     "git"
 240     [ "log"
 241     , "-1"
 242     , "HEAD"
 243     , "--pretty=format:" ++ format
 244     , "--date=format:%s"
 245     , filePath
 246     ]
 247     ""