Types.hs

{-# LANGUAGE AutoDeriveTypeable     #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TemplateHaskell        #-}

module Puppet.Interpreter.Types (
  -- * Record & lenses
   HasResource(..)
 , Resource(Resource)
 , HasResDefaults(..)
 , ResDefaults(ResDefaults)
 , HasLinkInformation(..)
 , LinkInformation(LinkInformation)
 , HasRIdentifier(..)
 , HieraQueryLayers(HieraQueryLayers)
 , HasHieraQueryLayers(..)
 , RIdentifier(RIdentifier)
 , HasScopeInformation(..)
 , ScopeInformation(ScopeInformation)
 , ScopeEnteringContext(..)
 , HasResourceModifier(..)
 , ResourceModifier(ResourceModifier)
 , HasIoMethods(..)
 , IoMethods(IoMethods)
 , HasCurContainer(..)
 , CurContainer(CurContainer)
 , HasNativeTypeMethods(..)
 , NativeTypeMethods(NativeTypeMethods)
 , NodeInfo(NodeInfo)
 , HasNodeInfo(..)
 , FactInfo(FactInfo)
 , HasFactInfo(..)
 , HasWireCatalog(..)
  -- ** Operational instructions
 , InterpreterInstr(..)
 , HasInterpreterReader(..)
 , InterpreterReader(InterpreterReader)
 , HasInterpreterState(..)
 , InterpreterState(InterpreterState)
  -- * Sum types
  -- ** PValue
 , PValue(..)
 , _PType
 , _PBoolean
 , _PString
 , _PResourceReference
 , _PArray
 , _PHash
 , _PNumber
 , _PUndef
  -- ** Misc
 , DataType(..)
 , CurContainerDesc(..)
 , ResourceCollectorType(..)
 , RSearchExpression(..)
 , Query(..)
 , ModifierType(..)
 , NodeField
 , Strictness(..)
 , HieraQueryType(..)
 , WireCatalog(..)
 , TopLevelType(..)
 , FactField(..)
 , ResRefOverride(..)
 , ResourceField(..)
 , OverrideType(..)
 , ClassIncludeType(..)
  -- ** PuppetDB
 , PuppetEdge(PuppetEdge)
 , PuppetDBAPI(..)
  -- * newtype & synonym
 , PrettyError(..)
 , InterpreterMonad
 , InterpreterWriter
 , FinalCatalog
 , NativeTypeValidate
 , NodeName
 , Container
 , HieraQueryFunc
 , Scope
 , Facts
 , EdgeMap
  -- * Classes
 , MonadThrowPos(..)
  -- * Definitions
 , metaparameters
 , showPos
) where

import           Puppet.Prelude hiding (show)

import           Control.Lens                hiding (Strict)
import           Control.Monad.Operational
import           Control.Monad.State.Strict
import           Control.Monad.Writer.Class
import           Data.Aeson                  as A
import           Data.Aeson.TH
import           Data.Aeson.Lens
import qualified Data.Either.Strict          as S
import qualified Data.HashMap.Strict         as HM
import qualified Data.HashSet                as HS
import qualified Data.Maybe.Strict           as S
import           Data.String                 (IsString (..))
import qualified Data.Text                   as Text
import qualified Data.List                   as List
import           Data.Time.Clock
import qualified Data.Traversable            as TR
import qualified Data.Vector                 as V
import           Foreign.Ruby.Helpers
import           GHC.Show                    (Show (..))
import           GHC.Stack
import qualified System.Log.Logger           as Log
import           Text.Megaparsec.Pos
import           Web.HttpApiData             (ToHttpApiData (..))

import           Puppet.Parser.PrettyPrinter
import           Puppet.Parser.Types
import           Puppet.Paths
import           Puppet.PP                   hiding (rational)

metaparameters :: HS.HashSet Text
metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]

type NodeName = Text
type Container = HM.HashMap Text
type Scope = Text
type Facts = Container PValue

newtype PrettyError = PrettyError { getError :: Doc }

instance Show PrettyError where
    show = show . getError

instance Monoid PrettyError where
    mempty = PrettyError mempty
    mappend a b = PrettyError $ getError a <+> getError b

instance IsString PrettyError where
    fromString = PrettyError . string

instance Exception PrettyError

instance Pretty PrettyError where
  pretty = getError

data PValue = PBoolean !Bool
            | PUndef
            | PString !Text -- integers and doubles are internally serialized as strings by puppet
            | PResourceReference !Text !Text
            | PArray !(V.Vector PValue)
            | PHash !(Container PValue)
            | PNumber !Scientific
            | PType DataType
            deriving (Eq, Show)

instance IsString PValue where
    fromString = PString . Text.pack

instance AsNumber PValue where
    _Number = prism num2PValue toNumber
        where
            num2PValue :: Scientific -> PValue
            num2PValue = PNumber
            toNumber :: PValue -> Either PValue Scientific
            toNumber (PNumber n) = Right n
            toNumber p@(PString x) = case text2Scientific x of
                                         Just o -> Right o
                                         _      -> Left p
            toNumber p = Left p

-- | The different kind of hiera queries.
data HieraQueryType
    = QFirst   -- ^ standard hiera query
    | QUnique -- ^ hiera_array
    | QHash  -- ^ hiera_hash
    | QDeep
    { _knockoutPrefix :: Maybe Text
    , _sortMerged     :: Bool
    , _mergeHashArray :: Bool
    } deriving (Show)

-- | The type of the Hiera API function associated to given hierarchy.
type HieraQueryFunc m = Container Text -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with ::)
                     -> Text -- ^ The query
                     -> HieraQueryType
                     -> m (S.Either PrettyError (Maybe PValue))

-- | All available queries including the global and module layer
-- The environment layer is not implemented
data HieraQueryLayers m
  = HieraQueryLayers
  {
    _globalLayer :: HieraQueryFunc m
  , _moduleLayer :: Container (HieraQueryFunc m)
  }


-- | The intepreter can run in two modes : a strict mode (recommended), and
-- a permissive mode.
data Strictness = Strict | Permissive
                deriving (Show, Eq)

instance FromJSON Strictness where
  parseJSON (Bool True)  = pure Strict
  parseJSON (Bool False) = pure Permissive
  parseJSON _            = mzero

data RSearchExpression = REqualitySearch !Text !PValue
                       | RNonEqualitySearch !Text !PValue
                       | RAndSearch !RSearchExpression !RSearchExpression
                       | ROrSearch !RSearchExpression !RSearchExpression
                       | RAlwaysTrue
                       deriving (Show, Eq)

-- | Puppet has two main ways to declare classes: include-like and resource-like
-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like puppet reference>
data ClassIncludeType = ClassIncludeLike  -- ^ using the include or contain function
                      | ClassResourceLike -- ^ resource like declaration
                      deriving (Eq)

-- | This type is used to differenciate the distinct top level types that are exposed by the DSL.
data TopLevelType
    -- |This is for node entries.
    = TopNode
    -- |This is for defines.
    | TopDefine
    -- |This is for classes.
    | TopClass
    deriving (Generic,Eq)

instance Hashable TopLevelType

-- | From the evaluation of Resource Default Declaration
data ResDefaults = ResDefaults
    { _resDefType     :: !Text
    , _resDefSrcScope :: !Text
    , _resDefValues   :: !(Container PValue)
    , _resDefPos      :: !PPosition
    }

-- | From the evaluation of Resource Override Declaration
data ResRefOverride = ResRefOverride
    { _rrid     :: !RIdentifier
    , _rrparams :: !(Container PValue)
    , _rrpos    :: !PPosition
    } deriving (Eq)

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

data ScopeEnteringContext = SENormal
                          | SEChild  !Text -- ^ We enter the scope as the child of another class
                          | SEParent !Text -- ^ We enter the scope as the parent of another class

-- TODO related to Scope: explain ...
data CurContainer = CurContainer
    { _cctype :: !CurContainerDesc
    , _cctags :: !(HS.HashSet Text)
    } deriving (Eq)

data ScopeInformation = ScopeInformation
    { _scopeVariables   :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))
    , _scopeResDefaults :: !(Container ResDefaults)
    , _scopeExtraTags   :: !(HS.HashSet Text)
    , _scopeContainer   :: !CurContainer
    , _scopeOverrides   :: !(HM.HashMap RIdentifier ResRefOverride)
    , _scopeParent      :: !(S.Maybe Text)
    }

data InterpreterState = InterpreterState
    { _scopes             :: !(Container ScopeInformation)
    , _loadedClasses      :: !(Container (Pair ClassIncludeType PPosition))
    , _definedResources   :: !(HM.HashMap RIdentifier Resource)
    , _curScope           :: ![CurContainerDesc]
    , _curPos             :: !PPosition
    , _nestedDeclarations :: !(HM.HashMap (TopLevelType,Text) Statement)
    , _extraRelations     :: ![LinkInformation]
    , _resMod             :: ![ResourceModifier]
    }

data InterpreterReader m = InterpreterReader
    { _readerNativeTypes     :: !(Container NativeTypeMethods)
    , _readerGetStatement    :: TopLevelType -> Text -> m (S.Either PrettyError Statement)
    , _readerGetTemplate     :: Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)
    , _readerPdbApi          :: PuppetDBAPI m
    , _readerExternalFunc    :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs
    , _readerNodename        :: Text
    , _readerHieraQuery      :: HieraQueryLayers m
    , _readerIoMethods       :: IoMethods m
    , _readerIgnoredModules  :: HS.HashSet Text
    , _readerExternalModules :: HS.HashSet Text
    , _readerIsStrict        :: Bool
    , _readerPuppetPaths     :: PuppetDirPaths
    , _readerRebaseFile      :: Maybe FilePath
    }

data IoMethods m = IoMethods
    { _ioGetCurrentCallStack :: m [String]
    , _ioReadFile            :: [Text] -> m (Either String Text)
    , _ioTraceEvent          :: String -> m ()
    }

data InterpreterInstr a where
    -- Utility for using what's in "InterpreterReader"
    GetNativeTypes      :: InterpreterInstr (Container NativeTypeMethods)
    GetStatement        :: TopLevelType -> Text -> InterpreterInstr Statement
    ComputeTemplate     :: Either Text Text -> InterpreterState -> InterpreterInstr Text
    ExternalFunction    :: Text -> [PValue] -> InterpreterInstr PValue
    GetNodeName         :: InterpreterInstr Text
    HieraQuery          :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)
    GetCurrentCallStack :: InterpreterInstr [String]
    IsIgnoredModule     :: Text -> InterpreterInstr Bool
    IsExternalModule    :: Text -> InterpreterInstr Bool
    IsStrict            :: InterpreterInstr Bool
    PuppetPaths         :: InterpreterInstr PuppetDirPaths
    RebaseFile          :: InterpreterInstr (Maybe FilePath)
    -- error
    ErrorThrow          :: PrettyError -> InterpreterInstr a
    ErrorCatch          :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a
    -- writer
    WriterTell          :: InterpreterWriter -> InterpreterInstr ()
    WriterPass          :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a
    WriterListen        :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)
    -- puppetdb wrappers, see 'PuppetDBAPI' for details
    PDBInformation      :: InterpreterInstr Doc
    PDBReplaceCatalog   :: WireCatalog -> InterpreterInstr ()
    PDBReplaceFacts     :: [(NodeName, Facts)] -> InterpreterInstr ()
    PDBDeactivateNode   :: NodeName -> InterpreterInstr ()
    PDBGetFacts         :: Query FactField -> InterpreterInstr [FactInfo]
    PDBGetResources     :: Query ResourceField -> InterpreterInstr [Resource]
    PDBGetNodes         :: Query NodeField -> InterpreterInstr [NodeInfo]
    PDBCommitDB         :: InterpreterInstr ()
    PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource]
    -- Reading the first file that can be read in a list
    ReadFile            :: [Text] -> InterpreterInstr Text
    -- Tracing events
    TraceEvent          :: String -> InterpreterInstr ()

-- | The main monad
type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)

instance MonadError PrettyError InterpreterMonad where
    throwError = singleton . ErrorThrow
    catchError a c = singleton (ErrorCatch a c)

-- | Log
type InterpreterWriter = [Pair Log.Priority Doc]
instance MonadWriter InterpreterWriter InterpreterMonad where
    tell = singleton . WriterTell
    pass = singleton . WriterPass
    listen = singleton . WriterListen

data RIdentifier = RIdentifier
    { _itype :: !Text
    , _iname :: !Text
    } deriving (Show,Eq,Generic,Ord)

instance Hashable RIdentifier

data ResourceModifier = ResourceModifier
    { _rmResType      :: !Text
    , _rmModifierType :: !ModifierType
    , _rmType         :: !ResourceCollectorType
    , _rmSearch       :: !RSearchExpression
    , _rmMutation     :: !(Resource -> InterpreterMonad Resource)
    , _rmDeclaration  :: !PPosition
    }

instance Show ResourceModifier where
  show (ResourceModifier rt mt ct se _ p) = List.unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]

data ModifierType = ModifierCollector -- ^ For collectors, optional resources
                  | ModifierMustMatch -- ^ For stuff like realize
                  deriving (Show, Eq)

data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error
                  | Replace -- ^ Can silently replace
                  | CantReplace -- ^ Silently ignore errors
                  | AppendAttribute -- ^ Can append values
                  deriving (Show, Eq)

data ResourceCollectorType = RealizeVirtual
                           | RealizeCollected
                           | DontRealize
                           deriving (Show, Eq)

data LinkInformation = LinkInformation
    { _linksrc  :: !RIdentifier
    , _linkdst  :: !RIdentifier
    , _linkType :: !LinkType
    , _linkPos  :: !PPosition
    } deriving Show

type EdgeMap = HM.HashMap RIdentifier [LinkInformation]

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

type NativeTypeValidate = Resource -> Either PrettyError Resource

-- | Attributes (and providers) of a puppet resource type bundled with validation rules
data NativeTypeMethods = NativeTypeMethods
    { _puppetValidate :: NativeTypeValidate
    , _puppetFields   :: HS.HashSet Text
    }

type FinalCatalog = HM.HashMap RIdentifier Resource

-- | Used to represent a relationship between two resources within the wired format (json).
-- See <http://docs.puppetlabs.com/puppetdb/2.3/api/wire_format/catalog_format_v5.html#data-type-edge>
data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show

-- | Wire format
--
-- See <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html puppet reference>.
data WireCatalog = WireCatalog
    { _wireCatalogNodename        :: !NodeName
    , _wireCatalogVersion         :: !Text
    , _wireCatalogEdges           :: !(V.Vector PuppetEdge)
    , _wireCatalogResources       :: !(V.Vector Resource)
    , _wireCatalogTransactionUUID :: !Text
    } deriving Show

data FactInfo = FactInfo
    { _factInfoNodename :: !NodeName
    , _factInfoName     :: !Text
    , _factInfoVal      :: !PValue
    }

data NodeInfo = NodeInfo
    { _nodeInfoName        :: !NodeName
    , _nodeInfoDeactivated :: !Bool
    , _nodeInfoCatalogT    :: !(S.Maybe UTCTime)
    , _nodeInfoFactsT      :: !(S.Maybe UTCTime)
    , _nodeInfoReportT     :: !(S.Maybe UTCTime)
    }

data PuppetDBAPI m = PuppetDBAPI
    { pdbInformation     :: m Doc
    , replaceCatalog     :: WireCatalog         -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>
    , replaceFacts       :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>
    , deactivateNode     :: NodeName            -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>
    , getFacts           :: Query FactField     -> ExceptT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>
    , getResources       :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>
    , getNodes           :: Query NodeField     -> ExceptT PrettyError m [NodeInfo]
    , commitDB           ::                        ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.
    , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]
    }

-- | Pretty straightforward way to define the various PuppetDB queries
data Query a = QEqual a Text
             | QG a Integer
             | QL a Integer
             | QGE a Integer
             | QLE a Integer
             | QMatch Text Text
             | QAnd [Query a]
             | QOr [Query a]
             | QNot (Query a)
             | QEmpty

-- | Fields for the fact endpoint
data FactField = FName
               | FValue
               | FCertname

-- | Fields for the node endpoint
data NodeField = NName | NFact Text

-- | Fields for the resource endpoint
data ResourceField = RTag
                   | RCertname
                   | RParameter Text
                   | RType
                   | RTitle
                   | RExported
                   | RFile
                   | RLine

data DataType
    = DTType
    | DTString (Maybe Int) (Maybe Int)
    | DTInteger (Maybe Int) (Maybe Int)
    | DTFloat (Maybe Double) (Maybe Double)
    | DTBoolean
    | DTArray DataType Int (Maybe Int)
    | DTHash DataType DataType Int (Maybe Int)
    | DTUndef
    | DTScalar
    | DTData
    | DTOptional DataType
    | NotUndef
    | DTVariant (NonEmpty DataType)
    | DTPattern (NonEmpty CompRegex)
    | DTEnum (NonEmpty Text)
    | DTAny
    | DTCollection
    deriving (Show, Eq)

makeClassy ''RIdentifier
makeClassy ''ResRefOverride
makeClassy ''LinkInformation
makeClassy ''ResDefaults
makeClassy ''ResourceModifier
makeClassy ''NativeTypeMethods
makeClassy ''ScopeInformation
makeClassy ''Resource
makeClassy ''InterpreterState
makeClassy ''InterpreterReader
makeClassy ''IoMethods
makeClassy ''CurContainer
makeClassy ''NodeInfo
makeClassy ''WireCatalog
makeClassy ''FactInfo
makeClassy ''HieraQueryLayers
makePrisms ''PValue

$(deriveJSON defaultOptions ''DataType)

class Monad m => MonadThrowPos m where
    throwPosError :: Doc -> m a

-- Useful for mocking for instance in a REPL
instance MonadThrowPos (Either Doc) where
  throwPosError = Left

class MonadStack m where
  getCurrentCallStack :: m [String]

instance MonadStack InterpreterMonad where
    getCurrentCallStack = singleton GetCurrentCallStack

instance MonadThrowPos InterpreterMonad where
    throwPosError s = do
        p <- use (curPos . _1)
        stack <- getCurrentCallStack
        let dstack = if null stack
                         then line
                         else mempty </> string (renderStack stack)
        throwError (PrettyError (s <+> "at" <+> showPos p <> dstack))

instance ToRuby PValue where
    toRuby = toRuby . toJSON
instance FromRuby PValue where
    fromRuby = fmap chk . fromRuby
        where
            chk (Left x) = Left x
            chk (Right x) = case fromJSON x of
                                Error rr    -> Left rr

                                Success suc -> Right suc

-- JSON INSTANCES --

instance FromJSON PValue where
    parseJSON Null       = return PUndef
    parseJSON (Number n) = return $ PNumber n
    parseJSON (String s) = return (PString s)
    parseJSON (Bool b)   = return (PBoolean b)
    parseJSON (Array v)  = fmap PArray (V.mapM parseJSON v)
    parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o)

instance ToJSON PValue where
    toJSON (PType t)                = toJSON t
    toJSON (PBoolean b)             = Bool b
    toJSON PUndef                   = Null
    toJSON (PString s)              = String s
    toJSON (PResourceReference _ _) = Null -- TODO
    toJSON (PArray r)               = Array (V.map toJSON r)
    toJSON (PHash x)                = Object (HM.map toJSON x)
    toJSON (PNumber n)              = Number n

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 ( HM.map toJSON (r ^. rattributes) `HM.union` relations ))
                      , ("sourceline", r ^. rpos . _1 . lSourceLine . to (toJSON . unPos))
                      , ("sourcefile", r ^. rpos . _1 . lSourceName . to toJSON)
                      ]
        where
            relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue
            toValue v | V.length v == 1 = V.head v
                      | otherwise = Array v
            changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)]
            changeRelations (k,v) = do
                c <- HS.toList v
                return (rel2text c, V.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, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.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) <- HM.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

instance ToJSON a => ToJSON (Query a) where
    toJSON (QOr qs)          = toJSON ("or" : map toJSON qs)
    toJSON (QAnd qs)         = toJSON ("and" : map toJSON qs)
    toJSON (QNot q)          = toJSON [ "not" , toJSON q ]
    toJSON (QEqual flds val) = toJSON [ "=",  toJSON flds, toJSON val ]
    toJSON (QMatch flds val) = toJSON [ "~",  toJSON flds, toJSON val ]
    toJSON (QL     flds val) = toJSON [ "<",  toJSON flds, toJSON val ]
    toJSON (QG     flds val) = toJSON [ ">",  toJSON flds, toJSON val ]
    toJSON (QLE    flds val) = toJSON [ "<=", toJSON flds, toJSON val ]
    toJSON (QGE    flds val) = toJSON [ ">=", toJSON flds, toJSON val ]
    toJSON  QEmpty           = Null

instance ToJSON a => ToHttpApiData (Query a) where
    toHeader = Control.Lens.view strict . encode
    toUrlPiece = decodeUtf8 . toHeader

instance FromJSON a => FromJSON (Query a) where
    parseJSON Null = pure QEmpty
    parseJSON (Array elems) = case V.toList elems of
      ("or":xs)          -> QOr    <$> mapM parseJSON xs
      ("and":xs)         -> QAnd   <$> mapM parseJSON xs
      ["not",x]          -> QNot   <$> parseJSON x
      [ "=", flds, val ] -> QEqual <$> parseJSON flds    <*> parseJSON val
      [ "~", flds, val ] -> QEqual <$> parseJSON flds    <*> parseJSON val
      [ ">", flds, val ] -> QG     <$> parseJSON flds    <*> parseJSON val
      [ "<", flds, val ] -> QL     <$> parseJSON flds    <*> parseJSON val
      [">=", flds, val ] -> QGE    <$> parseJSON flds    <*> parseJSON val
      ["<=", flds, val ] -> QLE    <$> parseJSON flds    <*> parseJSON val
      x                  -> fail ("unknown query" ++ show x)
    parseJSON _ = fail "Expected an array"

instance ToJSON FactField where
    toJSON FName     = "name"
    toJSON FValue    = "value"
    toJSON FCertname = "certname"

instance FromJSON FactField where
    parseJSON "name"     = pure FName
    parseJSON "value"    = pure FValue
    parseJSON "certname" = pure FCertname
    parseJSON _          = fail "Can't parse fact field"

instance ToJSON NodeField where
    toJSON NName     = "name"
    toJSON (NFact t) = toJSON [ "fact", t ]

instance FromJSON NodeField where
    parseJSON (Array xs) = case V.toList xs of
                               ["fact", x] -> NFact <$> parseJSON x
                               _           -> fail "Invalid field syntax"
    parseJSON (String "name") = pure NName
    parseJSON _ = fail "invalid field"

instance ToJSON ResourceField where
    toJSON RTag           = "tag"
    toJSON RCertname      = "certname"
    toJSON (RParameter t) = toJSON ["parameter", t]
    toJSON RType          = "type"
    toJSON RTitle         = "title"
    toJSON RExported      = "exported"
    toJSON RFile          = "file"
    toJSON RLine          = "line"

instance FromJSON ResourceField where
    parseJSON (Array xs) = case V.toList xs of
                               ["parameter", x] -> RParameter <$> parseJSON x
                               _ -> fail "Invalid field syntax"
    parseJSON (String "tag"     ) = pure RTag
    parseJSON (String "certname") = pure RCertname
    parseJSON (String "type"    ) = pure RType
    parseJSON (String "title"   ) = pure RTitle
    parseJSON (String "exported") = pure RExported
    parseJSON (String "file"    ) = pure RFile
    parseJSON (String "line"    ) = pure RLine
    parseJSON _ = fail "invalid field"

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 FromJSON PuppetEdge where
    parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"
    parseJSON _ = fail "invalid puppet edge"

instance ToJSON PuppetEdge where
    toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]

instance FromJSON WireCatalog where
    parseJSON (Object d) = d .: "data" >>= \case
        (Object v) -> WireCatalog
                <$> v .: "name"
                <*> v .: "version"
                <*> v .: "edges"
                <*> v .: "resources"
                <*> v .: "transaction-uuid"
        _ -> fail "Data is not an object"
    parseJSON _ = fail "invalid wire catalog"

instance ToJSON WireCatalog where
    toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)]
        where d = [ ("name", String n)
                  , ("version", String v)
                  , ("edges", toJSON e)
                  , ("resources", toJSON r)
                  , ("transaction-uuid", String t)
                  ]

instance ToJSON FactInfo where
    toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)]

instance FromJSON FactInfo where
    parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"
    parseJSON _ = fail "invalid fact info"

instance ToJSON NodeInfo where
    toJSON p = object [ ("name"             , toJSON (p ^. nodeInfoName))
                      , ("deactivated"      , toJSON (p ^. nodeInfoDeactivated))
                      , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT))
                      , ("facts_timestamp"  , toJSON (p ^. nodeInfoFactsT))
                      , ("report_timestamp" , toJSON (p ^. nodeInfoReportT))
                      ]

instance FromJSON NodeInfo where
    parseJSON (Object v) = NodeInfo <$> v .:  "name"
                                     <*> v .:? "deactivated" .!= False
                                     <*> v .:  "catalog_timestamp"
                                     <*> v .:  "facts_timestamp"
                                     <*> v .:  "report_timestamp"
    parseJSON _ = fail "invalide node info"