diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,37 @@ ## [Unreleased] +## [0.1.1.0] - 2026-06-28 + +### Added + +- `okf --version`, including git SHA reporting for Cabal and Nix builds when + available. +- Shell completion generation for supported shells. +- `okf help` command with embedded conceptual topic guides (`okf`, `format`, + `validation`, `profiles`), including a guide explaining what the Open Knowledge + Format is. The guides are plain text baked into the binary at compile time, so + `okf help ` works with no network or docs checkout. +- Profile-based validation: `okf validate --profile .dhall` checks a + bundle against a team's house conventions (allowed `type` strings, required + frontmatter keys, `resource:` schemes, file layout, and `# Schema` columns) + declared in a Dhall descriptor. Profiles are not part of the OKF standard, so + deviations are advisory by default; `--profile-enforce` fails the command on + drift. Ships an example bundle (`examples/postgresql-sample`), a sample + descriptor (`docs/profiles/postgresql.dhall`), and a user guide + (`docs/user/profiles.md`). +- Log support: `okf-core` can parse, serialize, and validate `log.md` files; + `okf-cli` can preview, validate, author log entries, and report drift between + bundle logs and git history. +- Canonical OKF profile schema Dhall modules with drift tests. + +### Changed + +- Expanded the README and user guides to cover the current CLI, profile + validation, and log workflows. +- Updated release, Nix, and repository metadata so both packages build and check + as separate Hackage packages. + ## [0.1.0.0] - 2026-06-19 Initial release. diff --git a/okf-core.cabal b/okf-core.cabal --- a/okf-core.cabal +++ b/okf-core.cabal @@ -1,36 +1,32 @@ -cabal-version: 3.4 -name: okf-core -version: 0.1.0.0 -synopsis: Read, validate, index, and traverse Open Knowledge Format bundles +cabal-version: 3.4 +name: okf-core +version: 0.1.1.0 +synopsis: + Read, validate, index, and traverse Open Knowledge Format bundles + description: okf-core parses Open Knowledge Format (OKF) bundles -- plain Markdown-plus-YAML knowledge graphs -- into typed documents, builds a concept index and link graph, validates referential integrity, and writes bundles back out with a round-trip guarantee. -category: Data, Text -license: BSD-3-Clause -license-file: LICENSE -author: Nadeem Bitar -maintainer: nadeem@gmail.com -copyright: (c) 2026 Nadeem Bitar -build-type: Simple +category: Data, Text +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +build-type: Simple extra-doc-files: CHANGELOG.md common common-options ghc-options: - -Wall - -Wcompat - -Widentities - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -fhide-source-paths -Wmissing-export-lists -Wpartial-fields -Wmissing-deriving-strategies - default-language: GHC2024 + default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields @@ -38,44 +34,51 @@ OverloadedStrings library - import: common-options - hs-source-dirs: src + import: common-options + hs-source-dirs: src exposed-modules: Okf.Bundle Okf.ConceptId Okf.Document Okf.Graph Okf.Index + Okf.Log Okf.Prelude + Okf.Profile Okf.Validation build-depends: - aeson >=2.2 && <2.4, - attoparsec >=0.14 && <0.15, - base >=4.20 && <5, - bytestring >=0.11 && <0.13, - cmark-gfm ^>=0.2, - containers >=0.6 && <0.8, - directory >=1.3 && <1.4, - filepath >=1.4 && <1.6, - frontmatter >=0.1 && <0.2, - generic-lens >=2.2 && <2.4, - lens ^>=5.3, - text ^>=2.1, - vector >=0.13 && <0.14, - yaml >=0.11 && <0.12, + , aeson >=2.2 && <2.4 + , attoparsec >=0.14 && <0.15 + , base >=4.20 && <5 + , bytestring >=0.11 && <0.13 + , cmark-gfm ^>=0.2 + , containers >=0.6 && <0.8 + , dhall >=1.41 && <1.43 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , frontmatter >=0.1 && <0.2 + , generic-lens >=2.2 && <2.4 + , lens ^>=5.3 + , text ^>=2.1 + , time >=1.12 && <1.15 + , vector >=0.13 && <0.14 + , yaml >=0.11 && <0.12 test-suite okf-core-test - import: common-options - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-options + type: exitcode-stdio-1.0 + main-is: Main.hs hs-source-dirs: test - build-depends: - aeson, - base >=4.20 && <5, - directory, - filepath, - okf-core, - temporary, - text ^>=2.1, + , aeson + , base >=4.20 && <5 + , dhall >=1.41 && <1.43 + , directory + , filepath + , generic-lens >=2.2 && <2.4 + , lens ^>=5.3 + , okf-core + , temporary + , text ^>=2.1 + , time >=1.12 && <1.15 diff --git a/src/Okf/Bundle.hs b/src/Okf/Bundle.hs --- a/src/Okf/Bundle.hs +++ b/src/Okf/Bundle.hs @@ -2,6 +2,7 @@ module Okf.Bundle ( BundleError (..), Concept, + LogFile (..), conceptFromDocument, conceptDescription, conceptDocument, @@ -15,6 +16,7 @@ isReservedMarkdownFile, serializeConcept, walkBundle, + walkLogs, writeBundle, ) where @@ -25,6 +27,7 @@ import Data.Text.IO qualified as Text.IO import Okf.ConceptId import Okf.Document +import Okf.Log import Okf.Prelude import System.Directory ( createDirectoryIfMissing, @@ -55,6 +58,13 @@ | 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 @@ -65,6 +75,16 @@ 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 = @@ -132,6 +152,34 @@ ) 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/\.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 @@ -161,6 +209,15 @@ 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) diff --git a/src/Okf/ConceptId.hs b/src/Okf/ConceptId.hs --- a/src/Okf/ConceptId.hs +++ b/src/Okf/ConceptId.hs @@ -1,23 +1,23 @@ -- | Safe concept identifiers for bundle-relative OKF Markdown documents. module Okf.ConceptId - ( ConceptId - , ConceptIdError (..) - , conceptIdFromFilePath - , conceptIdToFilePath - , parseConceptId - , renderConceptId - , renderConceptLinkTarget - , renderConceptLink - ) where + ( ConceptId, + ConceptIdError (..), + conceptIdFromFilePath, + conceptIdToFilePath, + parseConceptId, + renderConceptId, + renderConceptLinkTarget, + renderConceptLink, + ) +where -import Data.Char qualified as Char import Data.Aeson (ToJSON (..)) +import Data.Char qualified as Char import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text +import Okf.Prelude hiding ((<.>)) import System.FilePath ((<.>)) import System.FilePath qualified as FilePath - -import Okf.Prelude hiding ((<.>)) -- | A bundle-relative concept path without the @.md@ suffix. newtype ConceptId = ConceptId diff --git a/src/Okf/Document.hs b/src/Okf/Document.hs --- a/src/Okf/Document.hs +++ b/src/Okf/Document.hs @@ -1,25 +1,27 @@ -- | Parsing and serialization for OKF Markdown concept documents. module Okf.Document - ( Frontmatter (..) - , OKFDocument (..) - , DocumentParseError (..) - , emptyFrontmatter - , frontmatterLookup - , parseDocument - , serializeDocument + ( Frontmatter (..), + OKFDocument (..), + DocumentParseError (..), + emptyFrontmatter, + frontmatterLookup, + parseDocument, + serializeDocument, + -- * Frontmatter authoring - , frontmatterFromFields - , setField - , removeField - , OkfCommon (..) - , okfCommon - , setType - , setTitle - , setDescription - , setTimestamp - , setResource - , setTags - ) where + frontmatterFromFields, + setField, + removeField, + OkfCommon (..), + okfCommon, + setType, + setTitle, + setDescription, + setTimestamp, + setResource, + setTags, + ) +where import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as KeyMap @@ -32,7 +34,6 @@ import Data.Vector qualified as Vector import Data.Yaml qualified as Yaml import Data.Yaml.Pretty qualified as YamlPretty - import Okf.Prelude hiding (setField) -- | YAML frontmatter fields. OKF allows producer-defined extension keys, so @@ -44,8 +45,8 @@ -- | A Markdown concept document split into frontmatter and body. data OKFDocument = OKFDocument - { frontmatter :: !Frontmatter - , body :: !Text + { frontmatter :: !Frontmatter, + body :: !Text } deriving stock (Generic, Eq, Show) @@ -84,21 +85,23 @@ -- omitted because they are optional and have distinct shapes; set them with -- 'setResource' and 'setTags'. data OkfCommon = OkfCommon - { commonType :: !Text - , commonTitle :: !(Maybe Text) - , commonDescription :: !(Maybe Text) - , commonTimestamp :: !(Maybe Text) + { commonType :: !Text, + commonTitle :: !(Maybe Text), + commonDescription :: !(Maybe Text), + commonTimestamp :: !(Maybe Text) } deriving stock (Generic, Eq, Show) -- | Build frontmatter from the common OKF fields: @type@ always, plus -- whichever of @title@, @description@, @timestamp@ are present. okfCommon :: OkfCommon -> Frontmatter -okfCommon OkfCommon{commonType, commonTitle, commonDescription, commonTimestamp} = - foldr ($) (setType commonType emptyFrontmatter) - [ maybe id setTitle commonTitle - , maybe id setDescription commonDescription - , maybe id setTimestamp commonTimestamp +okfCommon OkfCommon {commonType, commonTitle, commonDescription, commonTimestamp} = + foldr + ($) + (setType commonType emptyFrontmatter) + [ maybe id setTitle commonTitle, + maybe id setDescription commonDescription, + maybe id setTimestamp commonTimestamp ] -- | Set the @type@ field. @@ -140,18 +143,19 @@ -- @type, title, description, timestamp, resource, tags@ — then every other key -- in ascending alphabetical order) so regenerating a bundle yields minimal diffs. serializeDocument :: OKFDocument -> Text -serializeDocument OKFDocument{frontmatter, body} = +serializeDocument OKFDocument {frontmatter, body} = Text.unlines ["---", renderedYaml, "---", ""] <> ensureTrailingNewline body - where - renderedYaml = renderOrderedYaml frontmatter + where + renderedYaml = renderOrderedYaml frontmatter -- | Render frontmatter to YAML with the deterministic OKF key order. renderOrderedYaml :: Frontmatter -> Text renderOrderedYaml (Frontmatter rawFields) = - Text.dropWhileEnd (== '\n') + Text.dropWhileEnd + (== '\n') (Text.Encoding.decodeUtf8 (YamlPretty.encodePretty config (Object rawFields))) - where - config = YamlPretty.setConfCompare (comparing okfKeyRank) YamlPretty.defConfig + where + config = YamlPretty.setConfCompare (comparing okfKeyRank) YamlPretty.defConfig -- | Sort key for deterministic frontmatter ordering: the six common OKF fields -- come first in their fixed order; every other key sorts after them @@ -161,9 +165,9 @@ case lookup keyText commonRanks of Just rank -> (rank, "") Nothing -> (length commonRanks, keyText) - where - commonRanks = - zip ["type", "title", "description", "timestamp", "resource", "tags"] [0 ..] + where + commonRanks = + zip ["type", "title", "description", "timestamp", "resource", "tags"] [0 ..] parseFrontmatterDocument :: ByteString.ByteString -> Either DocumentParseError OKFDocument parseFrontmatterDocument inputBytes = diff --git a/src/Okf/Log.hs b/src/Okf/Log.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Log.hs @@ -0,0 +1,228 @@ +-- | Parsing and rendering for OKF @log.md@ reserved files. +module Okf.Log + ( Log (..), + LogDay (..), + LogEntry (..), + LogParseError (..), + LogValidationError (..), + appendLogEntry, + logErrorIsStructural, + parseLog, + serializeLog, + validateLog, + ) +where + +import CMarkGFM qualified +import Data.Char qualified as Char +import Data.Text qualified as Text +import Data.Time (Day, defaultTimeLocale, parseTimeM) +import Okf.Prelude + +-- | One parsed @log.md@ file. +data Log = Log + { logTitle :: !Text, + logDays :: ![LogDay] + } + deriving stock (Generic, Eq, Show) + +-- | One @## YYYY-MM-DD@ date group and its entries. +data LogDay = LogDay + { logDate :: !Text, + logEntries :: ![LogEntry] + } + deriving stock (Generic, Eq, Show) + +-- | One bullet entry under a date group. +data LogEntry = LogEntry + { logKind :: !(Maybe Text), + logText :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | Reserved for future parser failures. CommonMark parsing is total today. +data LogParseError + = LogNotMarkdown Text + deriving stock (Generic, Eq, Show) + +-- | A structural or advisory problem in one parsed log. +data LogValidationError + = LogDateNotIso Text + | LogDaysOutOfOrder Text Text + | LogEmptyDay Text + deriving stock (Generic, Eq, Show) + +-- | Parse Markdown into the log model. Structural validation is separate. +parseLog :: Text -> Log +parseLog markdown = + finish (foldl' step emptyBuild topLevelNodes) + where + topLevelNodes = + case CMarkGFM.commonmarkToNode [] [] markdown of + CMarkGFM.Node _ _ documentChildren -> documentChildren + +-- | Render a log deterministically with a trailing newline. +serializeLog :: Log -> Text +serializeLog Log {logTitle, logDays} = + ensureTrailingNewline + ( Text.intercalate + "\n\n" + ("# " <> logTitle : fmap renderDay logDays) + ) + where + renderDay LogDay {logDate, logEntries} = + Text.intercalate "\n" ("## " <> logDate : fmap renderEntry logEntries) + + renderEntry LogEntry {logKind = Just kind, logText} = + "* **" <> kind <> "**: " <> logText + renderEntry LogEntry {logKind = Nothing, logText} = + "* " <> logText + +-- | Validate the OKF @log.md@ structure and ordering. +validateLog :: Log -> [LogValidationError] +validateLog Log {logDays} = + foldMap validateDay logDays <> validateOrdering logDays + where + validateDay LogDay {logDate, logEntries} = + [LogDateNotIso logDate | not (isIsoDate logDate)] + <> [LogEmptyDay logDate | null logEntries] + + validateOrdering days = + [ LogDaysOutOfOrder earlier later + | (LogDay earlier _, LogDay later _) <- zip days (drop 1 days), + isIsoDate earlier, + isIsoDate later, + earlier < later + ] + +-- | Whether a log validation error is a hard reserved-file structure error. +logErrorIsStructural :: LogValidationError -> Bool +logErrorIsStructural = \case + LogDateNotIso _ -> True + LogEmptyDay _ -> True + LogDaysOutOfOrder _ _ -> False + +data BuildLog = BuildLog + { buildTitle :: !(Maybe Text), + buildDaysRev :: ![LogDay], + buildCurrentDay :: !(Maybe LogDay) + } + +emptyBuild :: BuildLog +emptyBuild = + BuildLog + { buildTitle = Nothing, + buildDaysRev = [], + buildCurrentDay = Nothing + } + +step :: BuildLog -> CMarkGFM.Node -> BuildLog +step build node@(CMarkGFM.Node _ nodeType childNodes) = + case nodeType of + CMarkGFM.HEADING 1 -> + case buildTitle build of + Nothing -> build {buildTitle = Just (plainText node)} + Just _ -> build + CMarkGFM.HEADING 2 -> + (pushCurrent build) {buildCurrentDay = Just (LogDay (plainText node) [])} + CMarkGFM.LIST _ -> + case buildCurrentDay build of + Nothing -> build + Just day -> + build + { buildCurrentDay = + Just day {logEntries = logEntries day <> foldMap logEntriesFromItem childNodes} + } + _ -> build + +pushCurrent :: BuildLog -> BuildLog +pushCurrent build = + case buildCurrentDay build of + Nothing -> build + Just day -> build {buildDaysRev = day : buildDaysRev build, buildCurrentDay = Nothing} + +finish :: BuildLog -> Log +finish build = + Log + { logTitle = fromMaybe "" (buildTitle build), + logDays = reverse (maybe (buildDaysRev build) (: buildDaysRev build) (buildCurrentDay build)) + } + +logEntriesFromItem :: CMarkGFM.Node -> [LogEntry] +logEntriesFromItem (CMarkGFM.Node _ CMarkGFM.ITEM childNodes) = + case inlineNodes childNodes of + [] -> [LogEntry Nothing ""] + firstInline : restInline -> + case firstInline of + CMarkGFM.Node _ CMarkGFM.STRONG _ -> + [ LogEntry + { logKind = Just (plainText firstInline), + logText = dropKindSeparator (renderInlineNodes restInline) + } + | not (Text.null (plainText firstInline)) + ] + _ -> + [LogEntry {logKind = Nothing, logText = renderInlineNodes (firstInline : restInline)}] +logEntriesFromItem _ = [] + +inlineNodes :: [CMarkGFM.Node] -> [CMarkGFM.Node] +inlineNodes [] = [] +inlineNodes (CMarkGFM.Node _ CMarkGFM.PARAGRAPH paragraphChildren : rest) = + paragraphChildren <> inlineNodes rest +inlineNodes (node : rest) = + node : inlineNodes rest + +plainText :: CMarkGFM.Node -> Text +plainText (CMarkGFM.Node _ nodeType childNodes) = + case nodeType of + CMarkGFM.TEXT text -> text + CMarkGFM.CODE text -> text + CMarkGFM.SOFTBREAK -> "\n" + CMarkGFM.LINEBREAK -> "\n" + _ -> foldMap plainText childNodes + +renderInlineNodes :: [CMarkGFM.Node] -> Text +renderInlineNodes nodes = + Text.strip (CMarkGFM.nodeToCommonmark [] Nothing (CMarkGFM.Node Nothing CMarkGFM.PARAGRAPH nodes)) + +-- | Insert an entry under a date, keeping date groups newest first. +appendLogEntry :: Text -> LogEntry -> Log -> Log +appendLogEntry dateText entry logFile@Log {logDays} = + logFile {logDays = insertDay logDays} + where + newDay = LogDay dateText [entry] + + insertDay [] = [newDay] + insertDay (day : rest) + | logDate day == dateText = day {logEntries = entry : logEntries day} : rest + | dateText > logDate day = newDay : day : rest + | otherwise = day : insertDay rest + +dropKindSeparator :: Text -> Text +dropKindSeparator text = + Text.stripStart + ( fromMaybe + stripped + (Text.stripPrefix ":" stripped) + ) + where + stripped = Text.stripStart text + +ensureTrailingNewline :: Text -> Text +ensureTrailingNewline text + | Text.null text = "\n" + | "\n" `Text.isSuffixOf` text = text + | otherwise = text <> "\n" + +isIsoDate :: Text -> Bool +isIsoDate value = + Text.length value == 10 + && Text.index value 4 == '-' + && Text.index value 7 == '-' + && Text.all Char.isDigit (Text.take 4 value) + && Text.all Char.isDigit (Text.take 2 (Text.drop 5 value)) + && Text.all Char.isDigit (Text.drop 8 value) + && isJust parsed + where + parsed :: Maybe Day + parsed = parseTimeM True defaultTimeLocale "%Y-%m-%d" (Text.unpack value) diff --git a/src/Okf/Prelude.hs b/src/Okf/Prelude.hs --- a/src/Okf/Prelude.hs +++ b/src/Okf/Prelude.hs @@ -4,13 +4,14 @@ -- vocabulary while keeping generic-lens label instances local to modules -- that explicitly opt into them. module Okf.Prelude - ( module X - , module Control.Lens + ( module X, + module Control.Lens, -- * Generic-lens vocabulary - , module Data.Generics.Product - , module Data.Generics.Sum - ) where + module Data.Generics.Product, + module Data.Generics.Sum, + ) +where import "aeson" Data.Aeson as X (FromJSON, ToJSON, Value (..)) import "base" Control.Applicative as X ((<|>)) @@ -20,7 +21,7 @@ import "base" Data.Maybe as X (fromMaybe, isJust, isNothing) import "base" Data.Traversable as X (for) import "base" GHC.Generics as X (Generic) -import "lens" Control.Lens import "generic-lens" Data.Generics.Product import "generic-lens" Data.Generics.Sum +import "lens" Control.Lens import "text" Data.Text as X (Text) diff --git a/src/Okf/Profile.hs b/src/Okf/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Profile.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE PackageImports #-} + +-- | House-convention profiles: a declarative, Dhall-authored description of how a +-- team uses OKF, checkable against a bundle. Profiles are NOT part of the OKF +-- standard; a bundle that deviates from a profile remains fully OKF-conformant. +-- +-- A profile is loaded from a Dhall descriptor ('loadProfileFile') into a +-- 'ProfileSpec' and checked against a list of 'Concept's with 'validateProfile', +-- which returns a (possibly empty) list of 'ProfileViolation's. By design the +-- caller decides whether those violations are advisory or fatal; this module only +-- reports them. +module Okf.Profile + ( -- * Descriptor + ProfileSpec (..), + FrontmatterRules (..), + TypeRule (..), + loadProfileFile, + + -- * Validation + ProfileViolation (..), + validateProfile, + + -- * Body inspection + schemaSectionColumns, + ) +where + +import CMarkGFM qualified +import Control.Exception (SomeException, catch) +import Data.List qualified as List +import Data.Text qualified as Text +import Dhall (FromDhall (..), auto, genericAutoWith) +import Dhall qualified +import Okf.Bundle + ( Concept, + conceptDocument, + conceptIdOf, + conceptResource, + conceptType, + ) +import Okf.ConceptId (ConceptId, renderConceptId) +import Okf.Document (Frontmatter, frontmatterLookup) +import Okf.Prelude +import "generic-lens" Data.Generics.Labels () + +-- | A complete house profile. +data ProfileSpec = ProfileSpec + { name :: !Text, + okfVersion :: !Text, + frontmatter :: !FrontmatterRules, + allowUnknownTypes :: !Bool, + types :: ![TypeRule] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Frontmatter keys the profile expects on every concept. +data FrontmatterRules = FrontmatterRules + { required :: ![Text], + recommended :: ![Text] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | One rule per allowed concept @type@ string. +data TypeRule = TypeRule + { type_ :: !Text, + pathPattern :: !(Maybe Text), + resourceScheme :: !(Maybe Text), + requireSchemaSection :: !Bool, + schemaColumns :: ![Text] + } + deriving stock (Generic, Eq, Show) + +-- | Decode @type_@ from the Dhall field @type@ by stripping the trailing +-- underscore; all other fields map by their exact name. (Mirrors how +-- 'Okf.Bundle' uses a @type_@ field to avoid clashing with the @type@ keyword.) +instance FromDhall TypeRule where + autoWith _normalizer = + genericAutoWith + (Dhall.defaultInterpretOptions {Dhall.fieldModifier = stripTrailingUnderscore}) + where + stripTrailingUnderscore fieldName = + fromMaybe fieldName (Text.stripSuffix "_" fieldName) + +-- | Load and decode a Dhall profile descriptor from a file path. Any evaluation +-- or decoding failure is captured as a human-readable 'Left'. +loadProfileFile :: FilePath -> IO (Either Text ProfileSpec) +loadProfileFile path = + (Right <$> Dhall.inputFile auto path) + `catch` \(e :: SomeException) -> pure (Left (Text.pack (show e))) + +-- | A single deviation from a profile. Advisory by default at the CLI layer. +data ProfileViolation + = -- | concept's @type@ is not listed in the profile and unknown types are disallowed + TypeNotInProfile ConceptId Text + | -- | a required frontmatter key is missing or empty (concept, key) + MissingProfileField ConceptId Text + | -- | concept's file path does not match the type rule's pattern (concept, type, pattern) + PathPatternMismatch ConceptId Text Text + | -- | type rule requires a resource scheme but resource is absent (concept, type, scheme) + MissingResource ConceptId Text Text + | -- | resource present but its scheme is wrong (concept, expected scheme, actual resource) + ResourceSchemeMismatch ConceptId Text Text + | -- | required @# Schema@ section is absent (concept, type) + MissingSchemaSection ConceptId Text + | -- | @# Schema@ table columns do not match (concept, type, expected, actual) + SchemaColumnsMismatch ConceptId Text [Text] [Text] + deriving stock (Generic, Eq, Show) + +-- | Check every concept against the profile, returning all deviations. Concepts +-- whose @type@ is not in the profile vocabulary skip the per-rule checks (there +-- is no rule to check against) and only produce a 'TypeNotInProfile' violation +-- when @allowUnknownTypes@ is @False@. +validateProfile :: ProfileSpec -> [Concept] -> [ProfileViolation] +validateProfile spec = concatMap checkConcept + where + rulesByType = [(rule ^. #type_, rule) | rule <- spec ^. #types] + + checkConcept concept = + let cid = conceptIdOf concept + ctype = conceptType concept + in case lookup ctype rulesByType of + Nothing -> + [TypeNotInProfile cid ctype | not (spec ^. #allowUnknownTypes)] + Just rule -> + checkRequiredFields cid concept + <> checkPath cid ctype rule + <> checkResource cid ctype rule concept + <> checkSchema cid ctype rule concept + + checkRequiredFields cid concept = + [ MissingProfileField cid key + | key <- spec ^. #frontmatter . #required, + not (hasNonEmptyField key (conceptFrontmatter concept)) + ] + +-- | Project a concept's frontmatter (the document's @frontmatter@ field). +conceptFrontmatter :: Concept -> Frontmatter +conceptFrontmatter concept = conceptDocument concept ^. #frontmatter + +-- | A field counts as present only if it is a non-empty string or a non-empty +-- list (mirroring how the core validator treats @type@). Anything else, +-- including a missing key, does not count. +hasNonEmptyField :: Text -> Frontmatter -> Bool +hasNonEmptyField key fm = + case frontmatterLookup key fm of + Just (String value) -> not (Text.null (Text.strip value)) + Just (Array values) -> not (null values) + _ -> False + +-- | A type rule's @pathPattern@, when present, constrains where the concept's +-- file may live. +checkPath :: ConceptId -> Text -> TypeRule -> [ProfileViolation] +checkPath cid ctype rule = + case rule ^. #pathPattern of + Nothing -> [] + Just patternText + | matchPathPattern patternText cid -> [] + | otherwise -> [PathPatternMismatch cid ctype patternText] + +-- | Match a concept ID against a segment-glob pattern. @*@ matches exactly one +-- segment; a single trailing @**@ matches one or more remaining segments; every +-- other segment matches literally. Both segment lists must be consumed exactly, +-- except for the trailing @**@ case. +matchPathPattern :: Text -> ConceptId -> Bool +matchPathPattern patternText cid = + go (Text.splitOn "/" patternText) (Text.splitOn "/" (renderConceptId cid)) + where + go [] [] = True + go ["**"] (_ : _) = True + go ("*" : ps) (_ : ss) = go ps ss + go (p : ps) (s : ss) = p == s && go ps ss + go _ _ = False + +-- | A type rule's @resourceScheme@, when present, requires a @resource:@ value +-- whose scheme matches. +checkResource :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] +checkResource cid ctype rule concept = + case rule ^. #resourceScheme of + Nothing -> [] + Just scheme -> + case conceptResource concept of + Nothing -> [MissingResource cid ctype scheme] + Just value + | (scheme <> "://") `Text.isPrefixOf` value -> [] + | otherwise -> [ResourceSchemeMismatch cid scheme value] + +-- | A type rule's @# Schema@ contract: when @requireSchemaSection@ is set, the +-- body must contain a @# Schema@ section whose table header begins with the +-- required @schemaColumns@ (case-insensitive, trimmed, compared as a prefix so a +-- team may add trailing columns without tripping the check). +checkSchema :: ConceptId -> Text -> TypeRule -> Concept -> [ProfileViolation] +checkSchema cid ctype rule concept + | not (rule ^. #requireSchemaSection) = [] + | otherwise = + case schemaSectionColumns (conceptDocument concept ^. #body) of + Nothing -> [MissingSchemaSection cid ctype] + Just actual -> + let expected = rule ^. #schemaColumns + norm = map (Text.toLower . Text.strip) + in [ SchemaColumnsMismatch cid ctype expected actual + | not (norm expected `List.isPrefixOf` norm actual) + ] + +-- | The header-row columns of the first GitHub-flavored table that follows the +-- first top-level @# Schema@ heading, or 'Nothing' if there is no Schema heading +-- or no following table. Columns are trimmed. +schemaSectionColumns :: Text -> Maybe [Text] +schemaSectionColumns markdown = + let CMarkGFM.Node _ _ topLevel = CMarkGFM.commonmarkToNode [] [CMarkGFM.extTable] markdown + in firstTableAfterSchema topLevel + +firstTableAfterSchema :: [CMarkGFM.Node] -> Maybe [Text] +firstTableAfterSchema topLevel = + case dropWhile (not . isSchemaHeading) topLevel of + (_heading : rest) -> headerRow rest + [] -> Nothing + where + isSchemaHeading (CMarkGFM.Node _ (CMarkGFM.HEADING _) inner) = + Text.toLower (Text.strip (nodeText inner)) == "schema" + isSchemaHeading _ = False + + headerRow [] = Nothing + headerRow (CMarkGFM.Node _ (CMarkGFM.TABLE _) tableChildren : _) = + case tableChildren of + (CMarkGFM.Node _ CMarkGFM.TABLE_ROW cells : _) -> Just (map cellText cells) + _ -> Nothing + headerRow (_ : more) = headerRow more + + cellText (CMarkGFM.Node _ _ inner) = Text.strip (nodeText inner) + +-- | Concatenate all @TEXT@/@CODE@ literals under a node list, recursively. +nodeText :: [CMarkGFM.Node] -> Text +nodeText = foldMap go + where + go (CMarkGFM.Node _ (CMarkGFM.TEXT t) _) = t + go (CMarkGFM.Node _ (CMarkGFM.CODE t) _) = t + go (CMarkGFM.Node _ _ inner) = nodeText inner diff --git a/src/Okf/Validation.hs b/src/Okf/Validation.hs --- a/src/Okf/Validation.hs +++ b/src/Okf/Validation.hs @@ -5,16 +5,24 @@ validateDocument, BundleValidationError (..), validateBundle, + validateBundleLogs, + validateLogs, + LogStaleness (..), + logStaleness, + nearestEnclosingLogPath, ) where +import Data.List qualified as List import Data.Text qualified as Text import Data.Vector qualified as Vector -import Okf.Bundle (Concept, conceptDocument, conceptIdOf) +import Okf.Bundle (Concept, LogFile, conceptDocument, conceptIdOf, conceptSourcePath, logContent, logSourcePath) import Okf.ConceptId (ConceptId) import Okf.Document import Okf.Graph (danglingReferences, duplicateConceptIds) +import Okf.Log (Log (logDays), LogDay (logDate), LogValidationError, validateLog) import Okf.Prelude +import System.FilePath qualified as FilePath -- | Validation modes supported by the initial OKF core library. data ValidationProfile @@ -38,8 +46,19 @@ DanglingReference ConceptId ConceptId | -- | The same concept ID was assembled more than once. DuplicateConceptId ConceptId + | -- | A reserved log file does not match the required log structure. + LogInvalid FilePath LogValidationError deriving stock (Generic, Eq, Show) +-- | A concept whose timestamp appears newer than its nearest covering log. +data LogStaleness = LogStaleness + { staleConcept :: !ConceptId, + staleConceptDate :: !Text, + staleLogPath :: !(Maybe FilePath), + staleLogDate :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + -- | Validate a whole bundle: per-document checks under the given profile, plus -- referential integrity (no links to missing concepts) and uniqueness of -- concept IDs. An empty list means the bundle is valid under the profile. @@ -55,6 +74,28 @@ dangling = uncurry DanglingReference <$> danglingReferences concepts duplicates = DuplicateConceptId <$> duplicateConceptIds concepts +-- | Validate all parsed @log.md@ files discovered in a bundle. +validateBundleLogs :: [LogFile] -> [BundleValidationError] +validateBundleLogs = validateLogs + +-- | Validate all parsed @log.md@ files discovered in a bundle. +validateLogs :: [LogFile] -> [BundleValidationError] +validateLogs logFiles = + [ LogInvalid (logSourcePath logFile) err + | logFile <- logFiles, + err <- validateLog (logContent logFile) + ] + +-- | Find concepts whose timestamp date is newer than their nearest enclosing log. +logStaleness :: [Concept] -> [LogFile] -> [LogStaleness] +logStaleness concepts logs = + [ staleness + | concept <- concepts, + Just conceptDate <- [conceptTimestampDate concept], + let nearest = nearestEnclosingLog (conceptSourcePath concept) logs, + Just staleness <- [staleIfNeeded concept conceptDate nearest] + ] + -- | Validate a parsed document under the requested profile. validateDocument :: ValidationProfile -> OKFDocument -> [ValidationError] validateDocument profile document = @@ -85,3 +126,68 @@ where isString (String _) = True isString _ = False + +conceptTimestampDate :: Concept -> Maybe Text +conceptTimestampDate concept = + case frontmatterLookup "timestamp" (frontmatter (conceptDocument concept)) of + Just (String timestamp) + | Text.length timestamp >= 10 -> Just (Text.take 10 timestamp) + _ -> Nothing + +staleIfNeeded :: Concept -> Text -> Maybe LogFile -> Maybe LogStaleness +staleIfNeeded concept conceptDate nearest = + case nearest of + Nothing -> + Just + LogStaleness + { staleConcept = conceptIdOf concept, + staleConceptDate = conceptDate, + staleLogPath = Nothing, + staleLogDate = Nothing + } + Just logFile -> + let newest = newestLogDate (logContent logFile) + in if maybe True (conceptDate >) newest + then + Just + LogStaleness + { staleConcept = conceptIdOf concept, + staleConceptDate = conceptDate, + staleLogPath = Just (logSourcePath logFile), + staleLogDate = newest + } + else Nothing + +newestLogDate :: Log -> Maybe Text +newestLogDate logFile = + case logDate <$> logDays logFile of + [] -> Nothing + dates -> Just (maximum dates) + +nearestEnclosingLog :: FilePath -> [LogFile] -> Maybe LogFile +nearestEnclosingLog conceptPath logs = + case nearestEnclosingLogPath conceptPath (logSourcePath <$> logs) of + Nothing -> Nothing + Just path -> List.find ((== path) . logSourcePath) logs + +-- | Pick the closest @log.md@ path whose directory contains the concept path. +nearestEnclosingLogPath :: FilePath -> [FilePath] -> Maybe FilePath +nearestEnclosingLogPath conceptPath logPaths = + case candidates of + [] -> Nothing + _ -> Just (snd (List.maximumBy compareDepth candidates)) + where + conceptDirectory = pathSegments (FilePath.takeDirectory conceptPath) + candidates = + [ (scope, logPath) + | logPath <- logPaths, + let scope = pathSegments (FilePath.takeDirectory logPath), + scope `List.isPrefixOf` conceptDirectory + ] + compareDepth left right = compare (length (fst left)) (length (fst right)) + +pathSegments :: FilePath -> [FilePath] +pathSegments path = + case FilePath.splitDirectories (FilePath.normalise path) of + ["."] -> [] + segments -> filter (`notElem` [".", ""]) segments diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module Main (main) where import Data.Aeson (object, toJSON, (.=)) @@ -9,17 +11,21 @@ import Okf.Document import Okf.Graph import Okf.Index +import Okf.Log import Okf.Prelude hiding (setField, (.=)) +import Okf.Profile import Okf.Validation import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, + doesFileExist, getTemporaryDirectory, removeDirectoryRecursive, ) import System.Exit (exitFailure) import System.FilePath (()) import System.IO.Temp (createTempDirectory) +import "generic-lens" Data.Generics.Labels () main :: IO () main = do @@ -38,6 +44,14 @@ testIO "walkBundle reports a structured IO error for a missing root" testWalkBundleMissingRoot, testIO "walkBundle skips index.md and log.md" testWalkBundleSkipsReserved, testIO "walkBundle discovers nested concept IDs" testWalkBundleDiscoversNestedConceptIds, + test "parseLog/serializeLog round-trips a canonical log" testLogRoundTrip, + test "validateLog flags a non-ISO date heading" testValidateLogNonIsoDate, + test "validateLog flags an empty date group" testValidateLogEmptyDay, + test "validateLog flags out-of-order days" testValidateLogOutOfOrder, + testIO "walkLogs discovers nested log.md files" testWalkLogsDiscoversNested, + test "logStaleness flags a concept newer than its nearest log" testLogStalenessFlagsNewerConcept, + test "logStaleness prefers the deepest enclosing log" testLogStalenessPrefersDeepestLog, + test "appendLogEntry inserts newest-first and prepends within a day" testAppendLogEntry, testIO "generateIndex groups documents by frontmatter type" testGenerateIndexGroupsByType, testIO "extractLinks resolves relative and absolute bundle links" testExtractLinksResolveBundleLinks, testIO "extractLinks ignores external markdown URLs" testExtractLinksIgnoresExternalUrls, @@ -56,7 +70,17 @@ test "duplicateConceptIds finds repeated ids" testDuplicateConceptIds, test "conceptFromDocument derives typed fields from frontmatter" testConceptFromDocumentDerivesFields, testIO "writeBundle then walkBundle round-trips" testWriteBundleRoundTrip, - testIO "fixture dangling link reports a bundle validation error" testFixtureDanglingLink + testIO "fixture dangling link reports a bundle validation error" testFixtureDanglingLink, + testIO "loadProfileFile decodes the postgresql fixture" testLoadProfileFixture, + test "validateProfile accepts a conforming table concept" testProfileConformingTable, + test "validateProfile flags a type not in the vocabulary" testProfileUnknownType, + test "validateProfile flags a missing required field" testProfileMissingField, + test "validateProfile flags a resource scheme mismatch" testProfileResourceMismatch, + test "validateProfile flags a path pattern mismatch" testProfilePathMismatch, + test "validateProfile flags a missing # Schema section" testProfileMissingSchema, + test "validateProfile flags mismatched # Schema columns" testProfileSchemaColumnsMismatch, + test "schemaSectionColumns reads the header row of the Schema table" testSchemaSectionColumns, + testIO "validateProfile reports the expected deviations for the fixture bundle" testProfileDeviationsFixture ] unless (and results) exitFailure @@ -78,13 +102,13 @@ testParseValidDocument :: Either Text () testParseValidDocument = do document <- firstShow (parseDocument sampleDocument) - assertEqual (Just (String "BigQuery Table")) (frontmatterLookup "type" (frontmatter document)) + assertEqual (Just (String "BigQuery Table")) (frontmatterLookup "type" (document ^. #frontmatter)) assertEqual "# Schema\n\nBody text.\n" (body document) testParseNoFrontmatter :: Either Text () testParseNoFrontmatter = do document <- firstShow (parseDocument "# Draft\n") - assertEqual Nothing (frontmatterLookup "type" (frontmatter document)) + assertEqual Nothing (frontmatterLookup "type" (document ^. #frontmatter)) assertEqual "# Draft\n" (body document) testRejectUnterminatedFrontmatter :: Either Text () @@ -119,7 +143,7 @@ assertEqual [] (validateDocument PermissiveConformance document) assertEqual [] (validateDocument StrictAuthoring document) reparsed <- firstShow (parseDocument (serializeDocument document)) - assertEqual (frontmatter document) (frontmatter reparsed) + assertEqual (document ^. #frontmatter) (reparsed ^. #frontmatter) assertEqual (body document) (body reparsed) testRejectInvalidConceptId :: Either Text () @@ -165,6 +189,132 @@ ) ) +testLogRoundTrip :: Either Text () +testLogRoundTrip = do + let canonicalLog = + Text.unlines + [ "# Directory Update Log", + "", + "## 2026-06-23", + "* **Update**: Refreshed [orders](tables/orders.md).", + "* **Creation**: Added customers.", + "", + "## 2026-06-01", + "* Deprecated a stale note." + ] + parsed = parseLog canonicalLog + reparsed = parseLog (serializeLog parsed) + assertEqual + ( Log + { logTitle = "Directory Update Log", + logDays = + [ LogDay + { logDate = "2026-06-23", + logEntries = + [ LogEntry (Just "Update") "Refreshed [orders](tables/orders.md).", + LogEntry (Just "Creation") "Added customers." + ] + }, + LogDay + { logDate = "2026-06-01", + logEntries = [LogEntry Nothing "Deprecated a stale note."] + } + ] + } + ) + parsed + assertEqual parsed reparsed + +testValidateLogNonIsoDate :: Either Text () +testValidateLogNonIsoDate = + assertBool + "expected LogDateNotIso" + (LogDateNotIso "not-a-date" `List.elem` validateLog (parseLog "# Log\n\n## not-a-date\n* **Update**: oops\n")) + +testValidateLogEmptyDay :: Either Text () +testValidateLogEmptyDay = + assertBool + "expected LogEmptyDay" + (LogEmptyDay "2026-06-23" `List.elem` validateLog (parseLog "# Log\n\n## 2026-06-23\n")) + +testValidateLogOutOfOrder :: Either Text () +testValidateLogOutOfOrder = + assertBool + "expected LogDaysOutOfOrder" + ( LogDaysOutOfOrder "2026-01-01" "2026-06-23" + `List.elem` validateLog (parseLog "# Log\n\n## 2026-01-01\n* Old.\n\n## 2026-06-23\n* New.\n") + ) + +testWalkLogsDiscoversNested :: IO (Either Text ()) +testWalkLogsDiscoversNested = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-core-logs" + createDirectoryIfMissing True (root "tables") + Text.IO.writeFile (root "log.md") "# Root Log\n\n## 2026-06-23\n* Root entry.\n" + Text.IO.writeFile (root "tables" "log.md") "# Tables Log\n\n## 2026-06-22\n* Tables entry.\n" + result <- walkLogs root + removeDirectoryRecursive root + pure + ( case result of + Right logs -> assertEqual ["log.md", "tables/log.md"] (logSourcePath <$> logs) + Left bundleError -> Left ("expected logs, got " <> Text.pack (show bundleError)) + ) + +testLogStalenessFlagsNewerConcept :: Either Text () +testLogStalenessFlagsNewerConcept = do + staleId <- parseTestConceptId "stale" + staleConcept <- testConceptWithTimestamp "stale" "2026-06-23T00:00:00Z" + currentConcept <- testConceptWithTimestamp "current" "2026-01-01T00:00:00Z" + let logs = [LogFile "log.md" (parseLog "# Log\n\n## 2026-06-01\n* **Update**: logged.\n")] + assertEqual + [ LogStaleness + { staleConcept = staleId, + staleConceptDate = "2026-06-23", + staleLogPath = Just "log.md", + staleLogDate = Just "2026-06-01" + } + ] + (logStaleness [staleConcept, currentConcept] logs) + +testLogStalenessPrefersDeepestLog :: Either Text () +testLogStalenessPrefersDeepestLog = do + usersId <- parseTestConceptId "tables/users" + usersConcept <- testConceptWithTimestamp "tables/users" "2026-06-21T00:00:00Z" + let logs = + [ LogFile "log.md" (parseLog "# Root Log\n\n## 2026-06-01\n* **Update**: root.\n"), + LogFile "tables/log.md" (parseLog "# Tables Log\n\n## 2026-06-20\n* **Update**: tables.\n") + ] + assertEqual + [ LogStaleness + { staleConcept = usersId, + staleConceptDate = "2026-06-21", + staleLogPath = Just "tables/log.md", + staleLogDate = Just "2026-06-20" + } + ] + (logStaleness [usersConcept] logs) + +testAppendLogEntry :: Either Text () +testAppendLogEntry = + assertEqual + ( Log + { logTitle = "Log", + logDays = + [ LogDay "2026-06-23" [LogEntry (Just "Update") "new"], + LogDay "2026-06-01" [LogEntry (Just "Update") "prepended", LogEntry (Just "Creation") "old"] + ] + } + ) + ( appendLogEntry + "2026-06-01" + (LogEntry (Just "Update") "prepended") + ( appendLogEntry + "2026-06-23" + (LogEntry (Just "Update") "new") + (Log "Log" [LogDay "2026-06-01" [LogEntry (Just "Creation") "old"]]) + ) + ) + testGenerateIndexGroupsByType :: IO (Either Text ()) testGenerateIndexGroupsByType = withFixtureBundle @@ -318,7 +468,7 @@ } original = OKFDocument frontmatterValue "# Orders\n\nBody text.\n" reparsed <- firstShow (parseDocument (serializeDocument original)) - assertEqual (frontmatter original) (frontmatter reparsed) + assertEqual (original ^. #frontmatter) (reparsed ^. #frontmatter) assertEqual (body original) (body reparsed) testSerializeDeterministicKeyOrder :: Either Text () @@ -414,6 +564,19 @@ } pure (conceptFromDocument conceptId (OKFDocument frontmatterValue bodyText)) +testConceptWithTimestamp :: Text -> Text -> Either Text Concept +testConceptWithTimestamp rawId timestamp = do + conceptId <- parseTestConceptId rawId + let frontmatterValue = + okfCommon + OkfCommon + { commonType = "Test", + commonTitle = Just "Title", + commonDescription = Just "Description", + commonTimestamp = Just timestamp + } + pure (conceptFromDocument conceptId (OKFDocument frontmatterValue "# Test\n")) + testConceptFromDocumentDerivesFields :: Either Text () testConceptFromDocumentDerivesFields = do conceptId <- parseTestConceptId "tables/orders" @@ -469,6 +632,178 @@ where isDangling DanglingReference {} = True isDangling _ = False + +-- | Resolve a fixture file path regardless of whether tests run from the repo +-- root or the package directory (mirrors 'fixturePath' for files). +fixtureFilePath :: FilePath -> IO FilePath +fixtureFilePath name = findExisting candidates + where + candidates = + [ "okf-core" "test" "fixtures" name, + "test" "fixtures" name + ] + findExisting [] = fail ("fixture file not found: " <> name) + findExisting (candidate : rest) = do + exists <- doesFileExist candidate + if exists then pure candidate else findExisting rest + +-- | Milestone 1: the Dhall descriptor round-trips into a 'ProfileSpec'. +testLoadProfileFixture :: IO (Either Text ()) +testLoadProfileFixture = do + path <- fixtureFilePath "profiles/postgresql.dhall" + result <- loadProfileFile path + pure $ case result of + Left err -> Left ("failed to load profile: " <> err) + Right spec -> do + assertEqual "shinzui-postgresql" (spec ^. #name) + assertEqual False (spec ^. #allowUnknownTypes) + assertEqual ["type", "title"] (spec ^. #frontmatter . #required) + assertEqual + ["PostgreSQL Schema", "PostgreSQL Table", "PostgreSQL View"] + (map (^. #type_) (spec ^. #types)) + +-- | A standalone profile literal so the validation tests do not depend on the +-- Dhall fixture. One rule: PostgreSQL Table, fully constrained. +testProfileSpec :: ProfileSpec +testProfileSpec = + ProfileSpec + { name = "test-postgresql", + okfVersion = "0.1", + frontmatter = FrontmatterRules {required = ["type", "title"], recommended = []}, + allowUnknownTypes = False, + types = + [ TypeRule + { type_ = "PostgreSQL Table", + pathPattern = Just "schemas/*/tables/*", + resourceScheme = Just "postgresql", + requireSchemaSection = True, + schemaColumns = ["Column", "Type", "Nullable", "Description"] + } + ] + } + +-- | Build an in-memory concept from a raw ID, frontmatter pairs, and a body. +profileConcept :: Text -> [(Text, Value)] -> Text -> Either Text Concept +profileConcept rawId fieldPairs bodyText = do + conceptId <- parseTestConceptId rawId + pure (conceptFromDocument conceptId (OKFDocument (frontmatterFromFields fieldPairs) bodyText)) + +-- | A well-formed @# Schema@ section matching the profile's required columns. +schemaSectionBody :: Text +schemaSectionBody = + Text.unlines + [ "# Schema", + "", + "| Column | Type | Nullable | Description |", + "|--------|--------|----------|-------------|", + "| id | bigint | no | Primary key |" + ] + +testProfileConformingTable :: Either Text () +testProfileConformingTable = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [ ("type", String "PostgreSQL Table"), + ("title", String "Orders"), + ("resource", String "postgresql://warehouse/sales/orders") + ] + schemaSectionBody + assertEqual [] (validateProfile testProfileSpec [concept]) + +testProfileUnknownType :: Either Text () +testProfileUnknownType = do + concept <- + profileConcept + "schemas/sales/tables/bad" + [("type", String "pg table"), ("title", String "Bad"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/bad" + assertEqual [TypeNotInProfile cid "pg table"] (validateProfile testProfileSpec [concept]) + +testProfileMissingField :: Either Text () +testProfileMissingField = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual [MissingProfileField cid "title"] (validateProfile testProfileSpec [concept]) + +testProfileResourceMismatch :: Either Text () +testProfileResourceMismatch = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "mysql://x")] + schemaSectionBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [ResourceSchemeMismatch cid "postgresql" "mysql://x"] + (validateProfile testProfileSpec [concept]) + +testProfilePathMismatch :: Either Text () +testProfilePathMismatch = do + concept <- + profileConcept + "tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + schemaSectionBody + cid <- parseTestConceptId "tables/orders" + assertEqual + [PathPatternMismatch cid "PostgreSQL Table" "schemas/*/tables/*"] + (validateProfile testProfileSpec [concept]) + +testProfileMissingSchema :: Either Text () +testProfileMissingSchema = do + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + "# Overview\n\nNo schema section here.\n" + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [MissingSchemaSection cid "PostgreSQL Table"] + (validateProfile testProfileSpec [concept]) + +testProfileSchemaColumnsMismatch :: Either Text () +testProfileSchemaColumnsMismatch = do + let mismatchBody = + Text.unlines + ["# Schema", "", "| Col | Type |", "|-----|------|", "| id | bigint |"] + concept <- + profileConcept + "schemas/sales/tables/orders" + [("type", String "PostgreSQL Table"), ("title", String "Orders"), ("resource", String "postgresql://x")] + mismatchBody + cid <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [SchemaColumnsMismatch cid "PostgreSQL Table" ["Column", "Type", "Nullable", "Description"] ["Col", "Type"]] + (validateProfile testProfileSpec [concept]) + +testSchemaSectionColumns :: Either Text () +testSchemaSectionColumns = + assertEqual + (Just ["Column", "Type", "Nullable", "Description"]) + (schemaSectionColumns schemaSectionBody) + +-- | Milestone 5: walking the deviating fixture and validating it against the +-- shipped descriptor produces exactly the expected advisory deviations. +testProfileDeviationsFixture :: IO (Either Text ()) +testProfileDeviationsFixture = do + descriptorPath <- fixtureFilePath "profiles/postgresql.dhall" + loaded <- loadProfileFile descriptorPath + root <- fixturePath "profile-deviations" + concepts <- readBundle root + pure $ case loaded of + Left err -> Left ("failed to load profile: " <> err) + Right spec -> do + badId <- parseTestConceptId "schemas/sales/tables/bad" + ordersId <- parseTestConceptId "schemas/sales/tables/orders" + assertEqual + [TypeNotInProfile badId "pg table", MissingProfileField ordersId "title"] + (validateProfile spec concepts) substringIndex :: Text -> Text -> Maybe Int substringIndex needle haystack =