Skip to content

Instantly share code, notes, and snippets.

@MaxGabriel

MaxGabriel/DocumentDatabaseModels.hs

Created September 6, 2024 20:15
Show Gist options
  • Save MaxGabriel/1c224b261175c53e0e322ae054d7df50 to your computer and use it in GitHub Desktop.
Save MaxGabriel/1c224b261175c53e0e322ae054d7df50 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
DocumentDatabaseModels.hs
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module DocumentDatabaseModels where
import A.MercuryPrelude
import App
import Data.HashMap.Strict qualified as HM
import Data.List qualified as List
import Data.List.NonEmpty qualified as NM
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Database.Persist.Documentation
import Database.Persist.EntityDef.Internal
import DocumentDatabaseModels.Html (renderEntitiesToHtml)
import DocumentDatabaseModels.Triggers
import DocumentDatabaseModels.Utils (mFieldNameLink)
import Language.Haskell.TH
import Mercury.Database.Enums
import Mercury.Persistent
import Mercury.Persistent.TH.DeriveDocumentationInfo
import PersistentModels.All (allEntityDefs)
import Safe (fromJustNote)
-- Only used internally
deriving newtype instance Hashable EntityNameHS
writeMdDocs :: IO ()
writeMdDocs = do
writeFile "docs/db/schema.markdown" $
TE.encodeUtf8 $
"\x2191 psst, GitHub will give you a table of contents in this menu denoted \x2630\n\n"
<> "# Table Documentation\n\n"
<> "_This file is auto-generated based on `.persistentmodels` files -- do not edit it manually._\n\n"
<> ( render customMarkdownTableRenderer $
addForeignReferencesToCommentsMarkdown
<$> List.sortOn getEntityHaskellName allEntityDefs
)
<> "# Enum Documentation\n\n"
<> renderAllEnumDocsToMarkdown
where
addForeignReferencesToCommentsMarkdown edef = edef {entityComments = Just mcomments}
where
mcomments =
maybe id (<>) (entityComments edef <> Just "\n") (T.unlines (entityInfo <> referenceInfo))
entityInfo =
[ "* Haskell name: " <> unEntityNameHS (getEntityHaskellName edef) <> "\n"
]
referenceInfo =
map renderReference (fieldReferences edef <> foreignReferences edef)
renderTableLink hsTableName =
"[" <> unEntityNameHS hsTableName <> "](#" <> unEntityNameDB sqlTableName <> ")"
where
sqlTableName =
fromJustNote "all of our foreign keys should resolve" $
lookup hsTableName entitySqlNameByHaskellName
renderReference :: (EntityNameHS, [Text]) -> Text
renderReference (target, fieldList) =
mconcat
[ "* References: "
, renderTableLink target
, " via ("
]
<> T.intercalate "," fieldList
<> ")"
writeHtmlDocs :: (RequireCallStack, HasApp m) => m ()
writeHtmlDocs = do
triggerInfoMap <- getTableNameTriggerInfoMap
writeFile "docs/db/schema.html" $
TE.encodeUtf8 $
T.unlines
[ "<!DOCTYPE html>"
, "<html>"
, "<head>"
, "<style>"
, " table, th, td {"
, " border: 1px solid rgba(0,0,0,.3);"
, " border-collapse: collapse;"
, " }"
, ""
, ".collapsible {"
, " background-color: lightgrey;"
, " cursor: pointer;"
, " padding: 18px;"
, " border: none;"
, " text-align: left;"
, " outline: none;"
, " font-size: 15px;"
, "}"
, ""
, ".active, .collapsible:hover {"
, " background-color: #D0D0D0;"
, "}"
, ".content {"
, " padding: 0 18px;"
, " overflow: auto;"
, " background-color: #f1f1f1;"
, "}"
, "</style>"
, "</head>"
, "<body>"
]
<> "<h1>Table Documentation</h1>"
<> "<p><em>This file is auto-generated based on <code>.persistentmodels</code> files -- do not edit it manually.</em></p>"
<> renderEntitiesToHtml
allPostgresEnumTypeDocs
( addForeignReferencesToCommentsHtml
<$> List.sortOn getEntityHaskellName allEntityDefs
)
triggerInfoMap
<> "<h1>Enum Documentation</h1>"
<> renderAllEnumDocsToHtml
<> "</body>"
<> "</html>"
<> "\n"
where
addForeignReferencesToCommentsHtml edef = edef {entityComments = Just mcomments}
where
mcomments =
maybe id (<>) (entityComments edef <> Just "\n") "<ul>" <> T.unlines (entityInfo <> referenceInfo) <> "</ul>"
entityInfo =
[ "<li><p>Haskell name: " <> unEntityNameHS (getEntityHaskellName edef) <> "</p></li>"
]
referenceInfo =
map renderReference (fieldReferences edef <> foreignReferences edef)
renderTableLink hsTableName =
"<a href=\"#" <> unEntityNameDB sqlTableName <> "\">" <> unEntityNameHS hsTableName <> "</a>"
where
sqlTableName =
fromJustNote "all of our foreign keys should resolve" $
lookup hsTableName entitySqlNameByHaskellName
renderReference :: (EntityNameHS, [Text]) -> Text
renderReference (target, fieldList) =
mconcat
[ "<li><p>References: "
, renderTableLink target
, " via ("
, T.intercalate "," fieldList
, ")</p></li>"
]
-- because field references are late-bound (that is, they are resolved
-- at the end), we don't know the SQL name of things until the end.
--
-- thus we need a lookup map generated at the end to resolve haskell names
-- to db names
entitySqlNameByHaskellName :: HashMap EntityNameHS EntityNameDB
entitySqlNameByHaskellName =
HM.fromList $
map
(\def -> (getEntityHaskellName def, getEntityDBName def))
allEntityDefs
foreignReferences :: EntityDef -> [(EntityNameHS, [Text])]
foreignReferences edef = do
foreignDef <- getEntityForeignDefs edef
let name = foreignRefTableHaskell foreignDef
let fields = do
((fieldName, _), _) <- foreignFields foreignDef
pure $ unFieldNameHS fieldName
pure (name, fields)
fieldReferences :: EntityDef -> [(EntityNameHS, [Text])]
fieldReferences edef = do
fieldDef <- getEntityFields edef
name <-
case fieldReference fieldDef of
ForeignRef name -> pure name
_ -> empty
let fields = pure $ unFieldNameHS $ fieldHaskell fieldDef
pure (name, fields)
renderAllEnumDocsToHtml :: Text
renderAllEnumDocsToHtml =
T.intercalate
"\n"
( enumDocsToHtml
<$> sortOn (\e -> nameBase e.name) allPostgresEnumTypeDocs
)
where
enumDocsToHtml :: EnumDocs -> Text
enumDocsToHtml enumDocs =
let enumName = T.pack (nameBase enumDocs.name)
in mconcat
[ "<h2 id=\""
, T.pack (nameBase enumDocs.name)
, "\">"
, "<a href=\"" <> "#" <> enumName <> "\">" <> enumName <> "</a>"
, "</h2>"
, "\n"
, maybe "" (T.pack . ("\n" <>) . (<> "\n")) enumDocs.docs
, "\n"
, enumConstructorDocsToTable enumDocs.constructorDocs
]
enumConstructorDocsToTable :: [ConstructorDocs] -> Text
enumConstructorDocsToTable constructorDocsLst =
constructorDocsHeader
<> "\n"
<> (mconcat $ constructorDocsToMarkdownTableRow <$> constructorDocsLst)
<> "</tbody>"
<> "</table>"
where
constructorDocsHeader :: Text
constructorDocsHeader =
T.unlines
[ "<table>"
, "<colgroup>"
, "<col style=\"width: 50%\" />"
, "<col style=\"width: 50%\" />"
, "</colgroup>"
, "<thead>"
, "<tr class=\"header\">"
, "<th>Enum Value</th>"
, "<th>Description</th>"
, "</tr>"
, "</thead>"
, "<tbody>"
]
constructorDocsToMarkdownTableRow :: ConstructorDocs -> Text
constructorDocsToMarkdownTableRow constructorDocs =
"<tr><td><code>"
<> T.pack (nameBase constructorDocs.name)
<> "</code></td>\n<td>"
<> maybe "" (T.pack . newLinesToSpaces) constructorDocs.docs
<> "</td></tr>\n"
newLinesToSpaces s = (\c -> if c == '\n' then "<br>" else [c]) =<< s
renderAllEnumDocsToMarkdown :: Text
renderAllEnumDocsToMarkdown =
T.intercalate
"\n"
( enumDocsToMarkdown
<$> sortBy (\e1 e2 -> compare (nameBase e1.name) (nameBase e2.name)) allPostgresEnumTypeDocs
)
where
enumDocsToMarkdown :: EnumDocs -> Text
enumDocsToMarkdown enumDocs =
"## "
<> T.pack (nameBase enumDocs.name)
<> "\n"
<> maybe "" (T.pack . ("\n" <>) . (<> "\n")) enumDocs.docs
<> "\n"
<> enumConstructorDocsToTable enumDocs.constructorDocs
enumConstructorDocsToTable :: [ConstructorDocs] -> Text
enumConstructorDocsToTable constructorDocsLst =
constructorDocsHeader
<> "\n"
<> (mconcat $ constructorDocsToMarkdownTableRow <$> constructorDocsLst)
where
constructorDocsHeader :: Text
constructorDocsHeader =
"|Enum Value|Description|\n"
<> "|---|---|"
constructorDocsToMarkdownTableRow :: ConstructorDocs -> Text
constructorDocsToMarkdownTableRow constructorDocs =
"|`"
<> T.pack (nameBase constructorDocs.name)
<> "`|"
<> maybe "" (T.pack . newLinesToSpaces) constructorDocs.docs
<> "|\n"
newLinesToSpaces s = (\c -> if c == '\n' then "<br>" else [c]) =<< s
enumNameSet :: Set Text
enumNameSet = enumDocsToNameSet allPostgresEnumTypeDocs
-- | Taken pretty directly from persistent-documentation.
-- We use our own renderer however due to differences in render field where we want to insert the enum links and the header
customMarkdownTableRenderer :: Renderer Text
customMarkdownTableRenderer = Renderer {..}
where
renderField :: FieldDef -> Maybe Text -> Text
renderField FieldDef {..} mextra =
fold
[ "| `"
, unFieldNameDB fieldDB
, "` | "
, maybe
(showType fieldSqlType)
(\fieldNameLink -> "[" <> showType fieldSqlType <> "]" <> "(#" <> fieldNameLink <> ")")
(mFieldNameLink enumNameSet fieldType)
, " | "
, if isNullable fieldAttrs then ":heavy_check_mark:" else ""
, " | "
, foldMap cleanComment mextra
, " |"
]
renderFields :: [Text] -> Text
renderFields xs =
T.unlines $
"| Column name | Type | Nullable | Description |"
: "|-|-|-|-|"
: xs
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderEntity ed@EntityDef {..} mdocs fields =
T.unlines
( ["## `" <> unEntityNameDB entityDB <> "`" <> "\n"]
++ maybe [] singleton mdocs
++ [ "* Primary ID: `" <> getIdFieldName (getEntityId ed) <> "`"
, "" -- for adding line break after previous line
]
++ maybe [] renderUniquenessConstraints (NM.nonEmpty entityUniques)
)
<> fields
getIdFieldName :: EntityIdDef -> Text
getIdFieldName (EntityIdField fd) = unFieldNameDB (fieldDB fd)
getIdFieldName (EntityIdNaturalKey (CompositeDef fs _attrs)) =
T.intercalate " + " $ NM.toList $ NM.map (unFieldNameDB . fieldDB) fs
-- Render a list item w/ a nested items for each uniqueness constraint
renderUniquenessConstraints :: NM.NonEmpty UniqueDef -> [Text]
renderUniquenessConstraints uniqueDefs =
concat
[ ["* Uniqueness Constraint(s):"]
, NM.toList (renderUniquenessConstraint <$> uniqueDefs)
, [""]
]
-- Render the nested list item describing a single uniquness constraint
-- as @contraint_name (field_1, field_2, etc)@.
renderUniquenessConstraint :: UniqueDef -> Text
renderUniquenessConstraint UniqueDef {..} =
mconcat
[ " * `"
, unConstraintNameDB uniqueDBName
, " ("
, T.intercalate ", " . NM.toList $ map (unFieldNameDB . snd) uniqueFields
, ")`"
]
renderEntities :: [Text] -> Text
renderEntities = T.unlines
showType SqlString = "string"
showType SqlInt32 = "integer (32)"
showType SqlInt64 = "integer (64)"
showType SqlReal = "double"
showType SqlNumeric {} = "numeric"
showType SqlDay = "date"
showType SqlTime = "time"
showType SqlDayTime = "datetime"
showType SqlBlob = "blob"
showType SqlBool = "boolean"
showType (SqlOther t) = t
isNullable :: [FieldAttr] -> Bool
isNullable attrs =
FieldAttrMaybe `elem` attrs || FieldAttrNullable `elem` attrs
cleanComment :: Text -> Text
cleanComment comment =
let -- Newline characters may be present in a comment. The need to be removed
-- to allow the markdown tables to render properly.
newlineToBr '\n' = "<br>"
newlineToBr c = T.singleton c
in T.concatMap newlineToBr $ T.strip comment
Raw
Html.hs
-- | Render our .persistentmodels to HTML
--
-- This code was largely pulled out of persistent-documentation
module DocumentDatabaseModels.Html (renderEntitiesToHtml) where
import A.MercuryPrelude
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Database.Persist.EntityDef.Internal
import DocumentDatabaseModels.Triggers
import DocumentDatabaseModels.Utils (mFieldNameLink)
import Mercury.Persistent
import Mercury.Persistent.TH.DeriveDocumentationInfo
import MigrateModels.BlockDeletes (TableDeletability (..), tableDeletability)
import MigrateModels.ImmutableColumns (FieldMutability (..), fieldDefMutability)
import MigrateModels.Snowflake (fieldSnowflakeStatus)
import MigrateModels.Snowflake.Types (SnowflakeStatus (..))
-- | Renders HTML documentation of our .persistentmodels files.
renderEntitiesToHtml ::
RequireCallStack =>
-- | A list of every 'EnumDocs' (use @allPostgresEnumTypeDocs@). This is taken as a parameter, instead of imported directly, to avoid this module depending on every .persistentmodules file.
[EnumDocs] ->
-- | A list of every 'EntityDef' (use @allEntityDefs@). This is taken as a parameter, instead of imported directly, to avoid this module depending on every .persistentmodules file.
[EntityDef] ->
Map TableName [TriggerInfo] ->
Text
renderEntitiesToHtml enumDocs entityDefs triggerInfoMap = fieldMutabilityLegend <> (renderEntities $ map entityToText entityDefs)
where
entityToText :: EntityDef -> Text
entityToText ent = renderEntity ent entityDocs renderedFields triggerInfoMap
where
enumNames = enumDocsToNameSet enumDocs
fields = toList $ keyAndEntityFieldsDatabase ent
entityDocs = entityComments ent
renderedFields =
renderFields (map (\f -> renderField enumNames ent f (fieldComments f)) fields)
-- | version of keyAndEntityFields which returns all fields until upstream isupdated
keyAndEntityFieldsDatabase :: RequireCallStack => EntityDef -> NE.NonEmpty FieldDef
keyAndEntityFieldsDatabase ent =
case entityId ent of
EntityIdField fd ->
fd :| fields
EntityIdNaturalKey _ ->
case NE.nonEmpty fields of
Nothing ->
error $
mconcat
[ "persistent internal guarantee failed: entity is "
, "defined with an entityId = EntityIdNaturalKey, "
, "but somehow doesn't have any entity fields."
]
Just xs ->
xs
where
fields = entityFields ent
renderField :: Set Text -> EntityDef -> FieldDef -> Maybe Text -> Text
renderField enumNames anEntityDef fd@FieldDef {..} mextra =
fold
[ "<tr>"
, "<td><code>"
, unFieldNameDB fieldDB
, "</code></td>"
, maybe
("<td>" <> showType fieldSqlType <> "</td>")
(\fieldNameLink -> "<td><a href=\"#" <> fieldNameLink <> "\">" <> showType fieldSqlType <> "</a></td>")
(mFieldNameLink enumNames fieldType)
, "<td style=\"text-align: center\">"
, if isNullable fieldAttrs then "✅" else ""
, "</td>"
, "<td>"
, getMutabilityDescription anEntityDef fd
, "</td>"
, "<td style=\"text-align: center\">"
, getSnowflakeDescription anEntityDef fd
, "</td>"
, "<td>"
, foldMap cleanComment mextra
, "</td>"
, "</tr>"
]
getMutabilityDescription :: EntityDef -> FieldDef -> Text
getMutabilityDescription anEntityDef fieldDef = fieldDefMutabilityToLabel $ fieldDefMutability anEntityDef fieldDef
getSnowflakeDescription :: EntityDef -> FieldDef -> Text
getSnowflakeDescription anEntityDef fieldDef = snowflakeStatusToLabel $ fieldSnowflakeStatus anEntityDef fieldDef
snowflakeStatusToLabel :: SnowflakeStatus -> Text
snowflakeStatusToLabel snowflakeStatus = case snowflakeStatus of
SendToSnowflake -> "❄️"
DontSendToSnowflake -> "✖"
SnowflakeStatusUnknown -> "?"
fieldDefMutabilityToLabel :: FieldMutability -> Text
fieldDefMutabilityToLabel fieldMutability = case fieldMutability of
FieldMutabilityMutable -> "Mutable"
FieldMutabilityMutableIfNull -> "Mutable if NULL"
FieldMutabilityUndetermined -> "?"
FieldMutabilityImmutable -> "Immutable"
fieldMutabilityDescription :: FieldMutability -> Text
fieldMutabilityDescription fieldMutability = case fieldMutability of
FieldMutabilityMutable -> "An engineer is explicitly saying that some code exists that UPDATEs this column"
FieldMutabilityMutableIfNull -> "This column can only be UPDATEd if the current value is NULL. Used for fields like deleted_at that are set at most one time."
FieldMutabilityUndetermined -> "We haven't explicitly defined if the column can be updated. The default SQL behavior allows UPDATE, so use your judgment on if you think it can be updated or ask an engineer to set an explicit value."
FieldMutabilityImmutable -> "This column cannot be updated. This is enforced by a database trigger."
fieldMutabilityLegend :: Text
fieldMutabilityLegend =
fold
[ "<div style=\"max-width:900px;\">"
, "<h2>"
, "Mutability Legend"
, "</h2>"
, "<p>"
, "By default in a SQL database, you can update a column's value at any time."
, " We're currently in the process of enforcing that some values cannot be updated, to more clearly document update behavior and enforce correct semantics."
, " These values will appear in the Mutability column to tell you if UPDATE is allowed."
, "</p>"
, "<table>"
, "<colgroup>"
, "<col style=\"width: 15%\" />"
, "<col style=\"width: 85%\" />"
, "</colgroup>"
, "<thead>"
, "<tr>"
, "<th>Mutability</th>"
, "<th>Description</th>"
, "</tr>"
, "</thead>"
, "<tbody>"
, foldMap mutabilityRow [minBound .. maxBound]
, "</tbody>"
, "</table>"
, "</div>"
]
where
mutabilityRow :: FieldMutability -> Text
mutabilityRow fm =
fold
[ "<tr>"
, "<td>"
, fieldDefMutabilityToLabel fm
, "</td>"
, "<td>"
, fieldMutabilityDescription fm
, "</td>"
, "</tr>"
]
renderFields :: [Text] -> Text
renderFields xs =
T.unlines $
[ "<table>"
, "<colgroup>"
, "<col style=\"width: 20%\" />"
, "<col style=\"width: 10%\" />"
, "<col style=\"width: 5%\" />"
, "<col style=\"width: 8%\" />"
, "<col style=\"width: 5%\" />"
, "<col style=\"width: 52%\" />"
, "</colgroup>"
, "<thead>"
, "<tr class=\"header\">"
, "<th>Column name</th>"
, "<th>Type</th>"
, "<th>Nullable</th>"
, "<th>Mutability</th>"
, "<th>In Snowflake?</th>"
, "<th>Description</th>"
, "</tr>"
, "</thead><tbody>"
]
++ xs
++ ["</tbody></table>"]
renderEntity :: EntityDef -> Maybe Text -> Text -> Map TableName [TriggerInfo] -> Text
renderEntity ed@EntityDef {..} mdocs fields triggerInfoMap =
let entName = unEntityNameDB entityDB
in T.unlines
( [ "<h2 id=\""
<> entName
<> "\"><code>"
<> "<a href=\""
<> "#"
<> entName
<> "\">"
<> entName
<> "</a>"
<> "</code></h2>"
]
++ maybe [] toParagraphs mdocs
++ [ "<p>Primary ID: <code>"
<> getIdFieldName (getEntityId ed)
<> "</code></p>"
]
++ maybe [] renderUniquenessConstraints (NE.nonEmpty entityUniques)
)
<> "<p>"
<> tableDeletabilityDescription ed
<> "</p>"
<> fields
<> "<br>"
<> renderTableTriggerInfo entName triggerInfoMap
tableDeletabilityDescription :: EntityDef -> Text
tableDeletabilityDescription ed =
"Rows can be DELETEd? " <> case tableDeletability ed of
TableDeletabilityAllowDeletes -> "Yes"
TableDeletabilityBlockDeletes -> "No"
TableDeletabilityUndetermined -> "Unknown"
-- | Split the input string at consecutive newlines & wrap each element in
-- a paragraph tag.
toParagraphs :: Text -> [Text]
toParagraphs =
map (\text -> "<p>" <> text <> "</p>")
. filter (not . T.null)
. T.splitOn "\n\n"
getIdFieldName :: EntityIdDef -> Text
getIdFieldName (EntityIdField fd) = unFieldNameDB (fieldDB fd)
getIdFieldName (EntityIdNaturalKey (CompositeDef fs _attrs)) =
T.intercalate " + " $ NE.toList $ NE.map (unFieldNameDB . fieldDB) fs
-- | Render an unordered list of uniqueness constraints under a paragraph
-- element.
--
-- Each constraint is rendered as @constraint_name (field_1, field_2, ...)@.
renderUniquenessConstraints :: NE.NonEmpty UniqueDef -> [Text]
renderUniquenessConstraints uniqueDefs =
concat
[
[ "<p>Uniqueness Constraint(s):</p>"
, "<ul>"
]
, NE.toList $ renderUniquenessConstraint <$> uniqueDefs
,
[ "</ul>"
]
]
where
renderUniquenessConstraint :: UniqueDef -> Text
renderUniquenessConstraint UniqueDef {..} =
mconcat
[ "<li><code>"
, unConstraintNameDB uniqueDBName
, " ("
, T.intercalate ", " . NE.toList $ map (unFieldNameDB . snd) uniqueFields
, ")"
, "</code></li>"
]
renderEntities :: [Text] -> Text
renderEntities = T.unlines
showType :: SqlType -> Text
showType SqlString = "string"
showType SqlInt32 = "integer (32)"
showType SqlInt64 = "integer (64)"
showType SqlReal = "double"
showType SqlNumeric {} = "numeric"
showType SqlDay = "date"
showType SqlTime = "time"
showType SqlDayTime = "datetime"
showType SqlBlob = "blob"
showType SqlBool = "boolean"
showType (SqlOther t) = t
isNullable :: [FieldAttr] -> Bool
isNullable attrs =
FieldAttrMaybe `elem` attrs || FieldAttrNullable `elem` attrs
cleanComment :: Text -> Text
cleanComment comment =
let -- Newline characters may be present in a comment. The need to be removed
-- to allow the markdown tables to render properly.
newlineToBr '\n' = "<br>"
newlineToBr c = T.singleton c
in T.concatMap newlineToBr $ T.strip comment
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment