Database.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Baserock.Schema.V9.Database
-- Copyright  : (c) Daniel Firth 2018
-- License    : BSD3
-- Maintainer : locallycompact@gmail.com
-- Stability  : experimental
--
-- This file defines the V9 Baserock Yaml Schema in Haskell
--
-----------------------------------------------------------------------------
module Baserock.Schema.V9.Database
  ( Definitions(..)
  , loadSystem
  , loadMorphInto
  , defSystems
  , defStrata
  , defChunks
  , expandAliases
  , contractAliases
  )
where

import           Algebra.Graph
import           Baserock.Schema.V9.Data
import           Control.Monad.State
import           Data.Function.Flippers
import           Data.Typeable
import           Lens.Micro.Platform
import           RIO
import           RIO.List
import qualified RIO.ByteString                as BS
import qualified RIO.HashMap                   as HM
import qualified RIO.Text                      as Text
import qualified RIO.Text.Partial              as TextP

data Definitions = Definitions {
  _defSystems :: HashMap Text System,
  _defStrata  :: HashMap Text Stratum,
  _defChunks  :: HashMap Text ChunkInstructions
} deriving (Eq, Show)

instance Semigroup Definitions where
  Definitions x1 x2 x3 <> Definitions y1 y2 y3 = Definitions (x1 <> y1) (x2 <> y2) (x3 <> y3)

instance Monoid Definitions where
  mempty = Definitions mempty mempty mempty

$(makeLenses ''Definitions)

loadMorphInto
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , FromJSON b
     , ToPrettyYaml b
     , Typeable b
     , MonadThrow m
     , MonadState s m
     )
  => RIO.ASetter s s (HashMap Text b) (HashMap Text b)
  -> FilePath
  -> m b
loadMorphInto f x = do
  (t :: b) <- decodeFileThrowLogged x
  f %= HM.insert (Text.pack x) t
  return t

expandSystem =
  mapM (loadMorphInto defStrata . Text.unpack . _stratumIncludeMorph) . _strata

expandStratum =
  mapM (loadMorphInto defChunks . Text.unpack) . mapMaybe _chunkMorph . _chunks

loadSystem
  :: ( MonadReader env m
     , MonadIO m
     , MonadThrow m
     , MonadState Definitions m
     , HasLogFunc env
     )
  => FilePath
  -> m System
loadSystem f = do
  s <- loadMorphInto defSystems f
  (expandSystem >=> mapM expandStratum) s
  return s

expandAliases =
  over (chunks . traverse . repo) . flip (HM.foldrWithKey TextP.replace)

contractAliases = over (chunks . traverse . repo)
  . flip (HM.foldlWithKey' (flip3 TextP.replace))