Dotfiles.hs

{-# LANGUAGE RecordWildCards #-}

module Main where

import Data.List (foldl')
import qualified Data.Map.Strict as M
import qualified Data.Set as S

-- ============ 1. STATE SPACE ============

data UnitState = Inactive | Activating | Active | Deactivating | Failed
  deriving (Eq, Show)

-- runtime = unitId -> current state
type Runtime = M.Map String UnitState

-- ============ 2. WANTED STUFF (the declarative program) ============

data UnitDecl = UnitDecl
  { dWants    :: S.Set String   -- [Unit]    Wants=
  , dAfter    :: S.Set String   -- [Unit]    After=
  , dWantedBy :: S.Set String   -- [Install] WantedBy=
  } deriving (Show)

type Program = M.Map String UnitDecl

-- ============ THE POINT: your dotfiles ============

-- The real units you installed. (After- and WantedBy- only; Wants
-- mostly absent, which is exactly the bug shape.)

-- agentsview.service: background, started on default.target (works).
agentsview :: UnitDecl
agentsview = UnitDecl
  { dWants    = S.fromList ["network-online.target"]
  , dAfter    = S.fromList ["network-online.target"]
  , dWantedBy = S.fromList ["default.target"]
  }

-- the INDICATOR: previously WantedBy=graphical-session.target (never reached on MATE)
agentsviewIndicator :: UnitDecl
agentsviewIndicator = UnitDecl
  { dWants    = S.empty
  , dAfter    = S.fromList ["graphical-session.target"]
  , dWantedBy = S.fromList ["graphical-session.target"]
  }

-- a passive unit: does nothing, just a node to order/want against
emptyTarget :: UnitDecl
emptyTarget = UnitDecl S.empty S.empty S.empty

dotfiles :: Program
dotfiles = M.fromList
  [ ("agentsview.service", agentsview)
  , ("agentsview-indicator.service", agentsviewIndicator)
  -- targets and meta-units also live in the Program (as empty passive units)
  , ("default.target", emptyTarget)
  , ("graphical-session.target", emptyTarget)
  , ("network-online.target", emptyTarget)
  ]

-- ============ 3. THE EVALUATOR ============

-- Reverse index for WantedBy (the .wants/ symlinks enable materializes).
--
-- >>> wantedIndex dotfiles
-- fromList [("default.target",["agentsview.service"]),("graphical-session.target",["agentsview-indicator.service"])]
wantedIndex :: Program -> M.Map String [String]
wantedIndex prog = M.fromListWith (++)
  [ (t, [w]) | (w, d) <- M.toList prog, t <- S.toList (dWantedBy d) ]

-- Requirement closure, fixed point.
-- Starting G pulls in (a) what each unit Wants, (b) what wants each unit.
closure :: Program -> [String] -> [String]
closure prog = fix
  where
    idx = wantedIndex prog
    fix ws =
      let more = concat [ S.toList (dWants (prog M.! u))
                          ++ M.findWithDefault [] u idx
                        | u <- ws ]
          ws' = nub (ws ++ more)
      in if length ws' == length ws then ws else fix ws'

-- Kahn's algorithm. Work list maps node -> its still-pending dependencies
-- (predecessors). A node is ready when that list is empty; remove it and
-- drop it from everyone else's pending list. Leftover at the end = cycle.
kahn :: [(String, [String])] -> [String]
kahn graph = go graph []
  where
    go []    acc = reverse acc
    go nodes acc =
      let ready = [ n | (n, deps) <- nodes, null deps ]
      in if null ready
         then reverse acc ++ map fst nodes   -- cycle: emit remainder in map order
         else
           let n = head ready
               nodes' = [ (m, filter (/= n) ds)
                        | (m, ds) <- nodes, m /= n ]
           in go nodes' (n : acc)

-- Assemble the ordering for a requested start of `goals`.
run :: Program -> [String] -> [String]
run prog goals =
  let ns = closure prog goals
      nodeSet = S.fromList ns
      -- predecessor = something that must run before n (an After dep inside the closure)
      graph = [ (n, S.toList (dAfter (prog M.! n) `S.intersection` nodeSet))
              | n <- ns ]
  in kahn graph

-- small helpers
--
-- >>> nub ["agentsview","default","agentsview","network-online"]
-- ["agentsview","default","network-online"]
nub :: Eq a => [a] -> [a]
nub = foldl' (\acc x -> if x `elem` acc then acc else acc ++ [x]) []

-- ============ MAIN: run the interpreter ============

main :: IO ()
main = do
  putStrLn "=== start default.target (login) ==="
  mapM_ putStrLn (topoView dotfiles ["default.target"])
  putStrLn "=== start graphical-session.target ==="
  mapM_ putStrLn (topoView dotfiles ["graphical-session.target"])

topoView :: Program -> [String] -> [String]
topoView p = map ("  -> " ++) . run p