Graph.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Development.Guardian.Graph where

import qualified Algebra.Graph as G
import qualified Algebra.Graph.Class as GC
import Algebra.Graph.Label (Path)
import qualified Algebra.Graph.Labelled as LG
import qualified Algebra.Graph.Relation as Rel
import qualified Algebra.Graph.Relation.Preorder as Preorder
import qualified Algebra.Graph.ToGraph as GC
import Control.Monad (guard, void)
import Data.Bifunctor (Bifunctor)
import qualified Data.Bifunctor as Bi
import Data.Coerce (coerce)
import qualified Data.DList as DL
import Data.DList.DNonEmpty (DNonEmpty)
import qualified Data.DList.DNonEmpty as DLNE
import qualified Data.HashMap.Strict as HM
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Monoid (Ap (..))
import Data.Semigroup.Generic
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import Development.Guardian.Types
import GHC.Generics (Generic)
import Validation

buildDomainInfo :: Domains -> Validation (NE.NonEmpty DomainGraphError) DomainInfo
buildDomainInfo domainConfig = do
  let packageDic = buildPackageDic domainConfig
  domainGraph <- toDomainGraph domainConfig
  pure DomainInfo {..}

buildRawDomainGraph ::
  (GC.Graph gr, GC.Vertex gr ~ DomainName) =>
  Domains ->
  gr
buildRawDomainGraph Domains {..} =
  getOverlayed $
    HM.foldMapWithKey
      ( \dom Domain {..} ->
          Overlayed (GC.vertex dom)
            <> maybe mempty (foldMap (Overlayed . GC.edge dom)) dependsOn
      )
      getDomains

toDomainGraph :: Domains -> Validation (NE.NonEmpty DomainGraphError) DomainGraph
toDomainGraph doms =
  Bi.first DLNE.toNonEmpty $
    ans
      <$ Bi.first DLNE.singleton (detectCycle raw)
      <* Bi.first DLNE.singleton (detectPackageOverlaps doms)
  where
    !raw = buildRawDomainGraph doms
    !ans = Preorder.fromRelation raw

detectPackageOverlaps ::
  Domains -> Validation DomainGraphError ()
detectPackageOverlaps Domains {..}
  | Map.null overlaps = Success ()
  | otherwise = Failure $ OverlappingPackages overlaps
  where
    overlaps =
      Map.filter ((> 1) . Set.size) $
        getCatMap $
          HM.foldMapWithKey
            ( \dom ->
                foldMap
                  ( CatMap
                      . flip Map.singleton (Set.singleton dom)
                      . packageName
                  )
                  . packages
            )
            getDomains

newtype CatMap k v = CatMap {getCatMap :: Map k v}

instance (Semigroup v, Ord k) => Semigroup (CatMap k v) where
  (<>) = coerce $ Map.unionWith @k @v (<>)
  {-# INLINE (<>) #-}

instance (Semigroup v, Ord k) => Monoid (CatMap k v) where
  mempty = CatMap Map.empty
  {-# INLINE mempty #-}

detectCycle ::
  (GC.ToGraph t, Ord (GC.ToVertex t), GC.ToVertex t ~ DomainName) =>
  t ->
  Validation DomainGraphError ()
detectCycle gr =
  Bi.first CyclicDomainDep $
    eitherToValidation $
      void $
        GC.topSort gr

buildPackageDic :: Domains -> PackageDic
buildPackageDic =
  HM.foldMapWithKey
    ( \domName Domain {..} ->
        Map.fromList $
          map (\PackageDef {..} -> (packageName, (domName, extraDeps))) $
            V.toList packages
    )
    . getDomains

matches :: PackageDic -> Dependency -> PackageName -> Bool
matches pkgDic (DomainDep dn) pkg =
  maybe False ((dn ==) . fst) $ Map.lookup pkg pkgDic
matches _ (PackageDep pn) pkg = pn == pkg

newtype LOverlayed e a = LOverlayed {getLOverlayed :: LG.Graph e a}
  deriving (Show, Eq, Ord, Generic)

instance Monoid e => Semigroup (LOverlayed e a) where
  (<>) = coerce $ LG.overlay @e @a
  {-# INLINE (<>) #-}

instance Monoid e => Monoid (LOverlayed e a) where
  mempty = LOverlayed LG.empty
  {-# INLINE mempty #-}

data ActualGraphs a b = AGs {activatedGraph :: a, exceptionGraph :: b}
  deriving (Functor, Show, Eq, Ord, Generic)
  deriving (Semigroup, Monoid) via GenericSemigroupMonoid (ActualGraphs a b)

instance Bifunctor ActualGraphs where
  bimap f g (AGs x y) = AGs (f x) (g y)
  {-# INLINE bimap #-}
  first f (AGs x y) = AGs (f x) y
  {-# INLINE first #-}
  second g (AGs x y) = AGs x (g y)
  {-# INLINE second #-}

buildActualGraphs ::
  PackageDic ->
  PackageGraph ->
  Validation
    (DNonEmpty PackageViolation)
    (ActualGraphs ActualGraph (Map PackageName (Set Dependency)))
buildActualGraphs pkgDic =
  let pkgs = Map.keys pkgDic
   in fmap
        ( Bi.bimap
            (Bi.first DL.toList . getLOverlayed)
            (Map.filter (not . Set.null) . getCatMap)
        )
        . getAp
        . foldMap
          ( \e@(src, dst) -> Ap $ do
              src' <-
                maybe (failed $ OrphanPackage src pkgs) Success $
                  Map.lookup src pkgDic

              (dstDomain, _) <-
                maybe (failed $ OrphanPackage dst pkgs) Success $
                  Map.lookup dst pkgDic

              pure $
                let (srcDomain, srcExcept) = src'
                    aGraph = LOverlayed $ LG.edge (DL.singleton e) srcDomain dstDomain
                    excepts = Set.fromList $ V.toList $ V.filter (flip (matches pkgDic) dst) srcExcept
                 in if Set.null excepts
                      then AGs {exceptionGraph = mempty, activatedGraph = aGraph}
                      else AGs {activatedGraph = mempty, exceptionGraph = CatMap $ Map.singleton src excepts}
          )
        . G.edgeList

failed :: e -> Validation (DNonEmpty e) a
failed = Failure . pure

validatePackageGraph ::
  DomainInfo -> PackageGraph -> Validation (NE.NonEmpty PackageViolation) CheckResult
validatePackageGraph DomainInfo {..} pg =
  Bi.first DLNE.toNonEmpty $
    case buildActualGraphs packageDic pg of
      Failure e -> Failure e
      Success AGs {..} ->
        let redundantExtras = findRedundantExtraDeps packageDic pg
            diags =
              Diagnostics
                { redundantExtraDeps =
                    Set.fromList . V.toList <$> redundantExtras
                , usedExceptionalRules = exceptionGraph
                }
            resl
              | isEmptyDiagnostics diags = Ok
              | otherwise = OkWithDiagnostics diags
         in resl
              <$ ( case Bi.first DLNE.singleton (detectPackageCycle pg) of
                    f@Failure {} -> f
                    Success {} ->
                      Bi.first DLNE.singleton (coversAllPackages packageDic pg)
                        <* satisfiesDomainGraph domainGraph activatedGraph
                 )

detectPackageCycle ::
  PackageGraph -> Validation PackageViolation ()
detectPackageCycle pkgs =
  void $
    eitherToValidation $
      Bi.first CyclicPackageDep $
        GC.topSort pkgs

type ExemptDomDeps = ActualGraph

findRedundantExtraDeps ::
  PackageDic ->
  PackageGraph ->
  Map PackageName (V.Vector Dependency)
findRedundantExtraDeps pkgDic pg =
  Map.mapMaybeWithKey
    ( \pkg (_, specifiedDeps) -> do
        let actualDepPkgs = GC.postSet pkg pg
            actualDepDoms =
              Set.map
                (\dpkg -> maybe (error $ "No pkg find: " <> show (dpkg, actualDepPkgs)) fst (Map.lookup dpkg pkgDic))
                actualDepPkgs
            deps =
              V.filter
                ( \case
                    DomainDep dn -> dn `Set.notMember` actualDepDoms
                    PackageDep pn -> pn `Set.notMember` actualDepPkgs
                )
                specifiedDeps
        guard $ not $ V.null deps
        pure deps
    )
    pkgDic

coversAllPackages ::
  PackageDic -> PackageGraph -> Validation PackageViolation ()
coversAllPackages pkgDic pg =
  if null remain
    then Success ()
    else Failure $ UncoveredPackages remain
  where
    remain = Set.toList $ G.vertexSet pg Set.\\ Map.keysSet pkgDic

satisfiesDomainGraph ::
  DomainGraph -> ActualGraph -> Validation (DLNE.DNonEmpty PackageViolation) ()
satisfiesDomainGraph domGr ag =
  maybeToFailure () (DLNE.fromNonEmpty <$> NE.nonEmpty violatingEdges)
  where
    expectedEdges = Rel.edgeSet $ Preorder.toRelation domGr
    actualEdges :: Map (DomainName, DomainName) (Path PackageName)
    actualEdges =
      Map.fromList $
        map (\(x1, dn, dn') -> ((dn, dn'), x1)) $
          LG.edgeList ag
    violatingEdges =
      map
        ( uncurry $ uncurry DomainBoundaryViolation
        )
        $ Map.toList
        $ actualEdges `Map.withoutKeys` expectedEdges