deptrack-devops (empty) → 0.1.0.0
raw patch · 10 files changed
+1304/−0 lines, 10 filesdep +arraydep +asyncdep +basesetup-changed
Dependencies added: array, async, base, base64-bytestring, binary, bytestring, containers, deptrack-core, distributed-closure, dotgen, hashable, lens, mtl, safe, stm, text
Files
- ChangeLog.md +3/−0
- LICENSE +201/−0
- README.md +8/−0
- Setup.hs +2/−0
- deptrack-devops.cabal +41/−0
- src/Devops/Actions.hs +129/−0
- src/Devops/Base.hs +242/−0
- src/Devops/Cli.hs +193/−0
- src/Devops/Constraints.hs +20/−0
- src/Devops/Graph.hs +465/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for deptrack-devops++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deptrack-devops.cabal view
@@ -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
+ src/Devops/Actions.hs view
@@ -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")]+
+ src/Devops/Base.hs view
@@ -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
+ src/Devops/Cli.hs view
@@ -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
+ src/Devops/Constraints.hs view
@@ -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
+ src/Devops/Graph.hs view
@@ -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)+