V9.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

-----------------------------------------------------------------------------
-- |
-- Module     : Baserock.Schema.V9
-- 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 (

  -- * Schema
  ChunkInstructions(..),
  Chunk(..),
  StratumBD(..),
  StratumInclude(..),
  Stratum(..),
  System(..),

  -- * Lenses
  chunkInstructionsName,
  buildSystem,
  preConfigureCommands,
  configureCommands,
  postConfigureCommands,
  preBuildCommands,
  buildCommands,
  postBuildCommands,
  preInstallCommands,
  installCommands,
  postInstallCommands,

  chunkName,
  chunkMorph,
  repo,
  ref,
  sha,
  buildMode,
  chunkBuildSystem,

  stratumBDMorph,

  stratumName,
  stratumDescription,
  stratumBDs,
  chunks,

  stratumIncludeName,
  stratumIncludeMorph,

  systemName,
  systemDescription,
  arch,
  strata,
  configurationExtensions,

  -- * ASTs

  StratumAST,
  SystemAST,

  -- * Codecs
  
  encodeStratumAST,
  decodeStratumAST,
  encodeSystemAST,
  decodeSystemAST,

  -- * Misc
  
  encodeFilePretty,
  ToPrettyYaml(..)

) where

import Algebra.Graph
import Control.Arrow
import Control.Applicative
import Control.Error.Safe
import Control.Error.Util
import Control.Lens.TH
import Control.Monad
import Control.Monad.Except
import qualified Data.ByteString as BS
import Data.Ord
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text, unpack)
import Data.Yaml
import Data.Yaml.Pretty

listElemCmp as x y = fromMaybe LT $ liftA2 compare (elemIndex x as) (elemIndex y as)

possibly f v = if v == mzero then mzero else [f .= v]

class ToJSON a => ToPrettyYaml a where
  fieldOrder :: a -> [Text]

  fieldCmp :: a -> (Text -> Text -> Ordering)
  fieldCmp = listElemCmp . fieldOrder

  toPrettyYaml :: a -> BS.ByteString
  toPrettyYaml x = encodePretty (setConfCompare (fieldCmp x) defConfig) x

encodeFilePretty :: ToPrettyYaml a => FilePath -> a -> IO ()
encodeFilePretty f x = BS.writeFile f (toPrettyYaml x)

-- * ChunkInstructions

data ChunkInstructions = ChunkInstructions {
  _chunkInstructionsName :: Text,
  _buildSystem           :: Text,
  _preConfigureCommands  :: [Text],
  _configureCommands     :: [Text],
  _postConfigureCommands :: [Text],
  _preBuildCommands      :: [Text],
  _buildCommands         :: [Text],
  _postBuildCommands     :: [Text],
  _preInstallCommands    :: [Text],
  _installCommands       :: [Text],
  _postInstallCommands   :: [Text]
} deriving (Eq, Show)

$(makeLenses ''ChunkInstructions)

instance FromJSON ChunkInstructions where
  parseJSON (Object v) = ChunkInstructions
    <$> v .:  "name"
    <*> v .:? "build-system"            .!= "manual"
    <*> v .:? "pre-configure-commands"  .!= []
    <*> v .:? "configure-commands"      .!= []
    <*> v .:? "post-configure-commands" .!= []
    <*> v .:? "pre-build-commands"      .!= []
    <*> v .:? "build-commands"          .!= []
    <*> v .:? "post-build-commands"     .!= []
    <*> v .:? "pre-install-commands"    .!= []
    <*> v .:? "install-commands"        .!= []
    <*> v .:? "post-install-commands"   .!= []

instance ToJSON ChunkInstructions where
   toJSON x =
      object $ ["name" .= _chunkInstructionsName x, "kind" .= ("chunk" :: Text), "build-system" .= _buildSystem x]
            <> possibly "pre-configure-commands"  (_preConfigureCommands x)
            <> possibly "configure-commands"      (_configureCommands x)
            <> possibly "post-configure-commands" (_postConfigureCommands x)
            <> possibly "pre-build-commands"      (_preBuildCommands x)
            <> possibly "build-commands"          (_buildCommands x)
            <> possibly "post-build-commands"     (_postBuildCommands x)
            <> possibly "pre-install-commands"    (_preInstallCommands x)
            <> possibly "install-commands"        (_installCommands x)
            <> possibly "post-install-commands"   (_postInstallCommands x)

instance ToPrettyYaml ChunkInstructions where
  fieldOrder = const $ ["name", "kind", "build-system"]
   <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x]
   <> ["rpm-metadata"]


-- Stratum ("stratum.morph")

data Chunk = Chunk {
  _chunkName        :: Text,
  _chunkMorph       :: Maybe Text,
  _repo             :: Text,
  _ref              :: Text,
  _sha              :: Maybe Text,
  _buildMode        :: Text,
  _chunkBuildSystem :: Text,
  _chunkBDs         :: [Text]
} deriving (Eq, Show)

$(makeLenses ''Chunk)

instance FromJSON Chunk where
  parseJSON (Object v) = Chunk
    <$> v .:  "name"
    <*> v .:? "morph"
    <*> v .:  "repo"
    <*> v .:  "ref"
    <*> v .:? "sha"
    <*> v .:? "build-mode"    .!= "staging"
    <*> v .:? "build-system"  .!= "manual"
    <*> v .:? "build-depends" .!= []

instance ToJSON Chunk where
  toJSON x = object $ ["name" .= _chunkName x, "repo" .= _repo x, "ref" .= _ref x, "sha" .= _sha x]
                    <> possibly "morph" (_chunkMorph x)
                    <> (if _buildMode x == "staging" then mempty else ["buildmode" .= _buildMode x])
                    <> (if _chunkBuildSystem x == "manual" then mempty else ["build-system" .= _chunkBuildSystem x])
                    <> possibly "build-depends" (_chunkBDs x)

instance ToPrettyYaml Chunk where
  fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"]

data StratumBD = StratumBD {
  _stratumBDMorph :: Text
} deriving (Eq, Show)

$(makeLenses ''StratumBD)

instance FromJSON StratumBD where
  parseJSON (Object v) = StratumBD
    <$> v .: "morph"

instance ToJSON StratumBD where
  toJSON x = object ["morph" .= _stratumBDMorph x]

instance ToPrettyYaml StratumBD where
  fieldOrder = const ["morph"]

data Stratum = Stratum {
  _stratumName        :: Text,
  _stratumDescription :: Maybe Text,
  _stratumBDs         :: [StratumBD],
  _chunks             :: [Chunk]
} deriving (Eq, Show)

$(makeLenses ''Stratum)

instance FromJSON Stratum where
  parseJSON (Object v) = Stratum
    <$> v .:  "name"
    <*> v .:? "description"
    <*> v .:? "build-depends" .!= []
    <*> v .:  "chunks"

instance ToJSON Stratum where
  toJSON x = object $ ["name" .= _stratumName x, "kind" .= ("stratum" :: Text), "chunks" .= _chunks x]
                   <> possibly "description" (_stratumDescription x)
                   <> possibly "build-depends" (_stratumBDs x)

instance ToPrettyYaml Stratum where
  fieldOrder = const ["name", "kind", "description", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"]

-- System ("system.morph")

data StratumInclude = StratumInclude {
  _stratumIncludeName  :: Text,
  _stratumIncludeMorph :: Text
} deriving (Eq, Show)

$(makeLenses ''StratumInclude)

instance FromJSON StratumInclude where
  parseJSON (Object v) = StratumInclude
    <$> v .: "name"
    <*> v .: "morph"

instance ToJSON StratumInclude where
  toJSON x = object ["name" .= _stratumIncludeName x, "morph" .= _stratumIncludeMorph x]

instance ToPrettyYaml StratumInclude where
  fieldOrder = const ["name", "morph"]

data System = System {
  _systemName              :: Text,
  _systemDescription       :: Maybe Text,
  _arch                    :: Text,
  _strata                  :: [StratumInclude],
  _configurationExtensions :: [Text]
} deriving (Eq, Show)

$(makeLenses ''System)

instance FromJSON System where
  parseJSON (Object v) = System
    <$> v .:  "name"
    <*> v .:? "description"
    <*> v .:  "arch"
    <*> v .:  "strata"
    <*> v .:  "configuration-extensions"

instance ToJSON System where
  toJSON x = object $ ["name" .= _systemName x, "kind" .= ("system" :: Text), "arch" .= _arch x, "strata" .= _strata x, "configuration-extensions" .= _configurationExtensions x]
                    <> possibly "description" (_systemDescription x)

instance ToPrettyYaml System where
  fieldOrder = const $ ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"]

--- Decoders

type StratumAST = (Stratum, [(FilePath, ChunkInstructions)])
type SystemAST  = (System, [(FilePath, StratumAST)])

splitK a b = runKleisli $ Kleisli a &&& Kleisli b

decodeASTWith selector decoder x = runExceptT $ withExceptT (\e -> AesonException ("Error in " ++ x ++ ": " ++ show e)) $ do
  (ExceptT . decodeFileEither $ x) >>= splitK return (mapM (splitK return decoder) . selector)

decodeStratumAST :: FilePath -> IO (Either ParseException StratumAST)
decodeStratumAST = decodeASTWith (fmap unpack . mapMaybe _chunkMorph . _chunks) (ExceptT . decodeFileEither)

decodeSystemAST :: FilePath -> IO (Either ParseException SystemAST)
decodeSystemAST  = decodeASTWith (fmap (unpack . _stratumIncludeMorph) . _strata) (ExceptT . decodeStratumAST)

-- Encoders

encodeStratumAST :: FilePath -> StratumAST -> IO ()
encodeStratumAST f (x, as) = do
  encodeFilePretty f x
  forM_ as $ uncurry encodeFilePretty

encodeSystemAST :: FilePath -> SystemAST -> IO ()
encodeSystemAST f (x, as) = do
  encodeFilePretty f x
  forM_ as $ uncurry encodeStratumAST

-- Utility

data BaserockGraphException = NoExistChunkBD Chunk Text
                            | NoExistStratumBD Stratum Text deriving Show

stratumGraph :: Stratum -> Either BaserockGraphException (Graph Chunk)
stratumGraph s = right edges $ sequence $ runExceptT $ do
  x <- ExceptT (fmap Right $ _chunks s)
  y <- ExceptT (fmap Right $ _chunkBDs x)
  z <- failWith (NoExistChunkBD x y) $ find ((== y) . _chunkName) (_chunks s)
  return (z, x)

-- V9 is non-regular in that graphs of Strata can be derived purely from the Stratum itself
-- where as graphs of Systems require a SystemAST. We aim to correct this.