Refactor query type (#19)

src/cli/lib/EasyBI/Cli.hs

@@ -10,7 +10,7 @@ module EasyBI.Cli
   ) where
 
 import Control.Exception             (bracket)
-import Control.Lens                  (at, use, (.=))
+import Control.Lens                  (at, preview, review, use, (.=))
 import Control.Monad                 (void, when)
 import Control.Monad.Except          (MonadError (..), liftEither, runExceptT)
 import Control.Monad.IO.Class        (MonadIO (..))
@@ -35,6 +35,7 @@ import EasyBI.Sql.Catalog            (Catalog, TypedQueryExpr (..), tables,
 import EasyBI.Sql.Class              (render, runInferType)
 import EasyBI.Sql.Dialect            qualified as Dialect
 import EasyBI.Sql.Effects.Types      (generalise)
+import EasyBI.Sql.Select             (_Select)
 import EasyBI.Sql.Types              (SqlType (STDateTime),
                                       SqlVar (AnIdentifier), TypeEnv (..),
                                       rowFromSchema)
@@ -102,12 +103,12 @@ loadSchema SchemaConfig{scSqlFile, scTimestampColumns} = do
       logInfoS ("Create table " <> show names)
       let tp = rowFromSchema elements typeOverrides
       tables . at (AnIdentifier names) .= Just tp
-    CreateView _ names _ queryExpr _ -> do
+    CreateView _ names _ (preview _Select -> Just queryExpr) _ -> do
       logInfoS ("Create view " <> show names)
       tyEnv <- TypeEnv <$> use tables
-      case runInferType (tyEnv <> defaultTypeEnv) queryExpr of
+      case runInferType (tyEnv <> defaultTypeEnv) (review _Select queryExpr) of
         Left err -> do
-          logWarnS $ "Type inference failed for '" <> render Dialect.sqlite queryExpr <> "'"
+          logWarnS $ "Type inference failed for '" <> render Dialect.sqlite (review _Select queryExpr) <> "'"
           logWarn err
         Right (_, generalise -> tp, _) -> do
           views . at names .= Just (TypedQueryExpr queryExpr tp)

src/server/easy-bi-server.cabal

@@ -92,6 +92,7 @@ test-suite easy-bi-server-test
     easy-bi-server,
     easy-bi-sql,
     easy-bi-vis,
+    lens,
     text,
     containers,
     bytestring,

src/server/lib/EasyBI/Server.hs

@@ -12,20 +12,21 @@ module EasyBI.Server
 import Control.Monad               (when)
 import Control.Monad.Except        (ExceptT, MonadError (..), runExceptT)
 import Control.Monad.IO.Class      (MonadIO (..))
+import Data.Map                    (Map)
 import Data.Map                    qualified as Map
 import Data.Proxy                  (Proxy (..))
 import Data.String                 (IsString (..))
 import EasyBI.Server.API           (API)
-import EasyBI.Server.Cube          (Cube)
-import EasyBI.Server.Eval          (DbConnectionPool, applyFieldModifiers,
+import EasyBI.Server.Cube          (Cube, hashCube)
+import EasyBI.Server.Eval          (APIQuery, DbConnectionPool, buildQuery,
                                     evalQuery)
 import EasyBI.Server.State         (ServerState (..))
 import EasyBI.Server.State         qualified as State
-import EasyBI.Server.Visualisation (FieldInMode, InOut (..), Visualisation)
+import EasyBI.Server.Visualisation (SqlFieldName, Visualisation)
 import EasyBI.Server.Visualisation qualified as V
 import EasyBI.Sql.Catalog          (TypedQueryExpr (..))
 import EasyBI.Util.JSON            (WrappedObject (..))
-import EasyBI.Util.NiceHash        (Hashed, NiceHash, WithHash, withHash)
+import EasyBI.Util.NiceHash        (Hashed, NiceHash, Plain, WithHash, withHash)
 import EasyBI.Vis.Types            (Selections)
 import Network.Wai.Handler.Warp    qualified as Warp
 import Servant.API                 ((:<|>) (..))
@@ -47,28 +48,30 @@ data ServerConfig =
 easyBIServer :: DbConnectionPool -> ServerState -> Server API
 easyBIServer pool state =
   health
-    :<|> cubes state
-    :<|> cube state
-    :<|> vis
+    :<|> pure ((fmap (fmap (hashCube . fst))) (cubes state))
+    :<|> fmap (hashCube . fst) . cube state
+    :<|> vis state
     :<|> eval pool state
   where
     health = pure ()
-    cubes ServerState{ssCubes} = pure (Map.toList ssCubes)
+    cubes ServerState{ssCubes} = Map.toList ssCubes
 
-vis :: (MonadError ServerError m) => NiceHash TypedQueryExpr -> Selections [] (FieldInMode In) -> m [WithHash (Visualisation (NiceHash TypedQueryExpr))]
-vis hsh selections = do
-  let result = V.visualisations hsh selections
+vis :: (MonadError ServerError m) => ServerState -> NiceHash (Cube Hashed) -> Selections [] SqlFieldName -> m [WithHash (Visualisation (NiceHash (Cube Hashed)))]
+vis state hsh selections = do
+  (_, fields) <- cube state hsh
+  sel' <- traverse (lookupFromMaybe (flip Map.lookup fields)) selections
+  let result = V.visualisations hsh sel'
   when (null result) $ Debug.traceM $ "vis: no results!"
   pure (withHash <$> result)
 
-cube :: (MonadError ServerError m) => ServerState -> NiceHash (Cube Hashed) -> m (Cube Hashed)
+cube :: (MonadError ServerError m) => ServerState -> NiceHash (Cube Hashed) -> m (Cube Plain, Map SqlFieldName V.Field)
 cube state = lookupFromMaybe (State.findCube state)
 
-lkp :: (MonadError ServerError m) => ServerState -> NiceHash TypedQueryExpr -> m TypedQueryExpr
+lkp :: (MonadError ServerError m) => ServerState -> NiceHash (Cube Hashed) -> m TypedQueryExpr
 lkp state = lookupFromMaybe (State.findQuery state)
 
-eval :: (MonadFail m, MonadIO m, MonadError ServerError m) => DbConnectionPool -> ServerState -> NiceHash TypedQueryExpr -> [FieldInMode In] -> m [WrappedObject]
-eval pool state hsh fields = lkp state hsh >>= failOnError . applyFieldModifiers fields . teQuery >>= liftIO . evalQuery pool
+eval :: (MonadFail m, MonadIO m, MonadError ServerError m) => DbConnectionPool -> ServerState -> NiceHash (Cube Hashed) -> APIQuery -> m [WrappedObject]
+eval pool state hsh apiQuery = lkp state hsh >>= failOnError . buildQuery apiQuery . teQuery >>= liftIO . evalQuery pool
 
 lookupFromMaybe :: (MonadError ServerError m, Show k) => (k -> Maybe v) -> k -> m v
 lookupFromMaybe f k = case f k of

src/server/lib/EasyBI/Server/API.hs

@@ -5,8 +5,8 @@ module EasyBI.Server.API
   ) where
 
 import EasyBI.Server.Cube          (Cube)
-import EasyBI.Server.Visualisation (FieldInMode, InOut (..), Visualisation)
-import EasyBI.Sql.Catalog          (TypedQueryExpr)
+import EasyBI.Server.Eval          (APIQuery)
+import EasyBI.Server.Visualisation (SqlFieldName, Visualisation)
 import EasyBI.Util.JSON            (WrappedObject)
 import EasyBI.Util.NiceHash        (Hashed, NiceHash, WithHash)
 import EasyBI.Vis.Types            (Selections)
@@ -18,6 +18,6 @@ type API =
     "health" :> Get '[JSON] ()
     :<|> "cubes" :> Get '[JSON] [WithHash (Cube Hashed)]
     :<|> "cubes" :> Capture "cube"  (NiceHash (Cube Hashed))  :> Get '[JSON] (Cube Hashed)
-    :<|> "vis"   :> Capture "query" (NiceHash TypedQueryExpr) :> ReqBody '[JSON] (Selections [] (FieldInMode In)) :> Post '[JSON] [WithHash (Visualisation (NiceHash TypedQueryExpr))]
-    :<|> "eval"  :> Capture "query" (NiceHash TypedQueryExpr) :> ReqBody '[JSON] [FieldInMode In] :> Post '[JSON] [WrappedObject]
+    :<|> "vis"   :> Capture "query" (NiceHash (Cube Hashed)) :> ReqBody '[JSON] (Selections [] SqlFieldName) :> Post '[JSON] [WithHash (Visualisation (NiceHash (Cube Hashed)))]
+    :<|> "eval"  :> Capture "query" (NiceHash (Cube Hashed)) :> ReqBody '[JSON] APIQuery :> Post '[JSON] [WrappedObject]
   )

src/server/lib/EasyBI/Server/Config.hs

@@ -8,9 +8,8 @@
 module EasyBI.Server.Config
   ( ConfigError (..)
   , DataSourceConfig (..)
+  , DimensionGroupConfig (..)
   , FieldConfig (..)
-  , FieldGroupConfig (..)
-  , configFieldGroups
   , cubesFromCatalog
   ) where
 
@@ -20,12 +19,15 @@ import Data.Aeson                    qualified as JSON
 import Data.Bifunctor                (Bifunctor (..))
 import Data.Map                      (Map)
 import Data.Map                      qualified as Map
+import Data.Maybe                    (fromMaybe)
 import Data.Text                     (Text)
 import Data.Text                     qualified as Text
-import EasyBI.Server.Cube            (Cube (..), FieldGroup (..))
-import EasyBI.Server.Visualisation   (FieldInMode (..), InOut (..),
+import EasyBI.Server.Cube            (Cube (..), CubeName (..),
+                                      DimensionGroup (..))
+import EasyBI.Server.Visualisation   (Dimension, Field (..), Measure (..),
                                       SortOrder (..), SqlFieldName (..),
-                                      _displayName, _sortOrder, fields)
+                                      _dimensionDisplayName,
+                                      _measureDisplayName, fields, sqlFieldName)
 import EasyBI.Sql.Catalog            (Catalog (..), TypedQueryExpr (..))
 import EasyBI.Sql.Effects.Types      (RowType (..), Tp (..), TyScheme (..))
 import EasyBI.Util.JSON              (customJsonOptions)
@@ -48,71 +50,95 @@ instance ToJSON FieldConfig where
 instance FromJSON FieldConfig where
   parseJSON = JSON.genericParseJSON (customJsonOptions 2)
 
-data FieldGroupConfig =
-  FieldGroupConfig
-    { fgcName         :: Text
-    , fgcDescription  :: Maybe Text
-    , fgcPrimaryField :: FieldConfig
-    , fgcOtherFields  :: [FieldConfig]
+data DimensionGroupConfig =
+  DimensionGroupConfig
+    { dgcName         :: Text
+    , dgcDescription  :: Maybe Text
+    , dgcPrimaryField :: FieldConfig
+    , dgcOtherFields  :: [FieldConfig]
     }
     deriving stock (Eq, Show, Generic)
 
-instance ToJSON FieldGroupConfig where
+instance ToJSON DimensionGroupConfig where
   toJSON = JSON.genericToJSON (customJsonOptions 3)
   toEncoding = JSON.genericToEncoding (customJsonOptions 3)
 
-instance FromJSON FieldGroupConfig where
+instance FromJSON DimensionGroupConfig where
   parseJSON = JSON.genericParseJSON (customJsonOptions 3)
 
-newtype DataSourceConfig =
-  DataSourceConfig
-    { dscFieldGroups :: Map Text [FieldGroupConfig]
+data CubeConfig =
+  CubeConfig
+    { ccDimensions  :: [DimensionGroupConfig]
+    , ccMeasures    :: [FieldConfig]
+    , ccDisplayName :: Maybe String
     }
+    deriving stock (Eq, Show, Generic)
+
+instance ToJSON CubeConfig where
+  toJSON = JSON.genericToJSON (customJsonOptions 2)
+  toEncoding = JSON.genericToEncoding (customJsonOptions 2)
+
+instance FromJSON CubeConfig where
+  parseJSON = JSON.genericParseJSON (customJsonOptions 2)
+
+newtype DataSourceConfig =
+  DataSourceConfig{ dscCubes :: Map CubeName CubeConfig}
     deriving stock (Eq, Show)
     deriving newtype (ToJSON, FromJSON)
 
 data ConfigError =
   FieldNotFound Text
   -- ^ The field was not found in the data source
-  | DataSourceNotFound Text
+  | DataSourceNotFound CubeName
   -- ^ The data source with this name was not found
   | UnexpectedType Text
   -- ^ The view was found in the database, but it has an unexpected type
   deriving stock (Eq, Show, Generic)
   deriving anyclass (ToJSON, FromJSON)
 
--- | Build a list of @FieldGroup@s, throwing an error if the config specified a field
+-- | Build a list of @DimensionGroup@s, throwing an error if the config specified a field
 --   that does not exist in the input list.
-configFieldGroups :: [FieldInMode Out] -> [FieldGroupConfig] -> Either ConfigError [FieldGroup]
-configFieldGroups allFields dscFieldGroups = do
-  let fieldsByName = Map.fromList $ fmap (\fld -> (sqlFieldName fld, fld)) allFields
-      fieldByName FieldConfig{fcFieldName, fcDisplayName, fcDefaultSortOrder} = case Map.lookup (SqlFieldName $ Text.unpack fcFieldName) fieldsByName of
+configDimensionGroups :: Map SqlFieldName Field -> [DimensionGroupConfig] -> Either ConfigError [DimensionGroup]
+configDimensionGroups fieldsByName dscDimensionGroups = do
+  let dimensionByName :: FieldConfig -> Either ConfigError Dimension
+      dimensionByName FieldConfig{fcFieldName, fcDisplayName, fcDefaultSortOrder} = case Map.lookup (SqlFieldName $ Text.unpack fcFieldName) fieldsByName of
         Nothing              -> Left (FieldNotFound fcFieldName)
-        Just x@FieldInMode{} -> Right $
-          L.set _displayName fcDisplayName
-          . maybe id (\o -> L.set _sortOrder o) fcDefaultSortOrder
-          $ x
-      groupFromConfig FieldGroupConfig{fgcName, fgcDescription, fgcPrimaryField, fgcOtherFields} =
-        FieldGroup fgcName fgcDescription
-          <$> fieldByName fgcPrimaryField
-          <*> traverse fieldByName fgcOtherFields
-  traverse groupFromConfig dscFieldGroups
+        Just (ADimension d)  -> Right $ L.set _dimensionDisplayName fcDisplayName d
+        Just AMeasure{}      -> Left (UnexpectedType fcFieldName)
+      groupFromConfig DimensionGroupConfig{dgcName, dgcDescription, dgcPrimaryField, dgcOtherFields} =
+        DimensionGroup dgcName dgcDescription
+          <$> dimensionByName dgcPrimaryField
+          <*> traverse dimensionByName dgcOtherFields
+  traverse groupFromConfig dscDimensionGroups
+
+configMeasure :: Map SqlFieldName Field -> [FieldConfig] -> Either ConfigError [Measure]
+configMeasure fieldsByName fieldConfigs =
+  let dimensionByName :: FieldConfig -> Either ConfigError Measure
+      dimensionByName FieldConfig{fcFieldName, fcDisplayName, fcDefaultSortOrder} = case Map.lookup (SqlFieldName $ Text.unpack fcFieldName) fieldsByName of
+        Nothing           -> Left (FieldNotFound fcFieldName)
+        Just ADimension{} -> Left (UnexpectedType fcFieldName)
+        Just (AMeasure m) -> Right $ L.set _measureDisplayName fcDisplayName m
+  in traverse dimensionByName fieldConfigs
 
 -- | Build a list of cubes from a database catalog and a data source config.
 cubesFromCatalog :: Catalog -> DataSourceConfig -> Either ConfigError [Cube Plain]
-cubesFromCatalog Catalog{_views} DataSourceConfig{dscFieldGroups} = do
-  let availableViews = Map.fromList $ fmap (first mkTitle) $ Map.toList _views
+cubesFromCatalog Catalog{_views} DataSourceConfig{dscCubes} = do
+  let availableViews = Map.fromList $ fmap (first (CubeName . Text.unpack . mkTitle)) $ Map.toList _views
       mkTitle [] = "<no title>"
       mkTitle xs =
         let get (Name _ n) = Text.pack n
         in Text.intercalate "." (get <$> xs)
-      mkCube viewName fieldGroups = do
-        typedQueryExpr <- maybe (Left $ DataSourceNotFound viewName) Right (Map.lookup viewName availableViews)
+      mkCube :: CubeName -> CubeConfig -> Either ConfigError (Cube Plain)
+      mkCube cubeName CubeConfig{ccDimensions, ccDisplayName, ccMeasures} = do
+        let CubeName viewName = cubeName
+        typedQueryExpr <- maybe (Left $ DataSourceNotFound cubeName) Right (Map.lookup cubeName availableViews)
         fields_ <- case teType typedQueryExpr of { TyScheme _ (TpRow (RowType _ mp)) -> Right (fields mp); x -> Left (UnexpectedType $ Text.pack $ show x)}
+        let fieldsByName = Map.fromList $ fmap (\fld -> (sqlFieldName fld, fld)) fields_
         Cube
           <$> pure (hPlain typedQueryExpr)
-          <*> pure (Text.unpack viewName)
-          <*> pure (Text.unpack viewName) -- FIXME:_ Display name in config
-          <*> fmap (fmap withHash) (configFieldGroups fields_ fieldGroups)
+          <*> pure cubeName
+          <*> pure (fromMaybe viewName ccDisplayName)
+          <*> fmap (fmap withHash) (configDimensionGroups fieldsByName ccDimensions)
+          <*> fmap (fmap withHash) (configMeasure fieldsByName ccMeasures)
 
-  traverse (uncurry mkCube) (Map.toList dscFieldGroups)
+  traverse (uncurry mkCube) (Map.toList dscCubes)

src/server/lib/EasyBI/Server/Cube.hs

@@ -11,36 +11,51 @@
 {-# LANGUAGE UndecidableInstances #-}
 module EasyBI.Server.Cube
   ( Cube (..)
-  , FieldGroup (..)
+  , CubeName (..)
+  , DimensionGroup (..)
+  , fields
   , hashCube
   , queryExpr
-  , singletonFieldGroup
+  , singletonDimensionGroup
   ) where
 
 import Codec.Serialise             (Serialise (..))
-import Data.Aeson                  (FromJSON (..), ToJSON (..))
+import Data.Aeson                  (FromJSON (..), FromJSONKey, ToJSON (..),
+                                    ToJSONKey)
 import Data.Aeson                  qualified as JSON
+import Data.Map                    (Map)
+import Data.Map                    qualified as Map
 import Data.Text                   (Text)
 import Data.Text                   qualified as Text
-import EasyBI.Server.Visualisation (FieldInMode (..), InOut (Out),
-                                    SqlFieldName (..))
+import EasyBI.Server.Visualisation (Dimension (..), Field (..), Measure,
+                                    SqlFieldName (..), Visualisation,
+                                    sqlFieldName)
 import EasyBI.Sql.Catalog          (TypedQueryExpr)
 import EasyBI.Util.JSON            (customJsonOptions)
 import EasyBI.Util.NiceHash        (HasNiceHash (..), Hashable (..), Hashed,
-                                    NiceHashable (..), Plain, WithHash, hHash)
+                                    NiceHash, NiceHashable (..), Plain,
+                                    WithHash, hHash)
 import GHC.Generics                (Generic)
 
+newtype CubeName = CubeName String
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, ToJSONKey, FromJSON, FromJSONKey, Serialise)
+
 {-| A cube is a big SELECT statement with all dimensions
 and aggregations
 -}
 data Cube h =
   Cube
     { cQuery       :: Hashable TypedQueryExpr h
-    , cName        :: String
+    , cName        :: CubeName
     , cDisplayName :: String
-    , cFields      :: [WithHash FieldGroup]
+    , cDimensions  :: [WithHash DimensionGroup]
+    , cMeasures    :: [WithHash Measure]
     } deriving stock Generic
 
+instance HasNiceHash (Visualisation (NiceHash (Cube Hashed))) where
+  type Name (Visualisation (NiceHash (Cube Hashed))) = "vis"
+
 instance ToJSON (Cube Plain) where
   toJSON = JSON.genericToJSON (customJsonOptions 1)
   toEncoding = JSON.genericToEncoding (customJsonOptions 1)
@@ -67,23 +82,37 @@ queryExpr Cube{cQuery} = let HPlain a = cQuery in a
 instance HasNiceHash (Cube Hashed) where
   type Name (Cube Hashed) = "cube"
 
-data FieldGroup =
-  FieldGroup
-    { fgName         :: Text
-    , fgDescription  :: Maybe Text
-    , fgPrimaryField :: FieldInMode Out
-    , fgOtherFields  :: [FieldInMode Out]
+data DimensionGroup =
+  DimensionGroup
+    { dgName             :: Text
+    , dgDescription      :: Maybe Text
+    , dgPrimaryDimension :: Dimension
+    , dgOtherDimensions  :: [Dimension]
     } deriving stock (Eq, Generic)
       deriving anyclass (Serialise)
-      deriving HasNiceHash via (NiceHashable "field_group" FieldGroup)
+      deriving HasNiceHash via (NiceHashable "dimension_group" DimensionGroup)
 
-instance ToJSON FieldGroup where
+instance ToJSON DimensionGroup where
   toJSON = JSON.genericToJSON (customJsonOptions 2)
   toEncoding = JSON.genericToEncoding (customJsonOptions 2)
 
-instance FromJSON FieldGroup where
+instance FromJSON DimensionGroup where
   parseJSON = JSON.genericParseJSON (customJsonOptions 2)
 
 -- | A field group with a single field
-singletonFieldGroup :: FieldInMode Out -> FieldGroup
-singletonFieldGroup f = FieldGroup (Text.pack $ getSqlFieldName $ sqlFieldName f) Nothing f []
+singletonDimensionGroup :: Dimension -> DimensionGroup
+singletonDimensionGroup f =
+  DimensionGroup
+    (Text.pack $ getSqlFieldName $ dimensionSqlFieldName f)
+    Nothing
+    f
+    []
+
+-- | The fields that have been defined for the cube
+fields :: Cube h -> Map SqlFieldName Field
+fields Cube{cDimensions, cMeasures} =
+  let withKey f@Dimension{dimensionSqlFieldName} = (dimensionSqlFieldName, ADimension f)
+      mkMap DimensionGroup{dgPrimaryDimension, dgOtherDimensions} =
+        Map.fromList $ fmap withKey (dgPrimaryDimension : dgOtherDimensions)
+      mkField f = (sqlFieldName f, f)
+  in Map.unions $ (Map.fromList $ fmap (mkField . AMeasure . snd) cMeasures) : (mkMap . snd <$> cDimensions)