module Site.Update where import Commonmark.Simple qualified as Markdown import Control.Monad.Logger (MonadLoggerIO, logErrorNS, logInfoNS) import Control.Monad.Trans.Resource (MonadResource, runResourceT) import Data.Char qualified as Char import Data.LVar (LVar) import Data.List qualified as List import Data.List.Split (splitOn) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Some (Some) import Data.Text qualified as Text import Data.Time qualified as Time import Data.Time.Clock.POSIX qualified as Time import Ema.CLI qualified import Graphics.ThumbnailPlus qualified as Thumb import Network.URI.Slug (Slug, decodeSlug) import PyF import Relude import System.Directory qualified as FS import System.FilePath (()) import System.FilePath qualified as FS import System.IO.Error qualified as IO import System.Process (readProcess) import System.UnionMount qualified as Watch import Text.Pandoc.Definition qualified as Pandoc import Text.Pandoc.Walk qualified as Pandoc import Text.Read (read) import UnliftIO (MonadUnliftIO) import Prelude () import Site.Model data Watch = -- | A file generated by flake.nix Watch_LastModified | Watch_Static_Pics | Watch_Special_Markdown | Watch_Posts_Markdown deriving (Eq, Show, Ord) updateModel :: (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => Some Ema.CLI.Action -> LVar Model -> m () updateModel _ model = void . Watch.mountOnLVar "." [ (Watch_LastModified, "lastModified") , (Watch_Static_Pics, "static/pics/**/*.jpg") , (Watch_Special_Markdown, "special/**/*.md") , (Watch_Posts_Markdown, "posts/**/*.md") ] {-ignored-} [ "*~" , ".*" , "*.swp" , "*.swx" , "drafts/*" , "static/thumbs/**" ] {-current-} model {-initial-} Model { modelTime = Nothing , modelPosts = mempty , modelSpecials = mempty , modelPictures = mempty , modelLocalLinks = mempty } $ \case Watch_LastModified -> \filePath -> \case Watch.Delete -> pure $ \m -> m{modelTime = Nothing} Watch.Refresh _refreshAction () -> do lastMod <- readFile filePath modelTime <- either error (pure . Just) $ Time.parseTimeM True Time.defaultTimeLocale "%s" lastMod pure $ \m -> m{modelTime} Watch_Static_Pics -> \filePath -> let slugs = (decodeSlug <$>) $ Text.splitOn "/" $ toText filePath in let thumbsDir = FS.joinPath $ ["static", "thumbs"] <> List.drop 2 (FS.splitPath filePath) in \case Watch.Delete -> do logInfoNS domainName [fmt|Removing thumbsDir {thumbsDir}|] liftIO $ FS.removeDirectoryRecursive thumbsDir pure $ \m -> m{modelPictures = Map.delete slugs (modelPictures m)} Watch.Refresh refreshAction () -> case refreshAction of Watch.New -> do thumbs <- runResourceT $ createThumbnails thumbsDir filePath pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)} Watch.Update -> do thumbs <- runResourceT $ createThumbnails thumbsDir filePath pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)} Watch.Existing -> do dirEither <- liftIO $ IO.tryIOError $ FS.listDirectory thumbsDir thumbs <- case dirEither of Left err | IO.isDoesNotExistError err -> runResourceT $ createThumbnails thumbsDir filePath | otherwise -> error [fmt|{err:s}|] Right dir -> return $ List.sortOn (Thumb.width . fst) $ dir <&> \fp -> (thumbSizeFromFilePath fp, thumbsDir fp) pure $ \m -> m{modelPictures = Map.insert slugs thumbs (modelPictures m)} Watch_Posts_Markdown -> \filePath -> loadMarkdown filePath $ \f m -> m{modelPosts = f (modelPosts m)} Watch_Special_Markdown -> \filePath -> loadMarkdown filePath $ \f m -> m{modelSpecials = f (modelSpecials m)} loadMarkdown :: MonadIO m => MonadLoggerIO m => FilePath -> ((Map [Slug] Page -> Map [Slug] Page) -> Model -> Model) -> Watch.FileAction () -> m (Model -> Model) loadMarkdown filePath modifyModel = let pageSlugs = (decodeSlug <$>) $ List.drop 1 $ Text.splitOn "/" $ toText $ FS.dropExtension filePath in \case Watch.Delete -> pure $ modifyModel $ Map.delete pageSlugs Watch.Refresh _refreshAction () -> do fileContent <- Relude.readFileText filePath Markdown.parseMarkdownWithFrontMatter Markdown.fullMarkdownSpec filePath fileContent & \case Right (Just Meta{..}, pageDoc) -> do -- Get default Meta values from Git commits -- in case their not specified within the Mardown FrontMatter. -- Does not work within pure nix build because there is not .git there. (authorDate, commitDate, authorName, authorMail) <- liftIO (gitLog "%ad\n%cd\n%an\n%ae\n" filePath) <&> \case (List.lines -> [log_ad, log_cd, log_an, log_ae]) -> ( gregorianOfEpoch <$> readMaybe @Integer log_ad , gregorianOfEpoch <$> readMaybe @Integer log_cd , Just $ toText log_an , Just $ toText log_ae ) _ -> (Nothing, Nothing, Nothing, Nothing) let pageLocalLinks = (`Pandoc.query` pageDoc) $ \case Pandoc.Link _attrs _label (uri, _title) | not (Text.isInfixOf ":" uri) -> do -- keep only local URIs Set.singleton $ localLink pageSlugs uri _inl -> Set.empty pure $ \model -> modifyModel ( Map.insert pageSlugs Page { pageMeta = Meta { metaPublished = metaPublished <|> authorDate , metaUpdated = metaUpdated <|> commitDate , metaAuthors = metaAuthors <|> ( authorName <&> \entityName -> pure Entity { entityName , entityMail = authorMail } ) , .. } , pageDoc , pageLocalLinks } ) model{modelLocalLinks = Map.insert pageSlugs pageLocalLinks (modelLocalLinks model)} {- pure $ modifyModel $ Map.insert pageSlugs Page {pageMeta = Meta{..}, ..} -} Left err -> id <$ logErrorNS domainName [fmt|Parse error on {filePath}: {err}|] _ -> id <$ logErrorNS domainName [fmt|Failed to parse Meta on {filePath}|] createThumbnails :: MonadResource m => MonadLoggerIO m => FilePath -> FilePath -> m [(Thumb.Size, FilePath)] createThumbnails thumbsDir picPath = do liftIO $ FS.createDirectoryIfMissing True thumbsDir Thumb.createThumbnails thumbsConfig picPath >>= \case Thumb.CreatedThumbnails thumbs _releaseKeys -> do logInfoNS domainName [fmt|Creating {List.length thumbs} thumbs in {thumbsDir}|] liftIO $ do forM thumbs $ \thumb -> do let dest = thumbsDir thumbName thumb FS.copyFile (Thumb.thumbFp thumb) dest return (Thumb.thumbSize thumb, dest) err -> do logErrorNS domainName [fmt|Error: {show err :: String}|] return [] where thumbsConfig = Thumb.Configuration { Thumb.maxFileSize = 10 * 1024 * 1024 , Thumb.maxImageSize = Thumb.Size 4096 4096 , Thumb.reencodeOriginal = Thumb.Never , Thumb.thumbnailSizes = List.map (\s -> (Thumb.Size s s, Nothing)) thumbSizes , Thumb.temporaryDirectory = FS.getTemporaryDirectory } thumbSizes :: [Int] thumbSizes = [300, 800] thumbName :: Thumb.Thumbnail -> String thumbName Thumb.Thumbnail{thumbSize = Thumb.Size{..}, ..} = [fmt|{width}x{height}.{(Char.toLower <$> show @String thumbFormat)}|] thumbSizeFromFilePath :: FilePath -> Thumb.Size thumbSizeFromFilePath fp = case splitOn "x" $ List.reverse $ List.takeWhile (/= '-') $ List.reverse $ FS.takeBaseName fp of [w, h] -> Thumb.Size (read w) (read h) _ -> error [fmt|Cannot parse thumb's sizes from filepath: {fp}|] utcOfEpoch :: Integral a => a -> Time.UTCTime utcOfEpoch = Time.posixSecondsToUTCTime . fromIntegral gregorianOfEpoch :: Integral a => a -> Time.Day gregorianOfEpoch = Time.utctDay . utcOfEpoch gitLog :: String -> FilePath -> IO String gitLog format filePath = readProcess "git" [ "log" , "-1" , "HEAD" , "--pretty=format:" ++ format , "--date=format:%s" , filePath ] ""