Bundle.hs

-- | Bundle-level discovery for OKF concept documents.
module Okf.Bundle
  ( BundleError (..),
    Concept,
    LogFile (..),
    conceptFromDocument,
    conceptDescription,
    conceptDocument,
    conceptIdOf,
    conceptResource,
    conceptSourcePath,
    conceptTags,
    conceptTitle,
    conceptType,
    findConcept,
    findConceptsByDocumentId,
    isReservedMarkdownFile,
    serializeConcept,
    walkBundle,
    walkLogs,
    writeBundle,
  )
where

import Control.Exception (IOException, try)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.List qualified as List
import Data.Text qualified as Text
import Data.Text.IO qualified as Text.IO
import Okf.ConceptId
import Okf.Document
import Okf.Log
import Okf.Prelude
import System.Directory
  ( createDirectoryIfMissing,
    doesDirectoryExist,
    listDirectory,
  )
import System.FilePath ((</>))
import System.FilePath qualified as FilePath
import System.IO.Error (ioeGetErrorString)

-- | A parsed concept document discovered in a bundle.
data Concept = Concept
  { id :: !ConceptId,
    sourcePath :: !FilePath,
    document :: !OKFDocument,
    type_ :: !Text,
    title :: !(Maybe Text),
    description :: !(Maybe Text),
    resource :: !(Maybe Text),
    tags :: ![Text]
  }
  deriving stock (Generic, Eq, Show)

-- | Filesystem or parser failures while walking a bundle.
data BundleError
  = InvalidConceptPath FilePath ConceptIdError
  | InvalidConceptDocument FilePath DocumentParseError
  | BundleIoError FilePath Text
  deriving stock (Generic, Eq, Show)

-- | A parsed @log.md@ reserved file discovered in a bundle.
data LogFile = LogFile
  { logSourcePath :: !FilePath,
    logContent :: !Log
  }
  deriving stock (Generic, Eq, Show)

-- | Discover and parse every non-reserved Markdown concept in a bundle.
walkBundle :: FilePath -> IO (Either BundleError [Concept])
walkBundle root = do
  discovered <- discoverMarkdownFiles root ""
  case discovered of
    Left bundleError -> pure (Left bundleError)
    Right paths -> do
      results <- mapM (readConcept root) paths
      pure (List.sortOn (renderConceptId . conceptIdOf) <$> sequenceA results)

-- | Discover and parse every @log.md@ reserved file in a bundle.
walkLogs :: FilePath -> IO (Either BundleError [LogFile])
walkLogs root = do
  discovered <- discoverLogFiles root ""
  case discovered of
    Left bundleError -> pure (Left bundleError)
    Right paths -> do
      results <- mapM (readLog root) paths
      pure (List.sortOn logSourcePath <$> sequenceA results)

-- | Find a concept by identifier in an already walked bundle.
findConcept :: ConceptId -> [Concept] -> Maybe Concept
findConcept conceptId =
  List.find (\concept -> conceptIdOf concept == conceptId)

-- | Find concepts whose frontmatter carries the given document handle. When a
-- field is supplied, only that key is examined; otherwise every frontmatter
-- value is searched. All matches are returned so callers can report ambiguity.
findConceptsByDocumentId :: Maybe Text -> Text -> [Concept] -> [Concept]
findConceptsByDocumentId fieldFilter handle =
  filter conceptMatches
  where
    conceptMatches concept =
      case fieldFilter of
        Just fieldName ->
          valueMatches (frontmatterLookup fieldName (documentFrontmatter concept))
        Nothing ->
          any (valueMatches . Just) (KeyMap.elems (fields (documentFrontmatter concept)))
    valueMatches (Just (String value)) = Text.strip value == handle
    valueMatches _ = False
    documentFrontmatter concept = frontmatter (conceptDocument concept)

-- | Extract a concept identifier without colliding with Prelude's `id`.
conceptIdOf :: Concept -> ConceptId
conceptIdOf Concept {id = conceptId} = conceptId

-- | Bundle-relative path the concept was read from or would be written to.
conceptSourcePath :: Concept -> FilePath
conceptSourcePath Concept {sourcePath} = sourcePath

-- | Parsed Markdown document backing the concept.
conceptDocument :: Concept -> OKFDocument
conceptDocument Concept {document} = document

-- | Required @type@ frontmatter field projected as text, or empty when invalid.
conceptType :: Concept -> Text
conceptType Concept {type_} = type_

conceptTitle :: Concept -> Maybe Text
conceptTitle Concept {title} = title

conceptDescription :: Concept -> Maybe Text
conceptDescription Concept {description} = description

conceptResource :: Concept -> Maybe Text
conceptResource Concept {resource} = resource

conceptTags :: Concept -> [Text]
conceptTags Concept {tags} = tags

-- | Reserved Markdown filenames are not normal concept documents.
isReservedMarkdownFile :: FilePath -> Bool
isReservedMarkdownFile path =
  FilePath.takeFileName path `List.elem` ["index.md", "log.md"]

discoverMarkdownFiles :: FilePath -> FilePath -> IO (Either BundleError [FilePath])
discoverMarkdownFiles root relativeDir = do
  let absoluteDir = root </> relativeDir
      displayDir = if null relativeDir then root else relativeDir
  listed <- tryBundleIo displayDir (listDirectory absoluteDir)
  case listed of
    Left bundleError -> pure (Left bundleError)
    Right entries -> do
      discovered <-
        for
          (List.sort entries)
          ( \entry -> do
              let relativePath = relativeDir </> entry
                  absolutePath = root </> relativePath
              isDirectory <- tryBundleIo relativePath (doesDirectoryExist absolutePath)
              case isDirectory of
                Left bundleError -> pure (Left bundleError)
                Right True -> discoverMarkdownFiles root relativePath
                Right False ->
                  pure
                    ( Right
                        [ FilePath.normalise relativePath
                        | FilePath.takeExtension entry == ".md",
                          not (isReservedMarkdownFile entry)
                        ]
                    )
          )
      pure (concat <$> sequenceA discovered)

discoverLogFiles :: FilePath -> FilePath -> IO (Either BundleError [FilePath])
discoverLogFiles root relativeDir = do
  let absoluteDir = root </> relativeDir
      displayDir = if null relativeDir then root else relativeDir
  listed <- tryBundleIo displayDir (listDirectory absoluteDir)
  case listed of
    Left bundleError -> pure (Left bundleError)
    Right entries -> do
      discovered <-
        for
          (List.sort entries)
          ( \entry -> do
              let relativePath = relativeDir </> entry
                  absolutePath = root </> relativePath
              isDirectory <- tryBundleIo relativePath (doesDirectoryExist absolutePath)
              case isDirectory of
                Left bundleError -> pure (Left bundleError)
                Right True -> discoverLogFiles root relativePath
                Right False ->
                  pure
                    ( Right
                        [ FilePath.normalise relativePath
                        | entry == "log.md"
                        ]
                    )
          )
      pure (concat <$> sequenceA discovered)

-- | Write every concept to @root/\<conceptId\>.md@, creating parent directories
-- as needed, using 'serializeDocument' for the file contents. Existing files for
-- the given concepts are overwritten; files NOT corresponding to a supplied
-- concept are left untouched (a producer wanting a pristine output directory
-- should clear it first). Does not validate; run 'Okf.Validation.validateBundle'
-- first if you want referential-integrity guarantees.
writeBundle :: FilePath -> [Concept] -> IO ()
writeBundle root concepts =
  mapM_ writeConcept concepts
  where
    writeConcept concept = do
      let relativePath = conceptIdToFilePath (conceptIdOf concept)
          absolutePath = root </> relativePath
      createDirectoryIfMissing True (FilePath.takeDirectory absolutePath)
      Text.IO.writeFile absolutePath (serializeConcept concept)

-- | Serialize a single concept's document to a Markdown string.
serializeConcept :: Concept -> Text
serializeConcept = serializeDocument . document

readConcept :: FilePath -> FilePath -> IO (Either BundleError Concept)
readConcept root relativePath = do
  loaded <- tryBundleIo relativePath (Text.IO.readFile (root </> relativePath))
  pure
    ( do
        content <- loaded
        conceptId <- first (InvalidConceptPath relativePath) (conceptIdFromFilePath relativePath)
        document <- first (InvalidConceptDocument relativePath) (parseDocument content)
        pure (conceptAt conceptId relativePath document)
    )

readLog :: FilePath -> FilePath -> IO (Either BundleError LogFile)
readLog root relativePath = do
  loaded <- tryBundleIo relativePath (Text.IO.readFile (root </> relativePath))
  pure
    ( do
        content <- loaded
        pure (LogFile {logSourcePath = relativePath, logContent = parseLog content})
    )

tryBundleIo :: FilePath -> IO value -> IO (Either BundleError value)
tryBundleIo path action = do
  result <- try action
  pure
    ( case result of
        Right value -> Right value
        Left (exception :: IOException) -> Left (BundleIoError path (Text.pack (ioeGetErrorString exception)))
    )

-- | Build a 'Concept' from its identity and document. The typed projection
-- fields (@type_@, @title@, @description@, @resource@, @tags@) are derived from
-- the document's frontmatter, so they can never disagree with it. The source
-- path is derived from the concept ID. Use this when assembling concepts in
-- memory (for 'writeBundle' or 'Okf.Validation.validateBundle').
conceptFromDocument :: ConceptId -> OKFDocument -> Concept
conceptFromDocument conceptId =
  conceptAt conceptId (conceptIdToFilePath conceptId)

-- | Build a 'Concept' with an explicit on-disk source path (used by the reader).
conceptAt :: ConceptId -> FilePath -> OKFDocument -> Concept
conceptAt conceptId relativePath document =
  Concept
    { id = conceptId,
      sourcePath = relativePath,
      document,
      type_ = textField "type" (frontmatter document),
      title = optionalTextField "title" (frontmatter document),
      description = optionalTextField "description" (frontmatter document),
      resource = optionalTextField "resource" (frontmatter document),
      tags = tagsField (frontmatter document)
    }

textField :: Text -> Frontmatter -> Text
textField key frontmatter =
  fromMaybe "" (optionalTextField key frontmatter)

optionalTextField :: Text -> Frontmatter -> Maybe Text
optionalTextField key frontmatter =
  case frontmatterLookup key frontmatter of
    Just (String value) -> Just value
    _ -> Nothing

tagsField :: Frontmatter -> [Text]
tagsField frontmatter =
  case frontmatterLookup "tags" frontmatter of
    Just (Array values) -> foldMap tagValue values
    Just (String value) -> [value]
    _ -> []
  where
    tagValue (String value) = [value]
    tagValue _ = []