Resource.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}

module Puppet.Language.Resource
  ( Resource (..),
    HasResource (..),
    RIdentifier (..),
    HasRIdentifier (..),
    LinkInformation (..),
    HasLinkInformation (..),
    LinkType (..),
    Virtuality (..),
    CurContainerDesc (..),
    FinalCatalog,
    EdgeMap,
  )
where

import Data.Aeson
import qualified Data.Aeson.KeyMap as KM
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified GHC.Exts as Exts
import Puppet.Language.Core
import Puppet.Language.Value
import qualified Text.Megaparsec.Pos as Pos
import XPrelude

rel2text :: LinkType -> Text
rel2text RNotify = "notify"
rel2text RRequire = "require"
rel2text RBefore = "before"
rel2text RSubscribe = "subscribe"

data Virtuality
  = -- | Normal resource, that will be included in the catalog.
    Normal
  | -- | Type for virtual resources.
    Virtual
  | -- | Type for exported resources.
    Exported
  | -- | These are resources that are exported AND realized in the catalog.
    ExportedRealized
  deriving (Eq, Show)

data CurContainerDesc
  = -- | Contained at node or root level.
    ContRoot
  | -- | Contained in a class.
    ContClass !Text
  | -- | Contained in a define, along with the position where this define was ... defined
    ContDefine
      !Text
      !Text
      !PPosition
  | -- | Dummy container for imported resources, so that we know we must update the nodename
    ContImported !CurContainerDesc
  | -- | This one is used when finalizing imported resources, and contains the current node name
    ContImport
      !NodeName
      !CurContainerDesc
  deriving (Eq, Generic, Ord, Show)

instance Pretty CurContainerDesc where
  pretty (ContImport p x) = magenta "import" <> braces (ppline p) <> braces (pretty x)
  pretty (ContImported x) = magenta "imported" <> braces (pretty x)
  pretty ContRoot = dullyellow "::"
  pretty (ContClass cname) = dullyellow "class" <+> dullgreen (ppline cname)
  pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname)

-- | Relationship/ordering between resources.
data LinkType
  = -- | Applies a resource after the target resource.
    RRequire
  | -- | Applies a resource before the target resource.
    RBefore
  | -- | Applies a resource before the target resource. The target resource refreshes if the notifying resource changes.
    RNotify
  | -- | Applies a resource after the target resource. The subscribing resource refreshes if the target resource changes.
    RSubscribe
  deriving (Show, Eq, Generic)

instance Hashable LinkType

instance FromJSON LinkType where
  parseJSON (String "require") = return RRequire
  parseJSON (String "notify") = return RNotify
  parseJSON (String "subscribe") = return RSubscribe
  parseJSON (String "before") = return RBefore
  parseJSON _ = panic "invalid linktype"

instance ToJSON LinkType where
  toJSON = String . rel2text

instance Pretty LinkType where
  pretty RNotify = "~>"
  pretty RRequire = "<-"
  pretty RBefore = "->"
  pretty RSubscribe = "<~"

-- | In Puppet, a resource is identified by a name and a type.
data RIdentifier = RIdentifier
  { _itype :: !Text,
    _iname :: !Text
  }
  deriving (Show, Eq, Generic, Ord)

instance Pretty RIdentifier where
  pretty (RIdentifier t n) = pretty (PResourceReference t n)

instance FromJSON RIdentifier where
  parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title"
  parseJSON _ = fail "invalid resource"

instance ToJSON RIdentifier where
  toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)]

instance Hashable RIdentifier

-- | A fully resolved puppet resource that will be used in the 'FinalCatalog'.
data Resource = Resource
  { -- | Resource name.
    _rid :: !RIdentifier,
    -- | All the resource aliases
    _ralias :: !(HashSet Text),
    -- | Resource parameters.
    _rattributes :: !(Container PValue),
    -- | Resource relations.
    _rrelations :: !(HashMap RIdentifier (HashSet LinkType)),
    -- | Resource scope when it was defined, the real container will be the first item
    _rscope :: ![CurContainerDesc],
    -- | Virtuality.
    _rvirtuality :: !Virtuality,
    -- | Tags.
    _rtags :: !(HashSet Text),
    -- | Source code position of the resource definition.
    _rpos :: !PPosition,
    -- | The node were this resource was created, if remote
    _rnode :: !NodeName
  }
  deriving (Eq, Show)

makeClassy ''Resource
makeClassy ''RIdentifier

resourceRelations :: Resource -> [(RIdentifier, LinkType)]
resourceRelations = concatMap expandSet . Map.toList . view rrelations
  where
    expandSet (ri, lts) = [(ri, lt) | lt <- Set.toList lts]

meta :: Resource -> Doc
meta r = showPPos (r ^. rpos) <+> red node <+> green (brackets scp)
  where
    node = ppline (r ^. rnode)
    scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/= ContRoot) . to pretty)

resourceBody :: Resource -> Doc
resourceBody r =
  virtuality <> blue (ppline (r ^. rid . iname)) <> ":" <+> meta r <> line <> containerComma'' insde <> ";"
  where
    virtuality = case r ^. rvirtuality of
      Normal -> mempty
      Virtual -> dullred "@"
      Exported -> dullred "@@"
      ExportedRealized -> dullred "<@@>"
    insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2
    alignlst col = map (first (fill maxalign . col . ppline))
    attriblist1 = Exts.sortWith fst $ Map.toList (r ^. rattributes) ++ aliasdiff
    aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False
    aliasPValue = aliasWithoutTitle & PArray . Vector.fromList . map PString . Set.toList
    aliasdiff
      | Set.null aliasWithoutTitle = []
      | otherwise = [("alias", aliasPValue)]
    attriblist2 = map totext (resourceRelations r)
    totext (RIdentifier t n, lt) = (rel2text lt, PResourceReference t n)
    maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)
    maxalign' [] = 0
    maxalign' x = maximum . map (Text.length . fst) $ x

instance Pretty Resource where
  prettyList lst =
    let grouped = Map.toList $ Map.fromListWith (++) [(r ^. rid . itype, [r]) | r <- lst] :: [(Text, [Resource])]
        sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid . iname)))) grouped)
        showGroup :: (Text, [Resource]) -> Doc
        showGroup (rt, res) = dullyellow (ppline rt) <+> lbrace <> line <> indent 2 (vcat (map resourceBody res)) <> line <> rbrace
     in vcat (map showGroup sorted)
  pretty r = dullyellow (ppline (r ^. rid . itype)) <+> lbrace <> line <> indent 2 (resourceBody r) <> line <> rbrace

instance ToJSON Resource where
  toJSON r =
    object
      [ ("type", String $ r ^. rid . itype),
        ("title", String $ r ^. rid . iname),
        ("aliases", toJSON $ r ^. ralias),
        ("exported", Bool $ r ^. rvirtuality == Exported),
        ("tags", toJSON $ r ^. rtags),
        ("parameters", Object $ KM.fromHashMapText (fmap toJSON (r ^. rattributes) `Map.union` relations)),
        ("sourceline", r ^. rpos . _1 . _sourceLine . to (toJSON . Pos.unPos)),
        ("sourcefile", r ^. rpos . _1 . _sourceName . to toJSON)
      ]
    where
      relations = r ^. rrelations & Map.fromListWith (Vector.++) . concatMap changeRelations . Map.toList & fmap toValue
      toValue v
        | Vector.length v == 1 = Vector.head v
        | otherwise = Array v
      changeRelations :: (RIdentifier, HashSet LinkType) -> [(Text, Vector Value)]
      changeRelations (k, v) = do
        c <- Set.toList v
        return (rel2text c, Vector.singleton (String (rid2text k)))
      rid2text :: RIdentifier -> Text
      rid2text (RIdentifier t n) = capitalizeRT t `Text.append` "[" `Text.append` capn `Text.append` "]"
        where
          capn =
            if t == "classe"
              then capitalizeRT n
              else n

instance FromJSON Resource where
  parseJSON (Object v) = do
    isExported <- v .: "exported"
    let virtuality =
          if isExported
            then Exported
            else Normal
        getResourceIdentifier :: PValue -> Maybe RIdentifier
        getResourceIdentifier (PString x) =
          let (restype, brckts) = Text.breakOn "[" x
              rna
                | Text.null brckts = Nothing
                | Text.null restype = Nothing
                | Text.last brckts == ']' = Just (Text.tail (Text.init brckts))
                | otherwise = Nothing
           in case rna of
                Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname))
                _ -> Nothing
        getResourceIdentifier _ = Nothing
        -- TODO : properly handle metaparameters
        separate :: (Container PValue, HashMap RIdentifier (HashSet LinkType)) -> Text -> PValue -> (Container PValue, HashMap RIdentifier (HashSet LinkType))
        separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of
          (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True)
          _ -> (curAttribs & at k ?~ val, curRelations)
    (attribs, relations) <- Map.foldlWithKey' separate (mempty, mempty) <$> v .: "parameters"
    contimport <- v .:? "certname" .!= "unknown"
    Resource
      <$> (RIdentifier <$> fmap Text.toLower (v .: "type") <*> v .: "title")
      <*> v .:? "aliases" .!= mempty
      <*> pure attribs
      <*> pure relations
      <*> pure [ContImport contimport ContRoot]
      <*> pure virtuality
      <*> v .: "tags"
      <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1)
      <*> pure contimport
  parseJSON _ = mempty

type FinalCatalog = HashMap RIdentifier Resource

-- | Relationship/ordering information between two resources (used in the 'EdgeMap').
data LinkInformation = LinkInformation
  { _linksrc :: !RIdentifier,
    _linkdst :: !RIdentifier,
    _linkType :: !LinkType,
    _linkPos :: !PPosition
  }
  deriving (Show)

makeClassy ''LinkInformation

type EdgeMap = HashMap RIdentifier [LinkInformation]