V9.hs

{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DuplicateRecordFields     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}

module Baserock.Schema.V9 where

import Algebra.Graph
import Baserock.Schema.Utils
import Control.Arrow
import Control.Error.Safe
import Control.Error.Util
import Control.Monad
import Control.Monad.Except
import qualified Data.ByteString as BS
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Profunctor
import Data.Text (Text, unpack)
import Data.Yaml
import Data.Yaml.Pretty
import GHC.Generics

--- ChunkInstructions ("chunk.morph")

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, Generic, Show)

instance FromJSON ChunkInstructions where
  parseJSON = withObject "ChunkInstructions" $ \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"   .!= []

chunkInstructionsFieldOrder :: [Text] =
      ["name", "kind", "build-system"]
   <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x]
   <> ["rpm-metadata"]
chunkInstructionsFieldCmp = listElemCmp chunkInstructionsFieldOrder

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)

encodePrettyChunkInstructions = encodePretty $ setConfCompare chunkInstructionsFieldCmp defConfig 

-- 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, Generic, Show)

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

chunkFieldOrder :: [Text] = ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"]
chunkFieldCmp = listElemCmp chunkFieldOrder

instance ToJSON Chunk where
  toJSON x = object $ ["name" .= chunkName x, "repo" .= repo x, "ref" .= ref x, "sha" .= sha x]
                    <> possibly "morph" (chunkMorph x)
                    <> possibly "build-mode" (buildMode x)
                    <> possibly "build-system" (chunkBuildSystem x)
                    <> possibly "build-depends" (chunkBDs x)

encodePrettyChunk = encodePretty $ setConfCompare chunkFieldCmp defConfig

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

instance FromJSON StratumBD where
  parseJSON = withObject "StratumBD" $ \v -> StratumBD
    <$> v .: "morph"

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

data Stratum = Stratum {
  stratumName        :: Text,
  stratumDescription :: Maybe Text,
  stratumBDs         :: [StratumBD],
  chunks             :: [Chunk]
} deriving (Eq, Generic, Show)

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

stratumFieldOrder :: [Text] = chunkFieldOrder ++ ["kind", "chunks"]
stratumFieldCmp = listElemCmp stratumFieldOrder

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)

encodePrettyStratum = encodePretty $ setConfCompare stratumFieldCmp defConfig

-- System ("system.morph")

data StratumInclude = StratumInclude {
  stratumIncludeName  :: Text,
  stratumIncludeMorph :: Text
} deriving (Eq, Generic, Show)

instance FromJSON StratumInclude where
  parseJSON = withObject "StratumInclude" $ \v -> StratumInclude
    <$> v .: "name"
    <*> v .: "morph"

stratumIncludeFieldOrder :: [Text] = ["name", "morph"]
stratumIncludeFieldCmp = listElemCmp stratumIncludeFieldOrder

instance ToJSON StratumInclude where
  toJSON x = object ["name" .= stratumIncludeName x, "morph" .= stratumIncludeMorph x]

encodePrettyStratumInclude = encodePretty $ setConfCompare stratumIncludeFieldCmp defConfig

data System = System {
  systemName              :: Text,
  systemDescription       :: Maybe Text,
  arch                    :: Text,
  strata                  :: [StratumInclude],
  configurationExtensions :: [Text]
} deriving (Eq, Generic, Show)

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

systemFieldOrder :: [Text] = stratumIncludeFieldOrder ++ ["kind", "description", "arch", "strata", "configuration-extensions"]
systemFieldCmp = listElemCmp systemFieldOrder

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)

encodePrettySystem = encodePretty $ setConfCompare systemFieldCmp defConfig

--- 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 f (x, as) = do
  BS.writeFile f (encodePrettyStratum x)
  forM_ as $ \(i, j) -> BS.writeFile i (encodePrettyChunkInstructions j)

encodeSystemAST f (x, as) = do
  BS.writeFile f (encodePrettySystem x)
  forM_ as $ \(i, j) -> encodeStratumAST i j

-- 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.