abhin4v
/
ringo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adds a smart constructor for Env for better type safety. 

- Env is now created through a smart constructor which does
  validations.
pull/1/head
Abhinav Sarkar 2016-02-05 16:17:57 +05:30
parent b58e022b0e
commit ade5c388d8
13 changed files with 439 additions and 379 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
app/Main.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Main where module Main where
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
@ -8,7 +10,6 @@ import qualified Data.Text as Text
import Data.Aeson (encode) import Data.Aeson (encode)
import Data.Char (toLower) import Data.Char (toLower)
import Data.List (nub)
import Control.Monad (forM_) import Control.Monad (forM_)
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), (<.>)) import System.FilePath ((</>), (<.>))
@ -27,14 +28,12 @@ main = do
case result of case result of
Left err -> putStrLn err >> exitFailure Left err -> putStrLn err >> exitFailure
Right (tables, facts, defaults) -> do Right (tables, facts, defaults) -> do
let env = Env tables facts progSettings defaults case makeEnv tables facts progSettings defaults of
let errors = nub $ concatMap (validateTable env) tables ++ concatMap (validateFact env) facts Left errors -> mapM_ print errors >> exitFailure
if not $ null errors Right env -> writeFiles progOutputDir env >> exitSuccess
then mapM_ print errors >> exitFailure
else writeFiles progOutputDir env >> exitSuccess
writeFiles :: FilePath -> Env -> IO () writeFiles :: FilePath -> Env -> IO ()
writeFiles outputDir env@Env{..} = do writeFiles outputDir env@(envView -> EnvV{..}) = do
let Settings{..} = envSettings let Settings{..} = envSettings
forM_ sqls $ \(sqlType, table, sql) -> do forM_ sqls $ \(sqlType, table, sql) -> do
let dirName = outputDir </> map toLower (show sqlType) let dirName = outputDir </> map toLower (show sqlType)

3
app/Ringo/InputParser.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Ringo.InputParser (parseInput) where module Ringo.InputParser (parseInput) where
import qualified Data.Text as Text import qualified Data.Text as Text
@ -85,5 +86,5 @@ parseInput :: FilePath -> IO (Either String ([Table], [Fact], TypeDefaults))
parseInput file = do parseInput file = do
result <- decodeFileEither file result <- decodeFileEither file
return $ case result of return $ case result of
Left pe -> Left $ prettyPrintParseException pe Left pe -> Left $ prettyPrintParseException pe
Right (Input tables facts defaults) -> Right (tables, facts, defaults) Right (Input tables facts defaults) -> Right (tables, facts, defaults)

1
ringo.cabal
View File

@ -26,6 +26,7 @@ library
Ringo.Generator.Create, Ringo.Generator.Create,
Ringo.Generator.Populate.Dimension, Ringo.Generator.Populate.Dimension,
Ringo.Generator.Populate.Fact, Ringo.Generator.Populate.Fact,
Ringo.Types.Internal,
Ringo.Utils Ringo.Utils
build-depends: base >=4.7 && <5, build-depends: base >=4.7 && <5,
text >=1.2 && <1.3, text >=1.2 && <1.3,

24
src/Ringo.hs
View File

@ -12,8 +12,7 @@ module Ringo
, factTableDefnSQL , factTableDefnSQL
, dimensionTablePopulateSQL , dimensionTablePopulateSQL
, factTablePopulateSQL , factTablePopulateSQL
, validateTable , makeEnv
, validateFact
) where ) where
import Control.Monad.Reader (runReader) import Control.Monad.Reader (runReader)
@ -135,9 +134,14 @@ import qualified Ringo.Validator as V
-- , ("text", "'__UNKNOWN_VAL__'") -- , ("text", "'__UNKNOWN_VAL__'")
-- ] -- ]
-- settings = defSettings { settingTableNameSuffixTemplate = "" } -- settings = defSettings { settingTableNameSuffixTemplate = "" }
-- env = Env tables facts settings typeDefaults -- env = case makeEnv tables facts settings typeDefaults of
-- Left errors -> error . unlines . map show $ errors
-- Right env -> env
-- :} -- :}
makeEnv :: [Table] -> [Fact] -> Settings -> TypeDefaults -> Either [ValidationError] Env
makeEnv = V.validateEnv
-- | -- |
-- --
-- >>> print $ extractFactTable env sessionFact -- >>> print $ extractFactTable env sessionFact
@ -615,17 +619,3 @@ dimensionTablePopulateSQL popMode env fact =
factTablePopulateSQL :: TablePopulationMode -> Env -> Fact -> [Text] factTablePopulateSQL :: TablePopulationMode -> Env -> Fact -> [Text]
factTablePopulateSQL popMode env = factTablePopulateSQL popMode env =
flip runReader env . G.factTablePopulateSQL popMode flip runReader env . G.factTablePopulateSQL popMode
-- |
--
-- >>> concatMap (validateTable env) tables
-- []
validateTable :: Env -> Table -> [ValidationError]
validateTable env = flip runReader env . V.validateTable
-- |
--
-- >>> concatMap (validateFact env) facts
-- []
validateFact :: Env -> Fact -> [ValidationError]
validateFact env = flip runReader env . V.validateFact

91
src/Ringo/Extractor.hs
View File

@ -11,7 +11,7 @@ module Ringo.Extractor
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Tree as Tree import qualified Data.Tree as Tree
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, asks, withReader)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.List (nub) import Data.List (nub)
@ -22,57 +22,58 @@ import Ringo.Utils
extractFactTable :: Fact -> Reader Env Table extractFactTable :: Fact -> Reader Env Table
extractFactTable fact = do extractFactTable fact = do
Settings {..} <- asks envSettings allDims <- extractAllDimensionTables fact
allDims <- extractAllDimensionTables fact withReader envView $ do
tables <- asks envTables Settings {..} <- asks envSettings
let table = fromJust . findTable (factTableName fact) $ tables tables <- asks envTables
let table = fromJust . findTable (factTableName fact) $ tables
let countColType = settingFactCountColumnType let countColType = settingFactCountColumnType
dimIdColName = settingDimTableIdColumnName dimIdColName = settingDimTableIdColumnName
sourceColumn cName = fromJust . findColumn cName . tableColumns $ table sourceColumn cName = fromJust . findColumn cName . tableColumns $ table
notNullSourceColumnCopy cName = (sourceColumn cName) { columnNullable = NotNull } notNullSourceColumnCopy cName = (sourceColumn cName) { columnNullable = NotNull }
notNullSourceColumnRename scName cName = (notNullSourceColumnCopy scName) { columnName = cName } notNullSourceColumnRename scName cName = (notNullSourceColumnCopy scName) { columnName = cName }
columns = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> columns = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} ->
case factColType of case factColType of
DimTime -> DimTime ->
[ Column (timeUnitColumnName dimIdColName cName settingTimeUnit) "bigint" NotNull ] [ Column (timeUnitColumnName dimIdColName cName settingTimeUnit) "bigint" NotNull ]
NoDimId -> [ notNullSourceColumnCopy cName ] NoDimId -> [ notNullSourceColumnCopy cName ]
TenantId -> [ notNullSourceColumnCopy cName ] TenantId -> [ notNullSourceColumnCopy cName ]
FactCount {..} -> [ Column cName countColType NotNull ] FactCount {..} -> [ Column cName countColType NotNull ]
FactCountDistinct {..} -> [ Column cName "json" NotNull ] FactCountDistinct {..} -> [ Column cName "json" NotNull ]
FactSum {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] FactSum {..} -> [ notNullSourceColumnRename factColSourceColumn cName ]
FactMax {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] FactMax {..} -> [ notNullSourceColumnRename factColSourceColumn cName ]
FactMin {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] FactMin {..} -> [ notNullSourceColumnRename factColSourceColumn cName ]
FactAverage {..} -> FactAverage {..} ->
[ Column (cName <> settingAvgCountColumSuffix) countColType NotNull [ Column (cName <> settingAvgCountColumSuffix) countColType NotNull
, notNullSourceColumnRename factColSourceColumn (cName <> settingAvgSumColumnSuffix) , notNullSourceColumnRename factColSourceColumn (cName <> settingAvgSumColumnSuffix)
] ]
_ -> [] _ -> []
fkColumns = for allDims $ \(dimFact, dimTable) -> fkColumns = for allDims $ \(dimFact, dimTable) ->
let colName = factDimFKIdColumnName settingDimPrefix dimIdColName dimFact dimTable tables let colName = factDimFKIdColumnName settingDimPrefix dimIdColName dimFact dimTable tables
colType = idColTypeToFKIdColType settingDimTableIdColumnType colType = idColTypeToFKIdColType settingDimTableIdColumnType
in Column colName colType NotNull in Column colName colType NotNull
ukColNames = ukColNames =
(++ map columnName fkColumns) (++ map columnName fkColumns)
. forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> . forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} ->
case factColType of case factColType of
DimTime -> Just $ timeUnitColumnName dimIdColName cName settingTimeUnit DimTime -> Just $ timeUnitColumnName dimIdColName cName settingTimeUnit
NoDimId -> Just cName NoDimId -> Just cName
TenantId -> Just cName TenantId -> Just cName
_ -> Nothing _ -> Nothing
return Table return Table
{ tableName = { tableName =
extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit
, tableColumns = columns ++ fkColumns , tableColumns = columns ++ fkColumns
, tableConstraints = [ UniqueKey ukColNames ] , tableConstraints = [ UniqueKey ukColNames ]
} }
extractDependencies :: Fact -> Reader Env Dependencies extractDependencies :: Fact -> Reader Env Dependencies
extractDependencies fact = do extractDependencies fact = withReader envView $ do
settings@Settings{..} <- asks envSettings settings@Settings{..} <- asks envSettings
facts <- asks envFacts facts <- asks envFacts
let factSourceDeps = let factSourceDeps =

7
src/Ringo/Extractor/Internal.hs
View File

@ -13,7 +13,7 @@ import qualified Data.Text as Text
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, asks, withReader)
import Data.Function (on) import Data.Function (on)
import Data.Maybe (mapMaybe, fromMaybe, fromJust, catMaybes) import Data.Maybe (mapMaybe, fromMaybe, fromJust, catMaybes)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -59,7 +59,7 @@ idColTypeToFKIdColType typ = case Text.toLower typ of
_ -> typ _ -> typ
extractDimensionTables :: Fact -> Reader Env [Table] extractDimensionTables :: Fact -> Reader Env [Table]
extractDimensionTables fact = do extractDimensionTables fact = withReader envView $ do
settings <- asks envSettings settings <- asks envSettings
tables <- asks envTables tables <- asks envTables
let table = fromJust . findTable (factTableName fact) $ tables let table = fromJust . findTable (factTableName fact) $ tables
@ -99,4 +99,5 @@ extractAllDimensionTables fact = do
parentDims <- concat <$> mapM extract (factParentNames fact) parentDims <- concat <$> mapM extract (factParentNames fact)
return . nubBy ((==) `on` snd) $ myDims ++ parentDims return . nubBy ((==) `on` snd) $ myDims ++ parentDims
where where
extract fName = asks envFacts >>= extractAllDimensionTables . fromJust . findFact fName extract fName =
asks (envFacts . envView) >>= extractAllDimensionTables . fromJust . findFact fName

43
src/Ringo/Generator/Create.hs
View File

@ -11,7 +11,7 @@ module Ringo.Generator.Create (dimensionTableDefnSQL, factTableDefnSQL) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, asks, withReader)
import Database.HsSqlPpp.Syntax ( Statement(..), RowConstraint(..), AlterTableAction(..) import Database.HsSqlPpp.Syntax ( Statement(..), RowConstraint(..), AlterTableAction(..)
, AlterTableOperation(..), Constraint(..), Cascade(..) ) , AlterTableOperation(..), Constraint(..), Cascade(..) )
import Data.Maybe (listToMaybe, maybeToList) import Data.Maybe (listToMaybe, maybeToList)
@ -24,7 +24,7 @@ import Ringo.Types
import Ringo.Utils import Ringo.Utils
tableDefnStmts :: Table -> Reader Env [Statement] tableDefnStmts :: Table -> Reader Env [Statement]
tableDefnStmts Table {..} = do tableDefnStmts Table {..} = withReader envView $ do
Settings {..} <- asks envSettings Settings {..} <- asks envSettings
let tabName = tableName <> settingTableNameSuffixTemplate let tabName = tableName <> settingTableNameSuffixTemplate
@ -58,7 +58,7 @@ dimensionTableDefnSQL :: Table -> Reader Env [Text]
dimensionTableDefnSQL table = tableDefnSQL table dimensionTableIndexStmts dimensionTableDefnSQL table = tableDefnSQL table dimensionTableIndexStmts
dimensionTableIndexStmts :: Table -> Reader Env [Statement] dimensionTableIndexStmts :: Table -> Reader Env [Statement]
dimensionTableIndexStmts Table {..} = do dimensionTableIndexStmts Table {..} = withReader envView $do
Settings {..} <- asks envSettings Settings {..} <- asks envSettings
let tabName = tableName <> settingTableNameSuffixTemplate let tabName = tableName <> settingTableNameSuffixTemplate
tablePKColName = head [ cName | PrimaryKey cName <- tableConstraints ] tablePKColName = head [ cName | PrimaryKey cName <- tableConstraints ]
@ -72,25 +72,26 @@ factTableDefnSQL fact table = tableDefnSQL table (factTableIndexStmts fact)
factTableIndexStmts :: Fact -> Table -> Reader Env [Statement] factTableIndexStmts :: Fact -> Table -> Reader Env [Statement]
factTableIndexStmts fact table = do factTableIndexStmts fact table = do
Settings {..} <- asks envSettings allDims <- extractAllDimensionTables fact
tables <- asks envTables withReader envView $ do
allDims <- extractAllDimensionTables fact Settings {..} <- asks envSettings
tables <- asks envTables
let dimTimeCol = head [ cName | DimTimeV cName <- factColumns fact ] let dimTimeCol = head [ cName | DimTimeV cName <- factColumns fact ]
tenantIdCol = listToMaybe [ cName | TenantIdV cName <- factColumns fact ] tenantIdCol = listToMaybe [ cName | TenantIdV cName <- factColumns fact ]
tabName = tableName table <> settingTableNameSuffixTemplate tabName = tableName table <> settingTableNameSuffixTemplate
dimTimeColName cName = timeUnitColumnName settingDimTableIdColumnName cName settingTimeUnit dimTimeColName cName = timeUnitColumnName settingDimTableIdColumnName cName settingTimeUnit
factCols = forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> factCols = forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} ->
case factColType of case factColType of
DimTime -> Just [dimTimeColName cName] DimTime -> Just [dimTimeColName cName]
NoDimId -> Just [cName] NoDimId -> Just [cName]
TenantId -> Just [cName] TenantId -> Just [cName]
_ -> Nothing _ -> Nothing
dimCols = [ [ factDimFKIdColumnName settingDimPrefix settingDimTableIdColumnName dimFact dimTable tables ] dimCols = [ [ factDimFKIdColumnName settingDimPrefix settingDimTableIdColumnName dimFact dimTable tables ]
| (dimFact, dimTable) <- allDims ] | (dimFact, dimTable) <- allDims ]
return [ CreateIndexTSQL ea (nmc "") (name tabName) (map nmc cols) return [ CreateIndexTSQL ea (nmc "") (name tabName) (map nmc cols)
| cols <- factCols ++ dimCols ++ [ [cName, dimTimeColName dimTimeCol] | cols <- factCols ++ dimCols ++ [ [cName, dimTimeColName dimTimeCol]
| cName <- maybeToList tenantIdCol ] ] | cName <- maybeToList tenantIdCol ] ]

4
src/Ringo/Generator/Populate/Dimension.hs
View File

@ -10,7 +10,7 @@ module Ringo.Generator.Populate.Dimension (dimensionTablePopulateSQL) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, asks, withReader)
import Database.HsSqlPpp.Syntax (Statement, QueryExpr(..), Distinct(..), makeSelect, JoinType(..)) import Database.HsSqlPpp.Syntax (Statement, QueryExpr(..), Distinct(..), makeSelect, JoinType(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Text (Text) import Data.Text (Text)
@ -25,7 +25,7 @@ dimensionTablePopulateSQL popMode fact dimTableName =
ppStatement <$> dimensionTablePopulateStmt popMode fact dimTableName ppStatement <$> dimensionTablePopulateStmt popMode fact dimTableName
dimensionTablePopulateStmt :: TablePopulationMode -> Fact -> TableName -> Reader Env Statement dimensionTablePopulateStmt :: TablePopulationMode -> Fact -> TableName -> Reader Env Statement
dimensionTablePopulateStmt popMode fact dimTableName = do dimensionTablePopulateStmt popMode fact dimTableName = withReader envView $ do
Settings {..} <- asks envSettings Settings {..} <- asks envSettings
tables <- asks envTables tables <- asks envTables
defaults <- asks envTypeDefaults defaults <- asks envTypeDefaults

181
src/Ringo/Generator/Populate/Fact.hs
View File

@ -16,7 +16,7 @@ import qualified Data.Text as Text
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, asks, withReader)
import Database.HsSqlPpp.Syntax ( QueryExpr(..), Statement, makeSelect import Database.HsSqlPpp.Syntax ( QueryExpr(..), Statement, makeSelect
, SelectList(..), SelectItem(..), JoinType(..) ) , SelectList(..), SelectItem(..), JoinType(..) )
import Data.List (nub) import Data.List (nub)
@ -57,7 +57,7 @@ $$
LANGUAGE 'plpgsql' IMMUTABLE; LANGUAGE 'plpgsql' IMMUTABLE;
|] |]
factCountDistinctUpdateStmts :: TablePopulationMode -> Fact -> Text -> QueryExpr -> Reader Env [Statement] factCountDistinctUpdateStmts :: TablePopulationMode -> Fact -> Text -> QueryExpr -> Reader EnvV [Statement]
factCountDistinctUpdateStmts popMode fact groupByColPrefix expr = case expr of factCountDistinctUpdateStmts popMode fact groupByColPrefix expr = case expr of
Select {selSelectList = SelectList _ origSelectItems, ..} -> do Select {selSelectList = SelectList _ origSelectItems, ..} -> do
Settings {..} <- asks envSettings Settings {..} <- asks envSettings
@ -126,107 +126,108 @@ factCountDistinctUpdateStmts popMode fact groupByColPrefix expr = case expr of
factTablePopulateStmts :: TablePopulationMode -> Fact -> Reader Env [Statement] factTablePopulateStmts :: TablePopulationMode -> Fact -> Reader Env [Statement]
factTablePopulateStmts popMode fact = do factTablePopulateStmts popMode fact = do
Settings {..} <- asks envSettings allDims <- extractAllDimensionTables fact
allDims <- extractAllDimensionTables fact withReader envView $ do
tables <- asks envTables Settings {..} <- asks envSettings
defaults <- asks envTypeDefaults tables <- asks envTables
let fTableName = factTableName fact defaults <- asks envTypeDefaults
fTable = fromJust . findTable fTableName $ tables let fTableName = factTableName fact
dimIdColName = settingDimTableIdColumnName fTable = fromJust . findTable fTableName $ tables
dimIdColName = settingDimTableIdColumnName
coalesceFKId ex = coalesceFKId ex =
app "coalesce" [ ex, num . Text.pack . show $ settingForeignKeyIdCoalesceValue ] app "coalesce" [ ex, num . Text.pack . show $ settingForeignKeyIdCoalesceValue ]
timeUnitColumnInsertSQL cName = timeUnitColumnInsertSQL cName =
let colName = timeUnitColumnName dimIdColName cName settingTimeUnit let colName = timeUnitColumnName dimIdColName cName settingTimeUnit
in ( colName in ( colName
, cast (app "floor" [ binop "/" (extEpoch (eqi fTableName cName)) , cast (app "floor" [ binop "/" (extEpoch (eqi fTableName cName))
(num . Text.pack . show . timeUnitToSeconds $ settingTimeUnit) ]) (num . Text.pack . show . timeUnitToSeconds $ settingTimeUnit) ])
"bigint" "bigint"
, True , True
) )
dimIdColumnInsertSQL cName = dimIdColumnInsertSQL cName =
let sCol = fromJust . findColumn cName $ tableColumns fTable let sCol = fromJust . findColumn cName $ tableColumns fTable
in (cName, coalesceColumn defaults fTableName sCol, True) in (cName, coalesceColumn defaults fTableName sCol, True)
app' f cName = app f [ eqi fTableName cName ] app' f cName = app f [ eqi fTableName cName ]
factColMap = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> factColMap = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} ->
case factColType of case factColType of
DimTime -> [ timeUnitColumnInsertSQL cName ] DimTime -> [ timeUnitColumnInsertSQL cName ]
NoDimId -> [ dimIdColumnInsertSQL cName ] NoDimId -> [ dimIdColumnInsertSQL cName ]
TenantId -> [ dimIdColumnInsertSQL cName ] TenantId -> [ dimIdColumnInsertSQL cName ]
FactCount {..} -> FactCount {..} ->
[ (cName, app "count" [ maybe star (eqi fTableName) factColMaybeSourceColumn ], False) ] [ (cName, app "count" [ maybe star (eqi fTableName) factColMaybeSourceColumn ], False) ]
FactCountDistinct {..} -> [ (cName, cast (str "{}") "json", False) ] FactCountDistinct {..} -> [ (cName, cast (str "{}") "json", False) ]
FactSum {..} -> [ (cName, app' "sum" factColSourceColumn, False) ] FactSum {..} -> [ (cName, app' "sum" factColSourceColumn, False) ]
FactMax {..} -> [ (cName, app' "max" factColSourceColumn, False) ] FactMax {..} -> [ (cName, app' "max" factColSourceColumn, False) ]
FactMin {..} -> [ (cName, app' "min" factColSourceColumn, False) ] FactMin {..} -> [ (cName, app' "min" factColSourceColumn, False) ]
FactAverage {..} -> FactAverage {..} ->
[ ( cName <> settingAvgCountColumSuffix, app' "count" factColSourceColumn, False ) [ ( cName <> settingAvgCountColumSuffix, app' "count" factColSourceColumn, False )
, ( cName <> settingAvgSumColumnSuffix , app' "sum" factColSourceColumn , False) , ( cName <> settingAvgSumColumnSuffix , app' "sum" factColSourceColumn , False)
] ]
_ -> [] _ -> []
dimColMap = for allDims $ \(dimFact, factTable@Table {tableName}) -> let dimColMap = for allDims $ \(dimFact, factTable@Table {tableName}) -> let
dimFKIdColName = dimFKIdColName =
factDimFKIdColumnName settingDimPrefix dimIdColName dimFact factTable tables factDimFKIdColumnName settingDimPrefix dimIdColName dimFact factTable tables
factSourceTableName = factTableName dimFact factSourceTableName = factTableName dimFact
factSourceTable = fromJust . findTable factSourceTableName $ tables factSourceTable = fromJust . findTable factSourceTableName $ tables
dimFKIdColumn = fromJust . findColumn dimFKIdColName $ tableColumns factSourceTable dimFKIdColumn = fromJust . findColumn dimFKIdColName $ tableColumns factSourceTable
dimLookupWhereClauses = Just . foldBinop "and" $ dimLookupWhereClauses = Just . foldBinop "and" $
[ binop "=" (eqi tableName dimColName) (coalesceColumn defaults factSourceTableName sourceCol) [ binop "=" (eqi tableName dimColName) (coalesceColumn defaults factSourceTableName sourceCol)
| (dimColName, sourceColName) <- dimColumnMapping settingDimPrefix dimFact tableName | (dimColName, sourceColName) <- dimColumnMapping settingDimPrefix dimFact tableName
, let sourceCol = fromJust . findColumn sourceColName $ tableColumns factSourceTable ] , let sourceCol = fromJust . findColumn sourceColName $ tableColumns factSourceTable ]
insertExpr = if factTable `elem` tables -- existing dimension table insertExpr = if factTable `elem` tables -- existing dimension table
then (if columnNullable dimFKIdColumn == Null then coalesceFKId else id) then (if columnNullable dimFKIdColumn == Null then coalesceFKId else id)
$ eqi factSourceTableName dimFKIdColName $ eqi factSourceTableName dimFKIdColName
else coalesceFKId . subQueryExp $ else coalesceFKId . subQueryExp $
makeSelect makeSelect
{ selSelectList = sl [ si $ ei dimIdColName ] { selSelectList = sl [ si $ ei dimIdColName ]
, selTref = , selTref =
[ trefa (suffixTableName popMode settingTableNameSuffixTemplate tableName) tableName ] [ trefa (suffixTableName popMode settingTableNameSuffixTemplate tableName) tableName ]
, selWhere = dimLookupWhereClauses , selWhere = dimLookupWhereClauses
} }
in (dimFKIdColName, insertExpr, True) in (dimFKIdColName, insertExpr, True)
colMap = [ (cName, (expr, nmc $ groupByColPrefix <> cName), addToGroupBy) colMap = [ (cName, (expr, nmc $ groupByColPrefix <> cName), addToGroupBy)
| (cName, expr, addToGroupBy) <- factColMap ++ dimColMap ] | (cName, expr, addToGroupBy) <- factColMap ++ dimColMap ]
joinClauses = joinClauses =
map (tref &&& joinClausePreds fTable) map (tref &&& joinClausePreds fTable)
. filter (/= fTableName) . filter (/= fTableName)
. nub . nub
. map (factTableName . fst) . map (factTableName . fst)
$ allDims $ allDims
timeCol = eqi fTableName $ head [ cName | DimTimeV cName <- factColumns fact ] timeCol = eqi fTableName $ head [ cName | DimTimeV cName <- factColumns fact ]
extFactTableName = suffixTableName popMode settingTableNameSuffixTemplate extFactTableName = suffixTableName popMode settingTableNameSuffixTemplate
$ extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit $ extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit
populateSelectExpr = populateSelectExpr =
makeSelect makeSelect
{ selSelectList = sl . map (uncurry sia . snd3) $ colMap { selSelectList = sl . map (uncurry sia . snd3) $ colMap
, selTref = [ foldl (\tf (t, oc) -> tjoin tf LeftOuter t oc) (tref fTableName) joinClauses ] , selTref = [ foldl (\tf (t, oc) -> tjoin tf LeftOuter t oc) (tref fTableName) joinClauses ]
, selWhere = Just . foldBinop "and" $ , selWhere = Just . foldBinop "and" $
binop "<" timeCol placeholder : binop "<" timeCol placeholder :
[ binop ">=" timeCol placeholder | popMode == IncrementalPopulation ] [ binop ">=" timeCol placeholder | popMode == IncrementalPopulation ]
, selGroupBy = map (ei . (groupByColPrefix <>) . fst3) . filter thd3 $ colMap , selGroupBy = map (ei . (groupByColPrefix <>) . fst3) . filter thd3 $ colMap
} }
insertIntoStmt = insert extFactTableName (map fst3 colMap) populateSelectExpr insertIntoStmt = insert extFactTableName (map fst3 colMap) populateSelectExpr
updateStmts <- factCountDistinctUpdateStmts popMode fact groupByColPrefix populateSelectExpr updateStmts <- factCountDistinctUpdateStmts popMode fact groupByColPrefix populateSelectExpr
return $ insertIntoStmt : updateStmts return $ insertIntoStmt : updateStmts
where where
groupByColPrefix = "xxff_" groupByColPrefix = "xxff_"
joinClausePreds table oTableName = joinClausePreds table oTableName =
foldBinop "and" foldBinop "and"
. map (\(c1, c2) -> binop "=" (eqi (tableName table) c1) (eqi oTableName c2)) . map (\(c1, c2) -> binop "=" (eqi (tableName table) c1) (eqi oTableName c2))
<$> listToMaybe [ colPairs | ForeignKey tName colPairs <- tableConstraints table <$> listToMaybe [ colPairs | ForeignKey tName colPairs <- tableConstraints table
, tName == oTableName ] , tName == oTableName ]
factTablePopulateSQL :: TablePopulationMode -> Fact -> Reader Env [Text] factTablePopulateSQL :: TablePopulationMode -> Fact -> Reader Env [Text]
factTablePopulateSQL popMode fact = do factTablePopulateSQL popMode fact = do

203
src/Ringo/Types.hs
View File

@ -5,186 +5,25 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
module Ringo.Types where module Ringo.Types
( ColumnName, ColumnType, TableName
, Nullable(..), Column(..), TableConstraint(..), Table(..)
, TimeUnit(..), timeUnitName, timeUnitToSeconds
, Fact(..), FactColumnType(..), FactColumn(..), factSourceColumnName
, pattern DimTimeV
, pattern NoDimIdV
, pattern TenantIdV
, pattern DimIdV
, pattern DimValV
, pattern FactCountV
, pattern FactCountDistinctV
, pattern FactSumV
, pattern FactAverageV
, pattern FactMaxV
, pattern FactMinV
, Settings(..), defSettings
, ValidationError(..), TypeDefaults
, Env, EnvV(..), envView
, TablePopulationMode(..), Dependencies) where
import qualified Data.Text as Text import Ringo.Types.Internal
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.Text (Text)
showColNames :: [Text] -> String
showColNames cols = Text.unpack $ "(" <> Text.intercalate ", " cols <> ")"
type ColumnName = Text
type ColumnType = Text
type TableName = Text
data Nullable = Null | NotNull deriving (Eq, Enum)
instance Show Nullable where
show Null = "NULL"
show NotNull = "NOT NULL"
data Column = Column
{ columnName :: !ColumnName
, columnType :: !ColumnType
, columnNullable :: !Nullable
} deriving (Eq)
instance Show Column where
show Column {..} = "Column "
++ Text.unpack columnName ++ " "
++ Text.unpack columnType ++ " "
++ show columnNullable
data TableConstraint = PrimaryKey !ColumnName
| UniqueKey ![ColumnName]
| ForeignKey !TableName ![(ColumnName, ColumnName)]
deriving (Eq)
instance Show TableConstraint where
show (PrimaryKey col) = "PrimaryKey " ++ Text.unpack col
show (UniqueKey cols) = "UniqueKey " ++ showColNames cols
show (ForeignKey tName colMap) = "ForeignKey " ++ showColNames (map fst colMap) ++ " "
++ Text.unpack tName ++ " " ++ showColNames (map snd colMap)
data Table = Table
{ tableName :: !TableName
, tableColumns :: ![Column]
, tableConstraints :: ![TableConstraint]
} deriving (Eq)
instance Show Table where
show Table {..} =
unlines $ ("Table " ++ Text.unpack tableName) : map show tableColumns ++ map show tableConstraints
data TimeUnit = Second | Minute | Hour | Day | Week
deriving (Eq, Enum, Show, Read)
timeUnitName :: TimeUnit -> Text
timeUnitName = Text.toLower . Text.pack . show
timeUnitToSeconds :: TimeUnit -> Int
timeUnitToSeconds Second = 1
timeUnitToSeconds Minute = 60 * timeUnitToSeconds Second
timeUnitToSeconds Hour = 60 * timeUnitToSeconds Minute
timeUnitToSeconds Day = 24 * timeUnitToSeconds Hour
timeUnitToSeconds Week = 7 * timeUnitToSeconds Day
data Fact = Fact
{ factName :: !TableName
, factTableName :: !TableName
, factTablePersistent :: !Bool
, factParentNames :: ![TableName]
, factColumns :: ![FactColumn]
} deriving (Show)
data FCTNone
data FCTTargetTable
data FCTMaybeSourceColumn
data FCTSourceColumn
data FactColumnType a where
DimTime :: FactColumnType FCTNone
NoDimId :: FactColumnType FCTNone
TenantId :: FactColumnType FCTNone
DimId :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable
DimVal :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable
FactCount :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn
FactCountDistinct :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn
FactSum :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactAverage :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactMax :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactMin :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
deriving instance Show (FactColumnType a)
pattern DimTimeV col <- FactColumn col DimTime
pattern NoDimIdV col <- FactColumn col NoDimId
pattern TenantIdV col <- FactColumn col TenantId
pattern DimIdV col <- FactColumn col DimId {..}
pattern DimValV col <- FactColumn col DimVal {..}
pattern FactCountV col <- FactColumn col FactCount {..}
pattern FactCountDistinctV col <- FactColumn col FactCountDistinct {..}
pattern FactSumV col <- FactColumn col FactSum {..}
pattern FactAverageV col <- FactColumn col FactAverage {..}
pattern FactMaxV col <- FactColumn col FactMax {..}
pattern FactMinV col <- FactColumn col FactMin {..}
data FactColumn = forall a. FactColumn
{ factColTargetColumn :: !ColumnName
, factColType :: FactColumnType a }
deriving instance Show FactColumn
factSourceColumnName :: FactColumn -> Maybe ColumnName
factSourceColumnName FactColumn {..} = case factColType of
DimTime -> Just factColTargetColumn
NoDimId -> Just factColTargetColumn
TenantId -> Just factColTargetColumn
DimId {..} -> Just factColTargetColumn
DimVal {..} -> Just factColTargetColumn
FactCount {..} -> factColMaybeSourceColumn
FactCountDistinct {..} -> factColMaybeSourceColumn
FactSum {..} -> Just factColSourceColumn
FactAverage {..} -> Just factColSourceColumn
FactMax {..} -> Just factColSourceColumn
FactMin {..} -> Just factColSourceColumn
data Settings = Settings
{ settingDimPrefix :: !Text
, settingFactPrefix :: !Text
, settingTimeUnit :: !TimeUnit
, settingAvgCountColumSuffix :: !Text
, settingAvgSumColumnSuffix :: !Text
, settingDimTableIdColumnName :: !Text
, settingDimTableIdColumnType :: !Text
, settingFactCountColumnType :: !Text
, settingFactCountDistinctErrorRate :: !Double
, settingFactInfix :: !Text
, settingDependenciesJSONFileName :: !Text
, settingFactsJSONFileName :: !Text
, settingDimensionJSONFileName :: !Text
, settingForeignKeyIdCoalesceValue :: !Int
, settingTableNameSuffixTemplate :: !Text
} deriving (Eq, Show)
defSettings :: Settings
defSettings = Settings
{ settingDimPrefix = "dim_"
, settingFactPrefix = "fact_"
, settingTimeUnit = Minute
, settingAvgCountColumSuffix = "_count"
, settingAvgSumColumnSuffix = "_sum"
, settingDimTableIdColumnName = "id"
, settingDimTableIdColumnType = "serial"
, settingFactCountColumnType = "integer"
, settingFactCountDistinctErrorRate = 0.05
, settingFactInfix = "_by_"
, settingDependenciesJSONFileName = "dependencies.json"
, settingFactsJSONFileName = "facts.json"
, settingDimensionJSONFileName = "dimensions.json"
, settingForeignKeyIdCoalesceValue = -1
, settingTableNameSuffixTemplate = "{{suff}}"
}
data ValidationError = MissingTable !TableName
| MissingFact !TableName
| MissingColumn !TableName !ColumnName
| MissingTimeColumn !TableName
| MissingNotNullConstraint !TableName !ColumnName
| MissingTypeDefault !Text
deriving (Eq, Show)
type TypeDefaults = Map Text Text
data Env = Env
{ envTables :: ![Table]
, envFacts :: ![Fact]
, envSettings :: !Settings
, envTypeDefaults :: !TypeDefaults
} deriving (Show)
data TablePopulationMode = FullPopulation | IncrementalPopulation deriving (Eq, Show)
type Dependencies = Map TableName [TableName]

198
src/Ringo/Types/Internal.hs Normal file
View File

@ -0,0 +1,198 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
module Ringo.Types.Internal where
import qualified Data.Text as Text
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.Text (Text)
showColNames :: [Text] -> String
showColNames cols = Text.unpack $ "(" <> Text.intercalate ", " cols <> ")"
type ColumnName = Text
type ColumnType = Text
type TableName = Text
data Nullable = Null | NotNull deriving (Eq, Enum)
instance Show Nullable where
show Null = "NULL"
show NotNull = "NOT NULL"
data Column = Column
{ columnName :: !ColumnName
, columnType :: !ColumnType
, columnNullable :: !Nullable
} deriving (Eq)
instance Show Column where
show Column {..} = "Column "
++ Text.unpack columnName ++ " "
++ Text.unpack columnType ++ " "
++ show columnNullable
data TableConstraint = PrimaryKey !ColumnName
| UniqueKey ![ColumnName]
| ForeignKey !TableName ![(ColumnName, ColumnName)]
deriving (Eq)
instance Show TableConstraint where
show (PrimaryKey col) = "PrimaryKey " ++ Text.unpack col
show (UniqueKey cols) = "UniqueKey " ++ showColNames cols
show (ForeignKey tName colMap) = "ForeignKey " ++ showColNames (map fst colMap) ++ " "
++ Text.unpack tName ++ " " ++ showColNames (map snd colMap)
data Table = Table
{ tableName :: !TableName
, tableColumns :: ![Column]
, tableConstraints :: ![TableConstraint]
} deriving (Eq)
instance Show Table where
show Table {..} =
unlines $ ("Table " ++ Text.unpack tableName) : map show tableColumns ++ map show tableConstraints
data TimeUnit = Second | Minute | Hour | Day | Week
deriving (Eq, Enum, Show, Read)
timeUnitName :: TimeUnit -> Text
timeUnitName = Text.toLower . Text.pack . show
timeUnitToSeconds :: TimeUnit -> Int
timeUnitToSeconds Second = 1
timeUnitToSeconds Minute = 60 * timeUnitToSeconds Second
timeUnitToSeconds Hour = 60 * timeUnitToSeconds Minute
timeUnitToSeconds Day = 24 * timeUnitToSeconds Hour
timeUnitToSeconds Week = 7 * timeUnitToSeconds Day
data Fact = Fact
{ factName :: !TableName
, factTableName :: !TableName
, factTablePersistent :: !Bool
, factParentNames :: ![TableName]
, factColumns :: ![FactColumn]
} deriving (Show)
data FCTNone
data FCTTargetTable
data FCTMaybeSourceColumn
data FCTSourceColumn
data FactColumnType a where
DimTime :: FactColumnType FCTNone
NoDimId :: FactColumnType FCTNone
TenantId :: FactColumnType FCTNone
DimId :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable
DimVal :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable
FactCount :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn
FactCountDistinct :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn
FactSum :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactAverage :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactMax :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
FactMin :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn
deriving instance Show (FactColumnType a)
pattern DimTimeV col <- FactColumn col DimTime
pattern NoDimIdV col <- FactColumn col NoDimId
pattern TenantIdV col <- FactColumn col TenantId
pattern DimIdV col <- FactColumn col DimId {..}
pattern DimValV col <- FactColumn col DimVal {..}
pattern FactCountV col <- FactColumn col FactCount {..}
pattern FactCountDistinctV col <- FactColumn col FactCountDistinct {..}
pattern FactSumV col <- FactColumn col FactSum {..}
pattern FactAverageV col <- FactColumn col FactAverage {..}
pattern FactMaxV col <- FactColumn col FactMax {..}
pattern FactMinV col <- FactColumn col FactMin {..}
data FactColumn = forall a. FactColumn
{ factColTargetColumn :: !ColumnName
, factColType :: FactColumnType a }
deriving instance Show FactColumn
factSourceColumnName :: FactColumn -> Maybe ColumnName
factSourceColumnName FactColumn {..} = case factColType of
DimTime -> Just factColTargetColumn
NoDimId -> Just factColTargetColumn
TenantId -> Just factColTargetColumn
DimId {..} -> Just factColTargetColumn
DimVal {..} -> Just factColTargetColumn
FactCount {..} -> factColMaybeSourceColumn
FactCountDistinct {..} -> factColMaybeSourceColumn
FactSum {..} -> Just factColSourceColumn
FactAverage {..} -> Just factColSourceColumn
FactMax {..} -> Just factColSourceColumn
FactMin {..} -> Just factColSourceColumn
data Settings = Settings
{ settingDimPrefix :: !Text
, settingFactPrefix :: !Text
, settingTimeUnit :: !TimeUnit
, settingAvgCountColumSuffix :: !Text
, settingAvgSumColumnSuffix :: !Text
, settingDimTableIdColumnName :: !Text
, settingDimTableIdColumnType :: !Text
, settingFactCountColumnType :: !Text
, settingFactCountDistinctErrorRate :: !Double
, settingFactInfix :: !Text
, settingDependenciesJSONFileName :: !Text
, settingFactsJSONFileName :: !Text
, settingDimensionJSONFileName :: !Text
, settingForeignKeyIdCoalesceValue :: !Int
, settingTableNameSuffixTemplate :: !Text
} deriving (Eq, Show)
defSettings :: Settings
defSettings = Settings
{ settingDimPrefix = "dim_"
, settingFactPrefix = "fact_"
, settingTimeUnit = Minute
, settingAvgCountColumSuffix = "_count"
, settingAvgSumColumnSuffix = "_sum"
, settingDimTableIdColumnName = "id"
, settingDimTableIdColumnType = "serial"
, settingFactCountColumnType = "integer"
, settingFactCountDistinctErrorRate = 0.05
, settingFactInfix = "_by_"
, settingDependenciesJSONFileName = "dependencies.json"
, settingFactsJSONFileName = "facts.json"
, settingDimensionJSONFileName = "dimensions.json"
, settingForeignKeyIdCoalesceValue = -1
, settingTableNameSuffixTemplate = "{{suff}}"
}
data ValidationError = MissingTable !TableName
| DuplicateTable !TableName
| MissingFact !TableName
| DuplicateFact !TableName
| MissingColumn !TableName !ColumnName
| DuplicateColumn !TableName !ColumnName
| MissingTimeColumn !TableName
| MissingNotNullConstraint !TableName !ColumnName
| MissingTypeDefault !Text
deriving (Eq, Show)
type TypeDefaults = Map Text Text
data Env = Env ![Table] ![Fact] !Settings !TypeDefaults
data EnvV = EnvV
{ envTables :: ![Table]
, envFacts :: ![Fact]
, envSettings :: !Settings
, envTypeDefaults :: !TypeDefaults
} deriving (Show)
envView :: Env -> EnvV
envView (Env tables facts settings typeDefaults) = EnvV tables facts settings typeDefaults
data TablePopulationMode = FullPopulation | IncrementalPopulation deriving (Eq, Show)
type Dependencies = Map TableName [TableName]

8
src/Ringo/Utils.hs
View File

@ -34,6 +34,14 @@ second = Arrow.second
(&&&) :: (a -> b) -> (a -> c) -> a -> (b, c) (&&&) :: (a -> b) -> (a -> c) -> a -> (b, c)
(&&&) = (Arrow.&&&) (&&&) = (Arrow.&&&)
(>>>) :: (a -> b) -> (b -> c) -> (a -> c)
(>>>) = (Arrow.>>>)
(>>-) :: a -> (a -> b) -> b
(>>-) v f = f v
infixr 1 >>-
dupe :: a -> (a,a) dupe :: a -> (a,a)
dupe x = (x, x) dupe x = (x, x)

42
src/Ringo/Validator.hs
View File

@ -4,10 +4,7 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
module Ringo.Validator module Ringo.Validator (validateEnv) where
( validateTable
, validateFact
) where
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
@ -17,20 +14,25 @@ import qualified Data.Text as Text
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Reader (Reader, asks) import Control.Monad.Reader (Reader, ask, runReader)
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust)
import Data.List (nub, group, sort)
import Ringo.Extractor.Internal import Ringo.Extractor.Internal
import Ringo.Types import Ringo.Types
import Ringo.Types.Internal
import Ringo.Utils
data RawEnv = RawEnv ![Table] ![Fact] !Settings !TypeDefaults deriving (Show)
checkTableForCol :: Table -> ColumnName -> [ValidationError] checkTableForCol :: Table -> ColumnName -> [ValidationError]
checkTableForCol tab colName = checkTableForCol tab colName =
[ MissingColumn (tableName tab) colName | [ MissingColumn (tableName tab) colName |
not . any ((colName ==) . columnName) . tableColumns $ tab ] not . any ((colName ==) . columnName) . tableColumns $ tab ]
validateTable :: Table -> Reader Env [ValidationError] validateTable :: Table -> Reader RawEnv [ValidationError]
validateTable table = do validateTable table = do
tables <- asks envTables RawEnv tables _ _ _ <- ask
return . concatMap (checkConstraint tables) . tableConstraints $ table return . concatMap (checkConstraint tables) . tableConstraints $ table
where where
checkConstraint _ (PrimaryKey colName) = checkTableForCol table colName checkConstraint _ (PrimaryKey colName) = checkTableForCol table colName
@ -43,10 +45,10 @@ validateTable table = do
checkTableForColRefs tab = concatMap (checkTableForCol tab) checkTableForColRefs tab = concatMap (checkTableForCol tab)
validateFact :: Fact -> Reader Env [ValidationError] validateFact :: Fact -> Reader RawEnv [ValidationError]
validateFact Fact {..} = do validateFact Fact {..} = do
tables <- asks envTables RawEnv tables _ _ typeDefaults <- ask
defaults <- Map.keys <$> asks envTypeDefaults let defaults = Map.keys typeDefaults
case findTable factTableName tables of case findTable factTableName tables of
Nothing -> return [ MissingTable factTableName ] Nothing -> return [ MissingTable factTableName ]
Just table -> do Just table -> do
@ -75,7 +77,7 @@ validateFact Fact {..} = do
return $ tableVs ++ parentVs ++ colVs ++ timeVs ++ notNullVs ++ typeDefaultVs return $ tableVs ++ parentVs ++ colVs ++ timeVs ++ notNullVs ++ typeDefaultVs
where where
checkFactParents fName = do checkFactParents fName = do
facts <- asks envFacts RawEnv _ facts _ _ <- ask
case findFact fName facts of case findFact fName facts of
Nothing -> return [ MissingFact fName ] Nothing -> return [ MissingFact fName ]
Just pFact -> validateFact pFact Just pFact -> validateFact pFact
@ -88,3 +90,21 @@ validateFact Fact {..} = do
checkColumnTable tables FactColumn {..} = case factColType of checkColumnTable tables FactColumn {..} = case factColType of
DimId {factColTargetTable = tName} -> maybe [ MissingTable tName ] (const []) $ findTable tName tables DimId {factColTargetTable = tName} -> maybe [ MissingTable tName ] (const []) $ findTable tName tables
_ -> [] _ -> []
validateEnv :: [Table] -> [Fact] -> Settings -> TypeDefaults -> Either [ValidationError] Env
validateEnv tables facts settings typeDefaults =
flip runReader (RawEnv tables facts settings typeDefaults) $ do
tableVs <- concat <$> mapM validateTable tables
factVs <- concat <$> mapM validateFact facts
let dupTableVs = [ DuplicateTable table | table <- findDups . map tableName $ tables ]
let dupFactVs = [ DuplicateFact fact | fact <- findDups . map factName $ facts ]
let dupColVs = [ DuplicateColumn tableName col
| Table{..} <- tables
, col <- findDups . map columnName $ tableColumns ]
let vs = nub $ tableVs ++ factVs ++ dupTableVs ++ dupFactVs ++ dupColVs
if null vs
then return . Right $ Env tables facts settings typeDefaults
else return . Left $ vs
where
findDups =
sort >>> group >>> map (head &&& length) >>> filter (snd >>> (> 1)) >>> map fst