diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for deptrack-devops + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright {yyyy} {name of copyright owner} + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +DepTrack for DevOps +=================== + +This library provides a node type for DepTrack that contains enough information +to turnup, turndown, and check the healthiness of software entities. This +library also contains functions to operate on the graph of dependency nodes +concurrently (i.e., achieving maximum speed concurrency when turning up/down +dependency graphs). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deptrack-devops.cabal b/deptrack-devops.cabal new file mode 100644 --- /dev/null +++ b/deptrack-devops.cabal @@ -0,0 +1,41 @@ +name: deptrack-devops +version: 0.1.0.0 +synopsis: DepTrack applied to DevOps. +description: Describe your infrastructure with a directed-acyclic graph. Please see README.md +homepage: https://github.com/lucasdicioccio/deptrack-project +license: Apache-2.0 +license-file: LICENSE +author: Lucas DiCioccio +maintainer: lucas@dicioccio.fr +copyright: 2017 Lucas DiCioccio +category: DevOps +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + ChangeLog.md + README.md + +library + hs-source-dirs: src + exposed-modules: Devops.Base + Devops.Actions + Devops.Cli + Devops.Constraints + Devops.Graph + build-depends: base >= 4.11 && < 5 + , array >= 0.5 && < 0.6 + , async >= 2.2 && < 2.3 + , base64-bytestring >= 1.0 && < 1.1 + , binary >= 0.8 && < 0.9 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , deptrack-core >= 0.1 && < 0.2 + , distributed-closure >= 0.4 && < 0.5 + , dotgen >= 0.4 && < 0.5 + , hashable >= 1.2 && < 1.3 + , lens >= 4.16 && < 4.17 + , mtl >= 2.2 && < 2.3 + , safe >= 0.3 && < 0.4 + , stm >= 2.4 && < 2.5 + , text >= 1.2 && < 1.3 + default-language: Haskell2010 diff --git a/src/Devops/Actions.hs b/src/Devops/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Devops/Actions.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TupleSections #-} + +module Devops.Actions ( + concurrentTurnup , concurrentTurndown , concurrentUpkeep , checkStatuses + , sequentialTurnup, sequentialTurnDown + , display , defaultDotify , dotifyWithStatuses + , listUniqNodes + ) where + +import Control.Concurrent.Async (waitCatch) +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar (TVar, readTVar) +import Control.Lens (view) +import Data.Graph (edges, transposeG, vertices) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import Data.Tree (Tree (..), drawForest, flatten) +import Text.Dot (Dot, edge, showDot, userNode, + userNodeId) + +import Devops.Base (CheckResult (..), Op (..), + OpDescription (..), OpUniqueId, + PreOp, opUniqueId, preOpUniqueId, + runPreOp) +import Devops.Graph + +-- * Concurrent Operations + +-- | Turns up a graph concurrently. +concurrentTurnup :: OpGraph -> IO () +concurrentTurnup graph = do + let s = snapshot TurnedUp graph emptyIntents + sm <- atomically $ makeStatusesMap s + asyncTurnupGraph noBroadcast sm s graph + +-- | Keeps a graph up concurrently. +concurrentUpkeep :: OpGraph -> IO () +concurrentUpkeep graph = do + let s = snapshot TurnedUp graph emptyIntents + sm <- atomically $ makeStatusesMap s + upkeepGraph noBroadcast sm s graph defaultUpKeepFSM defaultDownKeepFSM + +-- | Turns down a graph concurrently. +concurrentTurndown :: OpGraph -> IO () +concurrentTurndown (g,f1,f2) = do + let graph = (transposeG g, f1, f2) + let s = snapshot TurnedDown graph emptyIntents + sm <- atomically $ makeStatusesMap s + asyncTurndownGraph noBroadcast sm s graph + +-- | Checks the graph and returns a dot formatted graph. +checkStatuses :: OpGraph -> IO (Map OpUniqueId CheckResult) +checkStatuses graph = do + let s = snapshot TurnedUp graph emptyIntents + statuses <- atomically $ makeStatusesMap s + asyncs <- checkWholeGraph noBroadcast statuses s graph + _ <- traverse waitCatch asyncs + atomically $ extractStatuses statuses + where + extractStatuses :: OpStatusesMap -> STM (Map OpUniqueId CheckResult) + extractStatuses statuses = + Map.fromList <$> traverse extractOne (Map.toList statuses) + extractOne :: (OpUniqueId, TVar OpStatus) -> STM (OpUniqueId, CheckResult) + extractOne (opId, tvar) = do + status <- readTVar tvar + return $ (opId, view opCheckResult status) + +-- * Sequential Operations + +sequentialTurnup :: OpGraph -> IO () +sequentialTurnup (g,f1,f2) = syncTurnupGraph noBroadcast (transposeG g, f1, f2) + +sequentialTurnDown :: OpGraph -> IO () +sequentialTurnDown = syncTurnDownGraph noBroadcast + +-- | Display a forest of operations. +display :: [Tree PreOp] -> IO () +display = putStrLn . drawForest . (fmap . fmap) (show . opDescription . runPreOp) + +-- | Lists the uniq list of nodes. +listUniqNodes :: [Tree PreOp] -> IO () +listUniqNodes forest = + let uniq f xs = Map.toList . Map.fromList $ zip (map f xs) xs + in putStrLn . unlines . map (\(k,v) -> show (k, opName $ opDescription v)) . uniq opUniqueId . map runPreOp . concatMap flatten $ forest + +-- | Returns a .dot formatted string of a graph using a projection function to +-- format every PreOp using .dot valid key/value node attributes. +dotifyWith :: (PreOp -> [(String,String)]) -> OpGraph -> String +dotifyWith attributes (g,lookupF,_) = + showDot dotted + where + dotted :: Dot () + dotted = do + let node v = y where (y,_,_) = lookupF v + let vs = vertices g + let es = filter (uncurry (/=)) $ edges g + mapM_ (\i -> userNode (userNodeId i) (attributes (node i))) vs + mapM_ (\(i,j) -> edge (userNodeId i) (userNodeId j) []) es + +-- | Builds a dot-formatted representation of the graph +defaultDotify :: OpGraph -> String +defaultDotify = dotifyWith nameAttributes + +-- | Same as dotify but also colorize based on statuses passed in second argument. +dotifyWithStatuses :: OpGraph -> Map OpUniqueId CheckResult -> String +dotifyWithStatuses graph x = + let allAttributes = nameAttributes <> colorFromStatusAttributes x + in dotifyWith allAttributes graph + +nameAttributes :: PreOp -> [(String, String)] +nameAttributes preOp = + let o = runPreOp preOp in + [("label", Text.unpack $ opName $ opDescription o)] + +colorFromStatusAttributes :: Map OpUniqueId CheckResult -> PreOp -> [(String, String)] +colorFromStatusAttributes c op = + let status = Map.lookup (preOpUniqueId op) c + in maybe unknownStatusLabels labelsFromStatus status + where + labelsFromStatus :: CheckResult -> [(String, String)] + labelsFromStatus Success = [("color", "green")] + labelsFromStatus Skipped = [("color", "yellow")] + labelsFromStatus Unknown = [("color", "blue")] + labelsFromStatus _ = [("color", "red")] + unknownStatusLabels :: [(String, String)] + unknownStatusLabels = [("shape", "egg")] + diff --git a/src/Devops/Base.hs b/src/Devops/Base.hs new file mode 100644 --- /dev/null +++ b/src/Devops/Base.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + +-- The base of Devops, using DepTrack. +-- +-- Basically like an applicative computation building a set of continuations +-- that run in an interpreter to turn nodes up/down. +module Devops.Base ( + PreOp (..) + , rawpreop + , Op (..) + , OpDescription (..) + , OpFunctions (..) + , DevOp , DevOpT + , runPreOp + , preopType + , OpUniqueId , preOpUniqueId + , OpCheck , CheckResult (..) , fromBool , noCheck + , OpAction , noAction + , buildOp + , buildPreOp + , noop + , neutralize + , TypedPreOp , castPreop + , devop + , Name + -- + , track + , declare + , inject + , guardEnv + , runDevOp + , getDependenciesOnly + ) where + +import Control.Applicative (Alternative) +import Control.Monad (guard) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader (ReaderT, runReaderT, ask, lift) +import Data.Hashable (Hashable (..), hash) +import Data.Proxy +import qualified Safe +import Data.Text (Text) +import Data.Tree (Forest) +import Data.Typeable (TypeRep, Typeable, cast, typeOf) +import GHC.Generics (Generic) + +import DepTrack (DepTrackT) +import qualified DepTrack + +type Name = Text + +-- | Handy name for tracking DevOp dependencies. +type DevOpT e m = ReaderT e (DepTrackT PreOp m) + +-- | Handy name for tracking DevOp dependencies using a pure computation +-- (recommended). +type DevOp env = DevOpT env [] + +-- | Evaluates the return value of a DevOp, discarding the dependencies. +runDevOp :: env -> DevOp env a -> Maybe a +runDevOp env = Safe.headMay . DepTrack.value . flip runReaderT env + +-- | Evaluates the dependencies of a DevOp, discarding any result. +getDependenciesOnly :: env -> DevOp env a -> Forest PreOp +getDependenciesOnly env devop = + let + res = DepTrack.evalDepForest1 $ runReaderT devop env + in + case res of [] -> [] ; ((_, forest):_) -> forest + +-- | Encapsulates a deferred `Op` along with an `a` argument to generate it. +-- +-- The PreOp is more or less a continuation to produce an Op (which is a set +-- of actions to turnup/turndown system states). +-- +-- This definition uses existential quantification with a Typeable constraint: +-- * generally, we do not care about the intermediate type +-- * however, we may want to inspect dependency nodes to apply some tree/graph +-- conversion +-- * we don't want to explicitly require library users to create a gigantic +-- sum-type +data PreOp = forall a. Typeable a => PreOp !a !(a -> Op) + +-- | Applies the argument and the function in a PreOp to get an Op. +runPreOp :: PreOp -> Op +runPreOp (PreOp x f) = f x + +-- | Almost like a PreOp, but which exposes the type of the intermediary +-- value. +type TypedPreOp a = (a, a -> Op) + +-- | Convert a PreOp to a TypedPreOp at runtime. +castPreop :: Typeable a => Proxy a -> PreOp -> Maybe (TypedPreOp a) +castPreop _ (PreOp x f) = (,) <$> cast x <*> cast f + +-- | Reads the runtime representation of the PreOp argument. +-- +-- This function is useful to display or filter dependency nodes at runtime. +preopType :: PreOp -> TypeRep +preopType (PreOp x _) = typeOf x + +-- | The identifier for a PreOp. +preOpUniqueId :: PreOp -> OpUniqueId +preOpUniqueId = opUniqueId . runPreOp + +instance Show PreOp where + show = show . runPreOp + +instance Eq PreOp where + preop1 == preop2 = opDescription (runPreOp preop1) == opDescription (runPreOp preop2) + +type OpUniqueId = Int + +-- | An actual system-level operation that can be tracked and depended on. +-- `Op`s provide standard `OpFunctions` for actually enacting commands. They are +-- identified by a `OpUniqueId` which is, as it name implies, is guaranteed to be unique +-- across a whole `DepTrack` graph. +data Op = Op { opDescription :: !OpDescription + , opFunctions :: !OpFunctions + , opUniqueId :: !OpUniqueId + } + +instance Show Op where + show (Op desc _ _) = "Op (" ++ show desc ++ ", <...functions...>)" + +data OpDescription = OpDescription { opName :: !Name + , opDocumentation :: !Text + } deriving (Show, Eq, Ord, Generic) + +instance Hashable OpDescription + +type Reason = String -- reason for a failure + +data CheckResult = + Skipped + -- ^ the Check was skipped (e.g., it's not meaningful or the actions are idempotent and cheap => checking is not useful) + | Unknown + -- ^ the Check has not taken place or not succeeded for unknown reasons + | Success + -- ^ the Check finished and determined a success + | Failure !Reason + -- ^ the Check finished and determined a failure + deriving (Show, Read, Eq, Ord) + +-- | Transforms True into Success, False into a Failure. +fromBool :: Bool -> CheckResult +fromBool (!True) = Success +fromBool (!False) = Failure "false (fromBool)" + +type OpCheck = IO CheckResult +type OpAction = IO () + +-- | Functions that can be run on an `Op` object, e.g. a system dependency to enact +-- commands. +data OpFunctions = OpFunctions { opCheck :: !OpCheck + , opTurnup :: !OpAction + , opTurndown :: !OpAction + , opReload :: !OpAction + } + +noCheck :: OpCheck +noCheck = return Skipped + +noAction :: OpAction +noAction = return () + +-- | Projects a Typeable object to a Preop using a projection function. +-- This is a low-level projection function. +rawpreop :: Typeable a => a -> (a -> Op) -> PreOp +rawpreop v f = PreOp v f + +-- | Build the internal representation for an 'Op'. +buildOp :: Name -> Text -> OpCheck -> OpAction -> OpAction -> OpAction -> Op +buildOp a b f1 f2 f3 f4 = + let desc = (OpDescription a b) in + let oid = hash desc in + let functions = OpFunctions f1 f2 f3 f4 in + Op desc functions oid + +-- | Build the internal representation for a 'PreOp'. +buildPreOp :: Name -> Text -> OpCheck -> OpAction -> OpAction -> OpAction -> PreOp +buildPreOp a b f1 f2 f3 f4 = let val = buildOp a b f1 f2 f3 f4 + in rawpreop val id + +-- | Simple no-op PreOp. +data NoOp = NoOp deriving (Show,Typeable) + +-- | Returns a noop. +noop :: Name -> Text -> PreOp +noop a b = rawpreop NoOp (const $ buildOp a b noCheck noAction noAction noAction) + +-- | Takes an Op and makes it a PreOp with same description but with noop +-- checks and actions. +neutralize :: Op -> PreOp +neutralize (Op desc _ oid) = + let val = Op desc (OpFunctions noCheck noAction noAction noAction) oid + in rawpreop val id + +-- | Tracks dependencies to build an object given a pair of projection -- +-- functions and a DepTrackT computation tracking predecessors. +devop + :: (Typeable b, Monad m) + => (a -> b) + -> (a -> Op) + -> DevOpT e m a + -> DevOpT e m b +devop f g a = do + env <- ask + let tracked = DepTrack.track g' (runReaderT a env) + fmap f $ lift tracked + where + g' v = let !o = g v in rawpreop (f v) (const o) + +track :: (Monad m) + => (a -> PreOp) + -> DevOpT e m a + -> DevOpT e m a +track f a = do + env <- ask + let tracked = DepTrack.track f (runReaderT a env) + lift tracked + +declare :: (Monad m) + => PreOp + -> DevOpT e m a + -> DevOpT e m a +declare obj = track (const obj) + +inject :: (Monad m) + => DevOpT e m a + -> DevOpT e m b + -> DevOpT e m (a, b) +inject m1 m2 = do + env <- ask + let tracked = DepTrack.inject (runReaderT m1 env) (runReaderT m2 env) + lift tracked + +guardEnv :: (Monad m, Alternative m) => (e -> Bool) -> DevOpT e m () +guardEnv f = ask >>= guard . f diff --git a/src/Devops/Cli.hs b/src/Devops/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Devops/Cli.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RecordWildCards #-} +-- | Building-block methods to build a command-line tool able to inspect and +-- turnup/turndown DevOps. +module Devops.Cli ( + Method (..), Concurrency (..) + , applyMethod + -- * Building main programs + , simpleMain + , SelfPath + , ForestOptimization + , App (..) + , appMain + , appMethod + , methodArg + -- * Utilities + , getDependenciesOnly + , graphize + , opClosureFromB64 + , opClosureToB64 + ) where + +import Control.Distributed.Closure (Closure, unclosure) +import Control.Monad.Identity (runIdentity) +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64.Lazy as B64 +import Data.ByteString.Lazy (ByteString) +import Data.Tree (Forest) +import Data.Typeable (Typeable) +import DepTrack (GraphData, buildGraph, evalDepForest1) +import Prelude hiding (readFile) +import System.Environment (getArgs, getExecutablePath) + +import Devops.Actions (checkStatuses, concurrentTurndown, concurrentTurnup, concurrentUpkeep, defaultDotify, + display, dotifyWithStatuses, listUniqNodes, sequentialTurnDown, sequentialTurnup) +import Devops.Base (DevOp, OpUniqueId, PreOp, preOpUniqueId, getDependenciesOnly) + +-------------------------------------------------------------------- + +data Method = + TurnUp Concurrency + | TurnDown Concurrency + | Upkeep + | Print + | Dot + | CheckDot + | List + +data Concurrency = Concurrently | Sequentially + +-------------------------------------------------------------------- +applyMethod :: [(Forest PreOp -> Forest PreOp)] + -> Forest PreOp + -> Method + -> IO () +applyMethod transformations originalForest meth = do + let forest = foldl (.) id transformations originalForest + let graph = graphize forest + + case meth of + TurnUp Concurrently -> concurrentTurnup graph + TurnUp Sequentially -> sequentialTurnup graph + TurnDown Concurrently -> concurrentTurndown graph + TurnDown Sequentially -> sequentialTurnDown graph + Upkeep -> concurrentUpkeep graph + Print -> display forest + Dot -> putStrLn . defaultDotify $ graph + CheckDot -> putStrLn . dotifyWithStatuses graph =<< checkStatuses graph + List -> listUniqNodes forest + +-------------------------------------------------------------------- + +-- | Simple main function for a single operation. +-- +-- You should use this 'simpleMain' for simple configuration binaries, more +-- involved architectures shoul almost need a 'App' or 'appMain'. +simpleMain :: DevOp env a + -- ^ an operation + -> [(Forest PreOp -> Forest PreOp)] + -- ^ forest transformations to optimize the resulting graph + -> [String] + -- ^ args + -> env + -- ^ environment + -> IO () +simpleMain devop optimizations args env = go args + where + forest = getDependenciesOnly env devop + call m = applyMethod optimizations forest m + go ("up":_) = call $ TurnUp Concurrently + go ("up-seq":_) = call $ TurnUp Sequentially + go ("down":_) = call $ TurnDown Concurrently + go ("down-seq":_) = call $ TurnDown Sequentially + go ("upkeep":_) = call Upkeep + go ("print":_) = call Print + go ("dot":_) = call Dot + go ("check-dot":_) = call CheckDot + go ("list":_) = call List + go _ = putStrLn usage + usage = unlines [ "deptrack-devops default main:" + , " Available arguments:" + , " up, down, upkeep, print, dot, check-dot, list" + ] + +-------------------------------------------------------------------- + +-- | A FilePath corresponding to the file with the currently-executing binary. +type SelfPath = FilePath + +-- | An optimization on PreOp forests. +type ForestOptimization = Forest PreOp -> Forest PreOp + +-- | A builder for app that can be useful for defining an infrastructure as a +-- recursive structure where the "main entry point" of the recursion is the +-- binary itself. +data App env node = App { + _parseArgs :: [String] -> (node, Method) + -- ^ Parses arguments, returns a parsed architecture and a set of args for + -- the real defaulMain. + , _revParse :: node -> Method -> [String] + -- ^ Reverse parse arguments, for instance when building a callback. + , _target :: node -> SelfPath -> (node -> Method -> [String]) -> DevOp env () + -- ^ Generates a target from the argument and the selfPath + , _opts :: [ForestOptimization] + -- ^ Optimizations to run. + , _retrieveEnv :: node -> IO env + -- ^ IO to retrieve the current environment. + } + +-- | DefaultMain for 'App'. +appMain :: App env a -> IO () +appMain App{..} = do + self <- getExecutablePath + args <- getArgs + let (node, meth) = _parseArgs args + env <- _retrieveEnv node + let forest = getDependenciesOnly env $ _target node self _revParse + applyMethod _opts forest meth + +-- | Unsafely parse a 'Method' from what could be a command line argument. +-- +-- (NB. unsafe means this function is partial, you should use this function in +-- conjunction with 'methodArg' for the reverse parse and you will be fine). +appMethod :: String -> Method +appMethod "up" = TurnUp Concurrently +appMethod "up-seq" = TurnUp Sequentially +appMethod "down" = TurnDown Concurrently +appMethod "down-seq" = TurnDown Sequentially +appMethod "upkeep" = Upkeep +appMethod "print" = Print +appMethod "dot" = Dot +appMethod "check-dot" = CheckDot +appMethod "list" = List +appMethod str = error $ "unparsed appMethod: " ++ str + +-- | Serializes a 'Method' to what should be a command-line argument later +-- parsed via 'appMethod'. +methodArg :: Method -> String +methodArg (TurnUp Concurrently) = "up" +methodArg (TurnUp Sequentially) = "up-seq" +methodArg (TurnDown Concurrently) = "down" +methodArg (TurnDown Sequentially) = "down-seq" +methodArg Upkeep = "upkeep" +methodArg Print = "print" +methodArg Dot = "dot" +methodArg CheckDot = "check-dot" +methodArg List = "list" + +-------------------------------------------------------------------- + +-- | Builds a Graph from dependencies represented as a Forest. +-- +-- Nodes with a same hash in the Forest will correspond to the same node in the +-- graph, hence, it's possible to create cycles by mistake if two nodes have a +-- same hash by mistake (this is possible if the hash does not depend on all +-- arguments to a DevOp). +graphize :: Forest PreOp -> GraphData PreOp OpUniqueId +graphize forest = buildGraph preOpUniqueId forest + +-- | Helper to deal with App when you want to use Closures as a +-- serialization/deserialization mechanism. +-- +-- You will likely add 'opClosureFromB64' in the '_parseArgs' field of your +-- 'App' and 'opClosureToB64' in the '_revParse' field. +opClosureFromB64 :: (Typeable env, Typeable a) => ByteString -> Closure (DevOp env a) +opClosureFromB64 b64 = do + let bstr = B64.decode b64 + let encodedClosure = either (error "invalid base64") id bstr + Binary.decode encodedClosure + +-- | Dual to 'opClosureFromB64'. +opClosureToB64 :: (Typeable env, Typeable a) => Closure (DevOp env a) -> ByteString +opClosureToB64 clo = + B64.encode $ Binary.encode clo diff --git a/src/Devops/Constraints.hs b/src/Devops/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Devops/Constraints.hs @@ -0,0 +1,20 @@ + +-- | Set of constraints useful for declaring DevOp. +module Devops.Constraints where + +import Control.Applicative (Alternative) +import Devops.Base + +class HasOS a where + os :: a -> String + +type OSName = String + +-- | Guards an action if it is not on a given OS. +onOS + :: (Monad m, Applicative m, Alternative m, HasOS env) + => OSName + -> DevOpT env m a + -> DevOpT env m a +onOS name act = + guardEnv ((== name) . os) *> act diff --git a/src/Devops/Graph.hs b/src/Devops/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Devops/Graph.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Devops.Graph ( + WantedDirection (..) + , Stability (..) + , OpGraph + , OpStatus , opCheckResult + , OpStatusesMap + , OpIntent , intentPreOp , intentDirection + , Intents , emptyIntents + -- + , Broadcast + , noBroadcast + -- * Asynchronous Operations + , snapshot , makeStatusesMap + , asyncTurnupGraph , asyncTurndownGraph , checkWholeGraph , upkeepGraph + , defaultUpKeepFSM , defaultDownKeepFSM + -- + , waitStability + -- * Synchronous Operations + , syncTurnupGraph, syncTurnDownGraph + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, mapConcurrently) +import Control.Concurrent.STM (STM, atomically, retry) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVar, + readTVar, readTVarIO, writeTVar) +import Control.Lens (set, view) +import Control.Lens.TH (makeLenses) +import Control.Monad (mapM_, void) +import qualified Data.Array as Array +import qualified Data.Graph as Graph +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import GHC.Generics + +import DepTrack (GraphData) +import Devops.Base (CheckResult (..), Op (..), + OpDescription (..), + OpFunctions (..), OpUniqueId, + PreOp, preOpUniqueId, runPreOp) + +-- | The intended direction of an operation. +data WantedDirection = TurnedUp | TurnedDown + deriving (Show,Eq,Ord,Generic) + +-- | NIH Stream representing an infinite non-empty lists. +-- TODO: +-- * carry some logical version/timestamp +-- * take some generally-accepted Stream implementation. +data Stream a = Cons a (Stream a) + deriving (Functor) +instance Applicative Stream where + pure x = let stream = Cons x stream in stream + Cons f fs <*> Cons a as = Cons (f a) (fs <*> as) + +-- | A snapshot representing the intent for a single operation at a given time. +data OpIntent = + OpIntent { _intentDirection :: WantedDirection + , _intentPreOp :: PreOp + } +makeLenses ''OpIntent + +-- | The stability an operation reached. +data Stability = Stable | Transient + deriving (Show,Eq,Ord,Generic) + +-- | The observed status for an operation. +data OpStatus = + OpStatus { _opCheckResult :: !CheckResult + , _opDirection :: !WantedDirection + , _opStability :: !Stability + } deriving Show +makeLenses ''OpStatus + +-- | A simple handler to be used when turning-up/down a graph sequentially +type SyncOpHandler a = PreOp -> IO a + +-- | A `PreOp` handler when turning up/down a graph concurrently +type AsyncOpHandler a = PreOp + -- ^ the operation + -> TVar OpStatus + -- ^ the operation status + -> [TVar OpStatus] + -- ^ children operations statuses + -> [TVar OpStatus] + -- ^ parents operations statuses + -> OpHistory + -- ^ historical intents for this operation + -> IO a + +-- | An OpGraph is a Graph containing PreOp. +type OpGraph = GraphData PreOp OpUniqueId + +-- | A succession of OpIntent to model intentions varying with events. +type OpHistory = Stream OpIntent + +-- | A map representing the collection of histories for a set of operations. +type Intents = Map OpUniqueId OpHistory +emptyIntents :: Intents +emptyIntents = Map.empty + +-- | A map representing the mutable status for a set of operations. +type OpStatusesMap = Map OpUniqueId (TVar OpStatus) + +-- | Concurrently spawn an action for each item in an OpGraph. +traverseOpGraph :: + OpStatusesMap + -> Intents + -> OpGraph + -> AsyncOpHandler a + -> IO [a] +traverseOpGraph statusMap intents (g,lookupVertex,_) handler = do + mapConcurrently (traverseOne handler) (Graph.vertices g) + where + traverseOne :: AsyncOpHandler a -> Graph.Vertex -> IO a + traverseOne go vertex = do + let (preop,oid,_) = lookupVertex vertex + let childrenOids = fmap (\(_,x,_) -> x) $ fmap lookupVertex (g Array.! vertex) + let parentsOids = fmap (\(_,x,_) -> x) $ fmap lookupVertex (Graph.transposeG g Array.! vertex) + let tvar = Map.lookup oid statusMap + let ophistory = Map.lookup oid intents + let childrenTVars = traverse (flip Map.lookup statusMap) + (childrenOids) + let parentsTVars = traverse (flip Map.lookup statusMap) + (parentsOids) + let action = go preop <$> tvar <*> childrenTVars <*> parentsTVars <*> ophistory + fromMaybe (error "tvar/ophistory mismatch") action + +-- | Atomically wait until all statuses are stable after reaching a given +-- direction. +waitStability :: WantedDirection -> Stability -> [TVar OpStatus] -> STM () +waitStability dir stab statusTVars = do + statuses <- traverse readTVar statusTVars + let stable x = stab == view opStability x + let rightDirection x = dir == view opDirection x + let ok x = stable x && rightDirection x + let ready = all ok statuses + if ready then return () else retry + +type Broadcast = (OpUniqueId,CheckResult,Stability,WantedDirection) -> IO () +noBroadcast :: Broadcast +noBroadcast = const (return ()) + +-- | Turn-up a graph sequentially +-- +-- Topologically sorts the graph then invokes `TurnUp` action synchronously +-- through each node. Note the order of execution is deterministic. +syncTurnupGraph :: Broadcast -> OpGraph -> IO () +syncTurnupGraph bcast (graph,lookupVertex,_) = + mapM_ go (Graph.topSort graph) + where + go :: Graph.Vertex -> IO () + go vertex = do + let (preop,oid,_) = lookupVertex vertex + desc = opName . opDescription $ runPreOp preop + funs = opFunctions $ runPreOp preop + turnup = opTurnup funs + reload = opReload funs + check = opCheck funs + bcast (oid,Unknown,Transient,TurnedUp) + print ("pre-checking: " <> desc) + currentStatus <- check + case currentStatus of + Success -> print ("reloading: " <> desc) >> reload + _ -> print ("turning-up: " <> desc) >> turnup + print ("turnup-done: " <> desc) + bcast (oid,Success,Stable,TurnedUp) + +-- | Turn-down a graph sequentially +-- +-- Topologically sorts the graph then invokes `TurnDown` action synchronously +-- through each node. Note the order of execution is deterministic. +syncTurnDownGraph :: Broadcast -> OpGraph -> IO () +syncTurnDownGraph bcast (graph,lookupVertex,_) = + mapM_ go (Graph.topSort graph) + where + go :: Graph.Vertex -> IO () + go vertex = do + let (preop,oid,_) = lookupVertex vertex + desc = opName . opDescription $ runPreOp preop + turndown = opTurndown $ opFunctions $ runPreOp preop + bcast (oid,Unknown,Transient,TurnedDown) + print ("turning-down: "<> desc) + turndown + print ("turndown-done: " <> desc) + bcast (oid,Success,Stable,TurnedDown) + +-- forks a node that will turnup a given Op once its children +-- all are green +-- dies early if the graph changes and removes the vertex from OpGraphStatuses +asyncTurnupGraph :: Broadcast + -> OpStatusesMap + -> Intents + -> OpGraph + -> IO () +asyncTurnupGraph bcast statusMap intents graph = do + void $ traverseOpGraph statusMap intents graph go + where + go :: AsyncOpHandler () + go preop tvar childrenTVars _ _ = do + let oid = preOpUniqueId preop + let desc = opName . opDescription $ runPreOp preop + let turnup = opTurnup $ opFunctions $ runPreOp preop + let reload = opReload $ opFunctions $ runPreOp preop + let check = opCheck $ opFunctions $ runPreOp preop + print $ "turnup waiting " <> (Text.pack (show (length childrenTVars))) <> " children: " <> desc + atomically $ do + waitStability TurnedUp Stable childrenTVars + modifyTVar' tvar (set opStability Transient) + bcast (oid,Unknown,Transient,TurnedUp) + print ("pre-checking: " <> desc) + currentStatus <- check + threadDelay 1000000 + case currentStatus of + Success -> print ("reloading: " <> desc) >> reload + _ -> print ("turning-up: " <> desc) >> turnup + atomically $ do + modifyTVar' tvar (set opStability Stable) + print ("turnup-done: " <> desc) + bcast (oid,Success,Stable,TurnedUp) + +-- | TODO: no longer transpose graph at the calling sites +asyncTurndownGraph :: Broadcast -> OpStatusesMap -> Intents -> OpGraph -> IO () +asyncTurndownGraph bcast statusMap intents graph = do + void $ traverseOpGraph statusMap intents graph go + where + -- wait for children to be OK and continue + go :: AsyncOpHandler () + go preop tvar childrenTVars _ _ = do + let oid = preOpUniqueId preop + let desc = opName . opDescription $ runPreOp preop + let turndown = opTurndown $ opFunctions $ runPreOp preop + print $ "turndown waiting " <> (Text.pack $ show (length childrenTVars)) <> " children: " <> desc + atomically $ do + waitStability TurnedDown Stable childrenTVars + modifyTVar' tvar (set opStability Transient) + bcast (oid,Unknown,Transient,TurnedDown) + print ("turning-down: "<> desc) + turndown + threadDelay 1000000 + atomically $ do + modifyTVar' tvar (set opStability Stable) + print ("turndown-done: " <> desc) + bcast (oid,Success,Stable,TurnedDown) + +checkWholeGraph :: Broadcast + -> OpStatusesMap + -> Intents + -> OpGraph + -> IO [Async (OpUniqueId, CheckResult, Stability, WantedDirection)] +checkWholeGraph bcast statusMap intents graph = do + traverseOpGraph statusMap intents graph go' + where + go' :: AsyncOpHandler (Async (OpUniqueId, CheckResult, Stability, WantedDirection)) + go' preop tvar _ _ _ = go (runPreOp preop) tvar + + go :: Op -> (TVar OpStatus) -> IO (Async (OpUniqueId, CheckResult, Stability, WantedDirection)) + go op tvar = do + async $ do + !newCheckResult <- opCheck $ opFunctions $ op + (_,new) <- atomically $ do + oldStatus <- readTVar tvar + let !newStatus = set opCheckResult newCheckResult oldStatus + writeTVar tvar newStatus + return (oldStatus, newStatus) + let oid = opUniqueId op + let ret = (oid,(view opCheckResult new), + (view opStability new), + (view opDirection new)) + bcast ret -- optimization to be here, could batch at the end + return ret + +data UpkeepState = + WaitUp + -- ^ waiting for a trigger to turn this node up + | Upping + -- ^ last we know, the node is currently turning up + | Up + -- ^ the node is considered turned up + +data UpkeepFSMFunctions = UpkeepFSMFunctions { + _waitUpAndStable :: IO () + , _turnupOrReload :: IO () + , _checkUpStatus :: IO OpStatus + } +makeLenses ''UpkeepFSMFunctions + +data DownkeepFSMFunctions = DownkeepFSMFunctions { + _waitDownAndStable :: IO () + , _performTurndown :: IO () + , _checkDownStatus :: IO OpStatus + } +makeLenses ''DownkeepFSMFunctions + +data DownkeepState = + WaitDown + -- ^ waiting for a trigger to turn this node down + | Downing + -- ^ last we know, the node is currently turning down + | Down + -- ^ the node is considered turned down + +-- | Transpose a intents from a "map of historical intentions" to a "history of +-- maps of intentions". +snapshots :: Intents -> Stream (Map OpUniqueId OpIntent) +snapshots = Map.traverseWithKey (\_ h -> h) + +-- | Turns a graph up and keep it up. +upkeepGraph :: Broadcast + -- ^ function delivering node change updates + -> OpStatusesMap + -- ^ instantaneous statuses + -> Intents + -- ^ historical intents + -> OpGraph + -- ^ graph containing adjacencies + -> UpkeepFSM + -- ^ FSM to apply to nodes that must be up + -> DownkeepFSM + -- ^ FSM to apply to nodes that must be down + -> IO () +upkeepGraph bcast statusMap intents graph upKeepFSM downKeepFSM = do + void $ traverseOpGraph statusMap intents graph go + where + go :: PreOp -> TVar OpStatus -> [TVar OpStatus] -> [TVar OpStatus] -> OpHistory -> IO () + go preop tvar childrenTVars parentTVars ophistory = do + let (Cons intent _) = ophistory + let !direction = view intentDirection intent + let !op = runPreOp preop + let !oid = opUniqueId op + let !desc = opName $ opDescription op + let !turnup = opTurnup $ opFunctions op + let !turndown = opTurndown $ opFunctions op + let !reload = opReload $ opFunctions op + let !check = opCheck $ opFunctions op + + let waitUpAndStableFunction = do + print ("waiting-start: " <> desc) + atomically $ do + waitStability TurnedUp Stable childrenTVars + modifyTVar' tvar (set opStability Transient) + bcast (oid,Unknown,Transient,TurnedUp) + + let waitDownAndStableFunction = do + print ("waiting-stop: " <> desc) + atomically $ do + waitStability TurnedDown Stable parentTVars + modifyTVar' tvar (set opStability Transient) + bcast (oid,Unknown,Transient,TurnedDown) + + let turnupOrReloadFunction = do + !status <- readTVarIO tvar + lastCheck <- case view opCheckResult status of + Unknown -> print ("pre-checking: " <> desc) >> check + x -> print ("re-checked: " <> desc) >> return x + case lastCheck of + Success -> print ("reloading: " <> desc) >> reload + _ -> print ("turning-up: " <> desc) >> turnup + atomically $ do + modifyTVar' tvar (set opStability Stable) + bcast (oid,Success,Stable,TurnedUp) + + let performTurndownFunction = do + print ("turning-down: "<> desc) + turndown + atomically $ do + modifyTVar' tvar (set opStability Stable) + bcast (oid,Success,Stable,TurnedDown) + + let checkStatusFunction = do + print ("checking: " <> desc) + !newCheckResult <- check + (_,new) <- atomically $ + adjustTVar' tvar (set opCheckResult newCheckResult) + bcast (oid,(view opCheckResult new), + (view opStability new), + (view opDirection new)) + return new + + let upFunctions = UpkeepFSMFunctions + waitUpAndStableFunction + turnupOrReloadFunction + checkStatusFunction + let downFunctions = DownkeepFSMFunctions + waitDownAndStableFunction + performTurndownFunction + checkStatusFunction + case direction of + TurnedUp -> upKeepFSM WaitUp upFunctions + TurnedDown -> downKeepFSM WaitDown downFunctions + +type UpkeepFSM = UpkeepState -> UpkeepFSMFunctions -> IO () +type DownkeepFSM = DownkeepState -> DownkeepFSMFunctions -> IO () + +defaultUpKeepFSM :: UpkeepFSM +defaultUpKeepFSM = fsm 100000 + where + increaseDelay :: Int -> Int + increaseDelay delay = min (delay * 2) 60000000 + decreaseDelay :: Int -> Int + decreaseDelay delay = max (floor $ (fromIntegral delay / 2 :: Float) ) 500000 + + fsm delay WaitUp xyz = threadDelay delay >> view waitUpAndStable xyz >> fsm delay Upping xyz + fsm delay Upping xyz = threadDelay delay >> view turnupOrReload xyz >> fsm delay Up xyz + fsm delay Up xyz = threadDelay delay >> do + newStatus <- view checkUpStatus xyz + case (view opCheckResult newStatus) of + Success -> fsm (increaseDelay delay) Up xyz + Skipped -> fsm (increaseDelay delay) Up xyz + _ -> fsm (decreaseDelay delay) Upping xyz + +defaultDownKeepFSM :: DownkeepFSM +defaultDownKeepFSM = fsm + where + fsm WaitDown xyz = threadDelay 1000000 >> view waitDownAndStable xyz >> fsm Downing xyz + fsm Downing xyz = threadDelay 1000000 >> view performTurndown xyz >> fsm Down xyz + fsm Down xyz = threadDelay 3000000 >> do + newStatus <- view checkDownStatus xyz + case (view opCheckResult newStatus) of + (Failure _) -> fsm Down xyz + _ -> fsm Downing xyz + +-- | Computes a snapshot of an OpGraph. +snapshot :: WantedDirection -> OpGraph -> Intents -> Intents +snapshot d (g,f,_) hist = + let nodes = fmap f (Graph.vertices g) -- graph nodes + mkPair (p,i,_) = (i, (OpIntent d p)) -- new OpIntent from a node in the OpGraph + s = Map.fromList (fmap mkPair nodes) -- new OpIntents to merge + t _ snap stream = Just $ Cons snap stream -- Stream concatenation on values + in Map.mergeWithKey t (fmap pure) id s hist -- merge the new snapshot (generalized update) + +-- | Returns an operation to atomically build a status map from a graph +-- snapshot. +makeStatusesMap :: Intents -> STM OpStatusesMap +makeStatusesMap intents = + let (Cons snap _) = snapshots intents + in Map.fromList <$> traverse mkPair (Map.toList snap) + where + mkPair :: (OpUniqueId, OpIntent) -> STM (OpUniqueId, TVar OpStatus) + mkPair (oid, intent) = do + let dir = view intentDirection intent + tvar <- newTVar (newOpStatus dir) + return (oid,tvar) + newOpStatus :: WantedDirection -> OpStatus + newOpStatus dir = OpStatus Unknown dir Transient + +adjustTVar' :: TVar a -> (a -> a) -> STM (a, a) +adjustTVar' t f = do + x <- readTVar t + let !y = f x + writeTVar t y + return (x, y) +