Graph.hs

module Graph where

import Data.Function (on)
import Data.List (deleteBy)

data Edge v id_ payload = Edge (v, v) id_ payload
  deriving Show

data Graph v id_ payload = Graph [v] [Edge v id_ payload]
  deriving Show

empty :: Graph v id_ payload
empty = Graph [] []

insert :: Eq v => Edge v id_ payload -> Graph v id_ payload -> Graph v id_ payload
insert e@(Edge (src, dst) _ _) (Graph vs es) =
  let vs'  = if src `elem` vs  then vs  else src : vs
      vs'' = if dst `elem` vs' then vs' else dst : vs'
   in Graph vs'' (e : es)

delete :: Eq id_ => Edge v id_ payload -> Graph v id_ payload -> Graph v id_ payload
delete e (Graph vs es) = Graph vs $ deleteBy ((==) `on` edgeID) e es

edgeID :: Edge v id_ payload -> id_
edgeID (Edge _ id_ _) = id_

Lib.hs

{-# LANGUAGE StandaloneDeriving #-}
module Lib where

import Control.Comonad.Store
import Control.Comonad.Traced

type Graph = ()
type MySystem guid host = Store (Traced [Sysmon guid host] Graph) Graph

type Sysmon' = Sysmon Int String

type MySystem2 = TracedT [Sysmon'] (Store [Sysmon']) Graph
type MySystem3 = StoreT [Sysmon'] (Traced [Sysmon']) Graph
type MySystem4 = Traced [Sysmon'] Graph

data Sysmon guid host
  = ProcessCreated
    { me     :: Process guid  -- ^ GUID of the created process
    , parent :: Process guid  -- ^ GUID of the spawning process
    , hostID :: host          -- ^ The host the process was created on
    , cdmRowID :: guid
    }
  | ProcessTerminated
    { me :: Process guid  -- ^ GUID of the terminated process
    , cdmRowID :: guid
    }

  -- | NetworkConnection
  --   { process         :: Process guid  -- ^ GUID of the process that spawned the connection
  --   , destinationHost :: host          -- ^ Desination of the created connection
  --   , cdmRowID :: guid
  --   }

  | Error
  deriving (Eq, Show)
deriving instance (Ord guid, Ord host) => Ord (Sysmon guid host)

data Node guid host
  = ProcessNode (Process guid)
  | HostNode    (Host host)
  deriving (Eq, Ord, Show)

newtype Process guid = Process guid deriving (Eq, Ord, Show)
newtype Host host    = Host host deriving (Eq, Ord, Show)

data Edge guid host
  = ProcessOn (Host host)    (Process guid)
  | ParentOf  (Process guid) (Process guid)
  deriving (Eq, Show)


data SysmonEvent guid
  = ProcessCreated'                 { parentGUID :: guid , myGUID :: guid }
  | ProcessChangedFileCreationTime { path :: String, ts :: String }
  | NetworkConnection
  | SysmonServiceStateChange
  | ProcessTerminated' { pid :: String }
  | DriverLoaded
  | ImageLoaded
  | CreateRemoteThread
  | RawAccessRead
  | ProcessAccess
  | FileCreate
  | RegistryEvent
  | FileCreateStreamHash
  | PipeCreated
  | PipeConnected
  | WmiEvent
  | DNSEvent
  | Error'
  deriving Show

-- data Sysmon ts guid = Sysmon ts (SysmonEvent guid)

-- data Node hostname pid = Host hostname | Process pid | Driver

-- data Edge pid
--   = ProcessSpawned pid pid

-- someFunc :: IO ()
-- someFunc = putStrLn "someFunc"

Main.hs

{-# LANGUAGE RecordWildCards #-}
module Main where

import Control.Comonad.Store
import Control.Comonad.Traced

import Control.Monad (mapM_)
import Control.Monad.Trans.State.Lazy (State, runState, get, modify)
import Data.List (foldl')
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as M
import qualified Data.Set as S

import Graph
import Lib hiding (Graph)
import Scratch

type HostGraph = Graph (Node Int String) Int (Sysmon Int String)
applySysmon :: Sysmon Int String -> HostGraph -> HostGraph
applySysmon r@(ProcessCreated{..}) = insert $ Edge (ProcessNode me, ProcessNode parent) cdmRowID r
applySysmon r@(ProcessTerminated{..}) = undefined

type HostGraph' = Map (Node Int (Sysmon Int String)) (Set (Node Int (Sysmon Int String)))
applySysmon' :: Sysmon Int String -> HostGraph' -> HostGraph'
applySysmon' r@(ProcessCreated{..})    = M.insertWith S.union (ProcessNode parent r) (S.singleton (ProcessNode me r))
applySysmon' r@(ProcessTerminated{..}) = M.delete (ProcessNode me r) . M.map (S.delete (ProcessNode me r))
applySysmon' Error = id

type HostGraphSimple = Map String String
applySysmonSimple :: SysmonEvent String -> HostGraphSimple -> HostGraphSimple
applySysmonSimple ProcessCreated'{..}    = M.insert parentGUID myGUID
applySysmonSimple NetworkConnection      = M.insert "myPID" "myPort"
applySysmonSimple ProcessTerminated'{..} = M.delete pid

evolveGraph :: [SysmonEvent String] -> State HostGraphSimple ()
evolveGraph = mapM_ (modify . applySysmonSimple)

main :: IO ()
main = do
  -- config <- getRecord (pack "My program")
  -- print (config :: App)
  let events =
        [ ProcessCreated (Process "1") (Process "2") (Host "me")
        -- , NetworkConnection (Process "2") (Host "otherGuy")
        , ProcessTerminated (Process "2")
        , ProcessTerminated (Process "1")
        ]
  return ()
  -- -- print (runState (evolveGraph events) M.empty)
  -- print $ scanl (flip applySysmon) M.empty events

package.yaml

name:                testing
version:             0.1.0.0
github:              "githubuser/testing"
license:             BSD3
author:              "Author name here"
maintainer:          "example@example.com"
copyright:           "2020 Author name here"

extra-source-files:
- README.md
- ChangeLog.md

# Metadata used when publishing your package
# synopsis:            Short description of your package
# category:            Web

# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description:         Please see the README on GitHub at <https://github.com/githubuser/testing#readme>

dependencies:
- base >= 4.7 && < 5
- optparse-generic
- text
- transformers
- containers
- justified-containers
- comonad

library:
  source-dirs: src

executables:
  testing-exe:
    main:                Main.hs
    source-dirs:         app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - testing

tests:
  testing-test:
    main:                Spec.hs
    source-dirs:         test
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - testing

Scratch.hs

{-# LANGUAGE MultiParamTypeClasses #-}

module Scratch where

import Control.Comonad.Store
import Control.Comonad.Traced

import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as M
import qualified Data.Set as S

data Event
  = ProcessCreate Int Int
  | ProcessTerminate Int
  deriving Show

events :: [Event]
events =
  [ ProcessCreate 1 2
  , ProcessCreate 1 3
  , ProcessTerminate 2
  , ProcessCreate 3 4
  , ProcessTerminate 1
  ]

type ProcessTree = Map Int (Set Int)
type System = Traced [Event] ProcessTree
type System2 = TracedT [Event] (Store ProcessTree)
type System3 = Store [Event] ProcessTree

evolve :: Event -> ProcessTree -> ProcessTree
evolve (ProcessCreate parent child) = M.insertWith S.union parent (S.singleton child)
evolve (ProcessTerminate child)     = M.delete child . M.map (S.delete child)

s = store (foldl (flip evolve) M.empty) []
s2 = store (scanl (flip evolve) M.empty) []



-- ===================================

class StateMachine state transition where
  apply :: transition -> state -> state