packages feed

groot (empty) → 0.0.1.0

raw patch · 54 files changed

+5125/−0 lines, 54 filesdep +QuickCheckdep +aesondep +amazonkasetup-changed

Dependencies added: QuickCheck, aeson, amazonka, amazonka-autoscaling, amazonka-core, amazonka-ec2, amazonka-ecs, ansi-terminal, attoparsec, base, bytestring, checkers, conduit, conduit-combinators, directory, exceptions, free, groot, hashable, hspec, http-conduit, http-types, ini, lens, lifted-base, mmorph, monad-control, mtl, optparse-applicative, pptable, prettyprinter, prettyprinter-ansi-terminal, prettyprinter-compat-ansi-wl-pprint, quickcheck-text, resourcet, stm, stm-chans, stm-conduit, stm-delay, text, these, time, transformers, unordered-containers, uuid, vector, yaml

Files

+ LICENSE view
@@ -0,0 +1,202 @@++                                 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 2017 Antonio Alonso Dominguez++   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,74 @@+# Groot++[![Build Status](https://travis-ci.org/alonsodomin/groot.svg?branch=master)](https://travis-ci.org/alonsodomin/groot)+[![Build status](https://ci.appveyor.com/api/projects/status/lljwg88fygttb28i?svg=true)](https://ci.appveyor.com/project/alonsodomin/groot)++Groot is a command line application with the purpose of remote managing AWS ECS Clusters and+ their associated resources (Tasks, Instances, Services, etc.)++## Installing++Head over to the [Releases](https://github.com/alonsodomin/groot/releases) and download the binaries for your OS. There are+ pre-built binaries for 64bits Linux, Mac OS and Windows. It gets downloaded as a single binary file, copy into your own machine+ and place it in a folder under your `PATH` environment variable.++For example, for Linux machines:++```+wget -O groot https://github.com/alonsodomin/groot/releases/download/v0.0.1.0/groot-linux+mv groot /usr/local/bin/+```++A more user friendly install process in on the works, someday I could get around to actually finish it.++## Building From Source++You will need [Stack](http://haskellstack.org) installed in your local machine. Once you´ve got that, then clone this+ repository and install the binaries using Stack:++```+git clone https://github.com/alonsodomin/groot+cd groot+stack install+```++Now step back, the whole of The Internet is going to be sucked into your machine.++## First Steps++Now that you have it installed in your system, run it with the `-h` (or `--help`) command line+ option to get an idea of what you can do.++```+groot -h+```++Groot supports several sub-commands, use the same `-h` flag to get some help on what they can do,+ i.e.: `groot ls tasks -h`.++## Status++Groot is a toy project started to further my knowledge of the Haskell programming language+ at the same time that I was solving a need for a proper tool to perform my most rutinary+ tasks when managing ECS resources.++Don't expect here the best Haskell code (and I should probably write more tests), if it serves+ you then great, use it and feel free to contribute.++## License++### Apache License 2.0++Copyright 2017 Antonio Alonso Dominguez++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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import           Groot.CLI++main :: IO ()+main = grootCli
+ groot.cabal view
@@ -0,0 +1,222 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: e05a1c100a151e6a19924074a2dd3c2af7bfb16858777ff584cd99deddafa3ab++name:           groot+version:        0.0.1.0+synopsis:       Command line utility to manage AWS ECS resources+description:    `groot` is a command line application with the purpose of remote managing AWS ECS Clusters and their associated resources (Tasks, Instances, Services, etc.)+category:       AWS,Cloud+homepage:       https://github.com/alonsodomin/groot#readme+bug-reports:    https://github.com/alonsodomin/groot/issues+author:         A. Alonso Dominguez+maintainer:     alonso.domin@gmail.com+copyright:      2017 A. Alonso Dominguez+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/alonsodomin/groot++library+  exposed-modules:+      Groot.CLI+      Groot.Console+      Groot.Data.Text+      Groot.Types+  other-modules:+      Groot.AWS+      Groot.AWS.Cluster+      Groot.AWS.Instance+      Groot.AWS.Service+      Groot.AWS.Task+      Groot.AWS.TaskDef+      Groot.CLI.Cluster+      Groot.CLI.Cluster.Events+      Groot.CLI.Cluster.Inspect+      Groot.CLI.Common+      Groot.CLI.List+      Groot.CLI.List.Cluster+      Groot.CLI.List.Common+      Groot.CLI.List.ContainerInstance+      Groot.CLI.List.ContainerService+      Groot.CLI.List.Task+      Groot.CLI.List.TaskDef+      Groot.CLI.Service+      Groot.CLI.Service.Compose+      Groot.CLI.Service.Events+      Groot.CLI.Service.Inspect+      Groot.Compose+      Groot.Compose.Service+      Groot.Compose.Service.AWS+      Groot.Compose.Service.DryRun+      Groot.Compose.Service.Free+      Groot.Config+      Groot.Core+      Groot.Core.Common+      Groot.Core.Events+      Groot.Data.Conduit.STM+      Groot.Data.Filter+      Groot.Data.Text.Display+      Groot.Data.Text.Styled+      Groot.Exception+      Groot.Exception.Cluster+      Groot.Exception.Instance+      Groot.Exception.Service+      Groot.Exception.Task+      Groot.Exception.TaskDef+      Groot.Internal.PrettyPrint+      Groot.Manifest+      Paths_groot+  hs-source-dirs:+      src+  build-depends:+      aeson+    , amazonka >=1.5.0 && <1.6+    , amazonka-autoscaling+    , amazonka-core+    , amazonka-ec2+    , amazonka-ecs+    , ansi-terminal+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , conduit+    , conduit-combinators+    , directory+    , exceptions+    , free+    , hashable+    , http-conduit+    , http-types+    , ini+    , lens+    , lifted-base+    , mmorph+    , monad-control+    , mtl >=2.2 && <2.3+    , optparse-applicative+    , pptable+    , prettyprinter+    , prettyprinter-ansi-terminal+    , prettyprinter-compat-ansi-wl-pprint+    , resourcet+    , stm+    , stm-chans+    , stm-conduit+    , stm-delay+    , text+    , these+    , time+    , transformers+    , unordered-containers+    , uuid+    , vector+    , yaml >=0.8.20 && <0.9+  default-language: Haskell2010++executable groot+  main-is: Main.hs+  other-modules:+      Paths_groot+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , amazonka >=1.5.0 && <1.6+    , amazonka-autoscaling+    , amazonka-core+    , amazonka-ec2+    , amazonka-ecs+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , conduit+    , conduit-combinators+    , directory+    , exceptions+    , free+    , groot+    , hashable+    , http-conduit+    , http-types+    , lens+    , lifted-base+    , mmorph+    , monad-control+    , mtl >=2.2 && <2.3+    , resourcet+    , stm+    , stm-chans+    , stm-conduit+    , stm-delay+    , text+    , these+    , time+    , transformers+    , unordered-containers+    , uuid+    , vector+    , yaml >=0.8.20 && <0.9+  default-language: Haskell2010++test-suite groot-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Groot.Console+      Test.Groot.Types+      Paths_groot+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , amazonka >=1.5.0 && <1.6+    , amazonka-autoscaling+    , amazonka-core+    , amazonka-ec2+    , amazonka-ecs+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , checkers+    , conduit+    , conduit-combinators+    , directory+    , exceptions+    , free+    , groot+    , hashable+    , hspec+    , http-conduit+    , http-types+    , lens+    , lifted-base+    , mmorph+    , monad-control+    , mtl >=2.2 && <2.3+    , quickcheck-text+    , resourcet+    , stm+    , stm-chans+    , stm-conduit+    , stm-delay+    , text+    , these+    , time+    , transformers+    , unordered-containers+    , uuid+    , vector+    , yaml >=0.8.20 && <0.9+  default-language: Haskell2010
+ src/Groot/AWS.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.AWS+     (+       module Groot.AWS.Cluster+     , module Groot.AWS.Instance+     , module Groot.AWS.Service+     , module Groot.AWS.Task+     , module Groot.AWS.TaskDef+     -- Error handlers+     , handleHttpException+     , handleServiceError+     ) where++import           Control.Lens+import           Data.Semigroup            ((<>))+import qualified Data.Text                 as T+import           Network.AWS+import           Network.HTTP.Conduit+import           Network.HTTP.Types.Status++import           Groot.AWS.Cluster+import           Groot.AWS.Instance+import           Groot.AWS.Service+import           Groot.AWS.Task+import           Groot.AWS.TaskDef+import           Groot.Console+import           Groot.Data.Text++-- AWS Error handlers++handleHttpException :: MonadConsole m => HttpException -> m ()+handleHttpException (InvalidUrlException url reason) =+  putError $ "Url " <> (styled yellowStyle $ toText url) <> " is invalid due to: " <> (styled redStyle $ toText reason)+handleHttpException (HttpExceptionRequest req _) =+  putError $ "Could not communicate with " <> (styled yellowStyle $ toText . host $ req) <> "."++handleServiceError :: MonadConsole m => ServiceError -> m ()+handleServiceError err =+  let servName  = toText $ err ^. serviceAbbrev+      statusMsg = toText . statusMessage $ err ^. serviceStatus+      message   = maybe "" toText $ err ^. serviceMessage+      styledSt  = styled yellowStyle (T.concat [servName, " ", statusMsg])+  in putError $ styledSt <+> (styleless message)
+ src/Groot/AWS/Cluster.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TypeFamilies #-}++module Groot.AWS.Cluster+     ( clusterName+     , clusterExists+     , fetchClusters+     , findCluster+     , getCluster+     , handleClusterNotFoundException+     , taskCluster+     , serviceCluster+     ) where++import           Control.Lens+import           Control.Monad.Catch+import           Control.Monad.Trans.Maybe+import           Data.Conduit+import qualified Data.Conduit.List         as CL+import           Data.Maybe                (isJust, listToMaybe)+import           Network.AWS+import qualified Network.AWS.ECS           as ECS++import           Groot.Data.Text+import           Groot.Exception+import           Groot.Types++-- |Extracts the cluster name as a 'ClusterRef'+clusterName :: ECS.Cluster -> Maybe ClusterRef+clusterName cluster = ClusterRef <$> cluster ^. ECS.cClusterName++-- |Checks whether the given cluster reference is pointing to an existing cluster+clusterExists :: MonadAWS m => ClusterRef -> m Bool+clusterExists clusterRef = isJust <$> (runMaybeT $ findCluster clusterRef)++-- |Obtains the cluster details of a given task+taskCluster :: MonadAWS m => ECS.Task -> MaybeT m ECS.Cluster+taskCluster tsk = do+  arn <- MaybeT . return $ ClusterRef <$> tsk ^. ECS.tClusterARN+  getCluster arn++-- |Obtains the cluster details of a given service+serviceCluster :: MonadAWS m => ECS.ContainerService -> MaybeT m ECS.Cluster+serviceCluster service = do+  arn <- MaybeT . return $ ClusterRef <$> service ^. ECS.csClusterARN+  getCluster arn++-- |Translates an AWS 'ClusterNotFoundException' into a Groot's 'ClusterNotFound'+handleClusterNotFoundException :: MonadCatch m => ClusterRef -> m a -> m a+handleClusterNotFoundException clusterRef action =+  catching ECS._ClusterNotFoundException action $ \_ -> throwM $ clusterNotFound clusterRef++fetchClusters' :: MonadAWS m => [ClusterRef] -> m [ECS.Cluster]+fetchClusters' []          = return []+fetchClusters' clusterRefs = do+  res <- send $ ECS.dcClusters .~ (toText <$> clusterRefs) $ ECS.describeClusters+  return $ res ^. ECS.dcrsClusters++-- |Builds a Conduit with all the clusters available+fetchClusters :: MonadAWS m => Source m ECS.Cluster+fetchClusters =+  paginate ECS.listClusters+    =$= CL.concatMapM (\x -> fetchClusters' (ClusterRef <$> x ^. ECS.lcrsClusterARNs))++-- |Tries to find a given cluster by its reference+findCluster :: MonadAWS m => ClusterRef -> MaybeT m ECS.Cluster+findCluster ref = MaybeT $ listToMaybe <$> fetchClusters' [ref]++-- |Same as 'findCluster' but it will throw a 'ClusterNotFound' in the Monad 'm'+-- in case the cluster does not exist+getCluster :: MonadAWS m => ClusterRef -> m ECS.Cluster+getCluster clusterRef = do+  cluster <- runMaybeT $ findCluster clusterRef+  case cluster of+    Just c  -> return c+    Nothing -> throwM $ clusterNotFound clusterRef
+ src/Groot/AWS/Instance.hs view
@@ -0,0 +1,85 @@+module Groot.AWS.Instance+     ( fetchInstances+     , fetchAllInstances+     , findInstances+     , findInstance+     , getInstance+     , taskInstance+     -- EC2 instances+     , findEc2Instances+     ) where++import           Control.Lens+import           Control.Monad.Catch+import           Control.Monad.Trans.Maybe+import           Data.Conduit+import qualified Data.Conduit.List         as CL+import           Network.AWS+import qualified Network.AWS.EC2           as EC2+import qualified Network.AWS.ECS           as ECS++import           Groot.AWS.Cluster+import           Groot.Data.Text+import           Groot.Exception+import           Groot.Types++-- |Obtains the instance of a given task+taskInstance :: MonadAWS m => ECS.Task -> MaybeT m ECS.ContainerInstance+taskInstance tsk = do+  clusterArn  <- MaybeT . return $ ClusterRef <$> tsk ^. ECS.tClusterARN+  instanceArn <- MaybeT . return $ ContainerInstanceRef <$> tsk ^. ECS.tContainerInstanceARN+  getInstance instanceArn (Just clusterArn)++fetchInstanceBatch :: MonadAWS m => [ContainerInstanceRef] -> ClusterRef -> m [ECS.ContainerInstance]+fetchInstanceBatch []           _          = return []+fetchInstanceBatch instanceRefs clusterRef =+  let fetch = do+        res <- send $ ECS.dciCluster ?~ (toText clusterRef)+               $ ECS.dciContainerInstances .~ (toText <$> instanceRefs)+               $ ECS.describeContainerInstances+        return $ res ^. ECS.dcisrsContainerInstances+  in handleClusterNotFoundException clusterRef fetch++-- |Builds a Conduit with all the task instances in a given cluster+fetchInstances :: MonadAWS m => ClusterRef -> Source m ECS.ContainerInstance+fetchInstances cref@(ClusterRef ref) =+  handleClusterNotFoundException cref (paginate (ECS.lciCluster ?~ ref $ ECS.listContainerInstances))+    =$= CL.concatMapM (\x -> fetchInstanceBatch (ContainerInstanceRef <$> x ^. ECS.lcirsContainerInstanceARNs) cref)++fetchInstancesC :: MonadAWS m => [ContainerInstanceRef] -> Conduit ClusterRef m ECS.ContainerInstance+fetchInstancesC instances =+  awaitForever (\cref -> yieldM $ fetchInstanceBatch instances cref) =$= CL.concat++-- |Builds a Conduit with all the task instances from all the clusters+fetchAllInstances :: MonadAWS m => Source m ECS.ContainerInstance+fetchAllInstances =+  let fetchAllInstancesC = awaitForever (\cref -> toProducer $ fetchInstances cref)+  in fetchClusters+     =$= CL.mapMaybe clusterName+     =$= fetchAllInstancesC++-- |Efficiently obtain all task instances whilst filtering a given cluster reference+-- or a set of instance references+findInstances :: MonadAWS m => [ContainerInstanceRef] -> Maybe ClusterRef -> Source m ECS.ContainerInstance+findInstances instances (Just clusterRef) =+  yield clusterRef =$= fetchInstancesC instances+findInstances instances _ =+  fetchClusters =$= CL.mapMaybe clusterName =$= fetchInstancesC instances++-- |Same as 'findInstances' but for a single instance reference+findInstance :: MonadAWS m => ContainerInstanceRef -> Maybe ClusterRef -> MaybeT m ECS.ContainerInstance+findInstance iref cref = MaybeT . runConduit $ findInstances [iref] cref =$= CL.head++-- |Same as 'findInstance' but will throw an 'InstanceNotFound' in the monad 'm'+-- in case the given instance reference does not exist+getInstance :: MonadAWS m => ContainerInstanceRef -> Maybe ClusterRef -> m ECS.ContainerInstance+getInstance iref cref = do+  inst <- runMaybeT $ findInstance iref cref+  case inst of+    Just x  -> return x+    Nothing -> throwM $ instanceNotFound iref cref++findEc2Instances :: MonadAWS m => [EC2InstanceId] -> Source m EC2.Instance+findEc2Instances ids = paginate (EC2.diiInstanceIds .~ (toText <$> ids) $ EC2.describeInstances)+  =$= CL.concatMap (\x -> x ^. EC2.dirsReservations)+  =$= CL.concatMap (\x -> x ^. EC2.rInstances)
+ src/Groot/AWS/Service.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}++module Groot.AWS.Service+     (+       serviceCoords+     , serviceTaskDefArn+     , findServices+     , findService+     , findServiceCoords+     , getService+     , fetchServices+     , fetchAllServices+     ) where++import           Control.Lens+import           Control.Monad+import           Control.Monad.Catch+import           Control.Monad.Trans.Maybe+import           Data.Conduit+import qualified Data.Conduit.List         as CL+import           Data.Maybe                (listToMaybe)+import           Network.AWS               hiding (await)+import           Network.AWS.Data.Text+import qualified Network.AWS.ECS           as ECS++import           Groot.AWS.Cluster+import           Groot.Data.Filter+import           Groot.Exception+import           Groot.Types++serviceCoords :: ECS.ContainerService -> Maybe ContainerServiceCoords+serviceCoords service = ContainerServiceCoords <$> serviceRef <*> clusterRef+  where serviceRef = ContainerServiceRef <$> service ^. ECS.csServiceARN+        clusterRef = ClusterRef          <$> service ^. ECS.csClusterARN++serviceTaskDefArn :: ECS.ContainerService -> Maybe TaskDefArn+serviceTaskDefArn service = join $ (either (\_ -> Nothing) Just . fromText) <$> service ^. ECS.csTaskDefinition++findServiceCoords :: (MonadAWS m, Traversable t)+                  => t ContainerServiceRef+                  -> m (t ContainerServiceCoords)+findServiceCoords = traverse singleServiceCoords+  where singleServiceCoords :: MonadAWS m => ContainerServiceRef -> m ContainerServiceCoords+        singleServiceCoords serviceRef = do+          mcoords <- serviceCoords <$> getService serviceRef Nothing+          case mcoords of+            Just c  -> return c+            Nothing -> throwM $ serviceNotFound serviceRef Nothing++fetchServiceBatch :: MonadAWS m => [ContainerServiceRef] -> ClusterRef -> m [ECS.ContainerService]+fetchServiceBatch []       _    = return []+fetchServiceBatch services cref =+  let fetch = do+        res <- send $ ECS.dCluster ?~ (toText cref)+               $ ECS.dServices .~ (toText <$> services)+               $ ECS.describeServices+        return $ res ^. ECS.dssrsServices+  in handleClusterNotFoundException cref fetch++fetchServices :: MonadAWS m => ClusterRef -> Source m ECS.ContainerService+fetchServices clusterRef =+  handleClusterNotFoundException clusterRef (paginate (ECS.lsCluster ?~ (toText clusterRef) $ ECS.listServices))+    =$= CL.concatMapM (\x -> fetchServiceBatch (ContainerServiceRef <$> x ^. ECS.lsrsServiceARNs) clusterRef)++fetchAllServices :: MonadAWS m => Source m ECS.ContainerService+fetchAllServices = fetchClusters+  =$= CL.mapMaybe clusterName+  =$= fetchAllServicesC++fetchServicesC' :: MonadAWS m+                => [ContainerServiceRef]+                -> Conduit ClusterRef m (ClusterRef, ECS.ContainerService)+fetchServicesC' services =+  awaitForever (\cref -> yieldM $ do+    servs <- fetchServiceBatch services cref+    return $ map ((,) cref) servs+  ) =$= CL.concat++fetchAllServicesC :: MonadAWS m => Conduit ClusterRef m ECS.ContainerService+fetchAllServicesC = awaitForever (\cref -> toProducer $ fetchServices cref)++findServices' :: MonadAWS m+              => [ContainerServiceRef]+              -> Maybe ClusterRef+              -> Source m (ClusterRef, ECS.ContainerService)+findServices' services (Just clusterRef) =+  yield clusterRef =$= fetchServicesC' services+findServices' services _ =+  fetchClusters =$= CL.mapMaybe clusterName =$= fetchServicesC' services++findServices :: MonadAWS m+             => [ContainerServiceRef]+             -> Maybe ClusterRef+             -> Source m ECS.ContainerService+findServices services cref = findServices' services cref =$= CL.map snd++findService :: MonadAWS m+            => ContainerServiceRef+            -> Maybe ClusterRef+            -> MaybeT m ECS.ContainerService+findService sref cref = MaybeT $ extractRequested cref+  where extractRequested (Just _) =+          runConduit $ findServices' [sref] cref =$= CL.map snd =$= CL.head+        extractRequested _ = do+          found <- sourceToList $ findServices' [sref] Nothing+                   =$= filterOnC snd (isContainerService sref)+          if (length found) > 1+          then throwM $ ambiguousServiceName sref (fst <$> found)+          else return $ snd <$> listToMaybe found++getService :: MonadAWS m+           => ContainerServiceRef+           -> Maybe ClusterRef+           -> m ECS.ContainerService+getService serviceName clusterRef = do+  serv <- runMaybeT $ findService serviceName clusterRef+  case serv of+    Just x  -> return x+    Nothing -> throwM $ serviceNotFound serviceName clusterRef
+ src/Groot/AWS/Task.hs view
@@ -0,0 +1,74 @@+module Groot.AWS.Task+     (+       fetchTasks+     , fetchAllTasks+     , fetchServiceTasks+     , findTasks+     , findTask+     , getTask+     ) where++import           Control.Lens+import           Control.Monad.Catch+import           Control.Monad.Trans.Maybe+import           Data.Conduit+import qualified Data.Conduit.List         as CL+import           Network.AWS+import           Network.AWS.Data.Text+import qualified Network.AWS.ECS           as ECS++import           Groot.AWS.Cluster+import           Groot.Exception+import           Groot.Types++fetchTaskBatch :: MonadAWS m => [TaskRef] -> ClusterRef -> m [ECS.Task]+fetchTaskBatch []       _          = return []+fetchTaskBatch taskRefs clusterRef =+  let fetch = do+        res <- send $ ECS.dtCluster ?~ (toText clusterRef)+               $ ECS.dtTasks .~ (toText <$> taskRefs)+               $ ECS.describeTasks+        return $ res ^. ECS.dtrsTasks+  in handleClusterNotFoundException clusterRef fetch++fetchTasksC :: MonadAWS m => [TaskRef] -> Conduit ClusterRef m ECS.Task+fetchTasksC tasks = awaitForever (\cref -> yieldM $ fetchTaskBatch tasks cref) =$= CL.concat++fetchTasks :: MonadAWS m => ClusterRef -> Source m ECS.Task+fetchTasks cref@(ClusterRef ref) =+  handleClusterNotFoundException cref (paginate (ECS.ltCluster ?~ ref $ ECS.listTasks))+    =$= CL.concatMapM (\x -> fetchTaskBatch (TaskRef <$> x ^. ECS.ltrsTaskARNs) cref)++fetchAllTasks :: MonadAWS m => Source m ECS.Task+fetchAllTasks =+  let fetchAllTasksC = awaitForever (\cref -> toProducer $ fetchTasks cref)+  in fetchClusters+     =$= CL.mapMaybe clusterName+     =$= fetchAllTasksC++findTasks :: MonadAWS m => [TaskRef] -> Maybe ClusterRef -> Source m ECS.Task+findTasks tasks (Just clusterRef) =+  yield clusterRef =$= fetchTasksC tasks+findTasks tasks _ =+  fetchClusters =$= CL.mapMaybe clusterName =$= fetchTasksC tasks++findTask :: MonadAWS m => TaskRef -> Maybe ClusterRef -> MaybeT m ECS.Task+findTask tref cref = MaybeT . runConduit $ findTasks [tref] cref =$= CL.head++getTask :: MonadAWS m => TaskRef -> Maybe ClusterRef -> m ECS.Task+getTask tref cref = do+  t <- runMaybeT $ findTask tref cref+  case t of+    Just x  -> return x+    Nothing -> throwM $ taskNotFound tref cref++fetchServiceTasks :: MonadAWS m => Maybe ClusterRef -> ContainerServiceRef -> Source m ECS.Task+fetchServiceTasks Nothing sref =+  fetchClusters+    =$= CL.mapMaybe clusterName+    =$= awaitForever (\c -> toProducer $ fetchServiceTasks (Just c) sref)+fetchServiceTasks (Just cref@(ClusterRef cluster)) (ContainerServiceRef service) =+  catching ECS._ServiceNotFoundException tasks $ \_ -> CL.sourceNull+  where tasks = paginate (ECS.ltCluster ?~ cluster $ ECS.ltServiceName ?~ service $ ECS.listTasks)+                =$= CL.map (\x -> TaskRef <$> x ^. ECS.ltrsTaskARNs)+                =$= awaitForever (\ts -> toProducer $ findTasks ts (Just cref))
+ src/Groot/AWS/TaskDef.hs view
@@ -0,0 +1,40 @@+module Groot.AWS.TaskDef where++import           Control.Lens+import           Control.Monad.Trans.Maybe+import           Data.Conduit+import qualified Data.Conduit.List         as CL+import           Network.AWS+import qualified Network.AWS.ECS           as ECS++import           Groot.Types++taskDefId :: ECS.TaskDefinition -> Maybe TaskDefId+taskDefId taskDef = TaskDefId <$> (TaskFamily <$> taskDef ^. ECS.tdFamily) <*> (taskDef ^. ECS.tdRevision)++getTaskDef :: MonadAWS m => TaskDefRef -> MaybeT m ECS.TaskDefinition+getTaskDef (TaskDefRef arn) =+  catching _ServiceError readTaskDef $ \_ -> MaybeT (pure Nothing)+  where readTaskDef = MaybeT $ do+          res <- send $ ECS.describeTaskDefinition arn+          return $ res ^. ECS.desrsTaskDefinition++taskDefFromTask :: MonadAWS m => ECS.Task -> MaybeT m ECS.TaskDefinition+taskDefFromTask tsk = do+  arn <- MaybeT . return $ TaskDefRef <$> tsk ^. ECS.tTaskDefinitionARN+  getTaskDef arn++fetchTaskDefs :: (MonadAWS m, Foldable f) => f TaskDefFilter -> Source m ECS.TaskDefinition+fetchTaskDefs filters =+  let tds :: TaskDefStatus -> ECS.TaskDefinitionStatus+      tds TDSActive   = ECS.TDSActive+      tds TDSInactive = ECS.TDSInactive++      withFilter :: TaskDefFilter -> ECS.ListTaskDefinitions -> ECS.ListTaskDefinitions+      withFilter (TDFFamily (TaskFamily f)) = ECS.ltdFamilyPrefix ?~ f+      withFilter (TDFStatus s)              = ECS.ltdStatus ?~ (tds s)++  in paginate (foldr withFilter ECS.listTaskDefinitions filters)+     =$= CL.concatMap (view ECS.ltdrsTaskDefinitionARNs)+     =$= CL.map TaskDefRef+     =$= CL.mapMaybeM (\x -> runMaybeT (getTaskDef x))
+ src/Groot/CLI.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++{-|+Module      : Groot.CLI+Description : Command Line Interface for Groot+Copyright   : A. Alonso Dominguez (c) 2017, http://github.com/alonsodomin+License     : Apache 2.0+Maintainer  : A. Alonso Dominguez <alonso.domin (λ) google>+Stability   : experimental+Portability : portable++This is the main application module, application's 'main' function hooks into this+via the 'grootCli' function and applications interested on embedding some of Groot's+features can use some of the more fain grained functions exposed via this module.+-}+module Groot.CLI+     ( GrootOpts+     , GrootCmd+     , CredentialsOpt+     , loadEnv+     , grootOpts+     , grootCli+     , evalCmd+     ) where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Maybe+import           Data.Semigroup             ((<>))+import           Data.String+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Data.Version               (showVersion)+import           Network.AWS                hiding (Debug)+import qualified Network.AWS                as AWS+import           Options.Applicative+import           Paths_groot                (version)+import           System.IO++import           Groot.CLI.Cluster+import           Groot.CLI.Common+import           Groot.CLI.List+import           Groot.CLI.Service+import           Groot.Config+import           Groot.Console+import           Groot.Core+import           Groot.Data.Text+import           Groot.Exception+import           Groot.Manifest++data CredentialsOpt =+    ProfileOpt (Maybe Text) (Maybe FilePath)+  | KeysOpt AccessKey SecretKey+  deriving Eq++credsOpt :: Parser CredentialsOpt+credsOpt =+  let profile = T.pack <$> strOption+                ( long "profile"+                <> short 'p'+                <> metavar "AWS_PROFILE"+                <> help "AWS Profile" )+      accessKey = (AccessKey . fromString) <$> strOption+                  ( long "accessKey"+                  <> metavar "ACCESS_KEY"+                  <> help "AWS Access Key" )+      secretKey = (SecretKey . fromString) <$> strOption+                  ( long "secretKey"+                  <> metavar "SECRET_KEY"+                  <> help "AWS Secret Key" )+      file = strOption+              ( long "creds"+            <> metavar "CRENDENTIALS_FILE"+            <> help "AWS Credentials config file" )+  in let fromProfile = ProfileOpt <$> (optional profile) <*> (optional file)+         fromKeys    = KeysOpt <$> accessKey <*> secretKey+      in fromKeys <|> fromProfile++regionOpt :: Parser Region+regionOpt = option (attoReadM parser)+          ( long "region"+          <> short 'r'+          <> metavar "AWS_REGION"+          <> help "AWS Region identifier" )++versionInfo :: String+versionInfo = "groot " ++ (showVersion version)++versionOpt :: Parser (a -> a)+versionOpt = infoOption versionInfo $ mconcat [+    long "version"+  , short 'v'+  , help "Show version number"+  ]++-- |Top level Groot commands+data GrootCmd =+    ClusterCmd ClusterSubCmd+  | ListCmd ListSubCmd+  | ServiceCmd ServiceSubCmd+  deriving (Eq, Show)++-- |Groot options for a given execution+data GrootOpts = GrootOpts+  { _grootCreds  :: CredentialsOpt+  , _grootRegion :: Maybe Region+  , _grootDebug  :: Bool+  , _grootCmd    :: GrootCmd+  } deriving Eq++makeLenses ''GrootOpts++commands :: Parser GrootCmd+commands = hsubparser+   ( command "ls"      (info (ListCmd    <$> listCmds)    (progDesc "List ECS resources"))+  <> command "cluster" (info (ClusterCmd <$> clusterCmds) (progDesc "Perform cluster related operations"))+  <> command "service" (info (ServiceCmd <$> serviceCmds) (progDesc "Perform service related operations"))+  -- <> command "task"    (info (TaskCmd    <$> grootTaskCli)    (progDesc "Manage ECS tasks"))+    )++-- |Command line parser for all the possible Groot options+grootOpts :: Parser GrootOpts+grootOpts = ( GrootOpts+          <$> credsOpt+          <*> optional regionOpt+          <*> switch+            ( long "debug"+           <> help "Enable debug mode when running" )+          <*> commands+          ) <**> versionOpt++-- | Generates the AWS Env from the command line options+loadEnv :: GrootOpts -> IO Env+loadEnv opts = do+  configFile       <- defaultConfigFile+  (creds, profile) <- buildCreds $ opts ^. grootCreds+  env              <- newEnv creds+  setupLogger =<< assignRegion (findRegion configFile profile) env+    where buildCreds :: CredentialsOpt -> IO (Credentials, Maybe Text)+          buildCreds (ProfileOpt profile file) = do+            profileName <- return $ maybe defaultSectionName id profile+            credsFile   <- maybe defaultCredsFile return file+            return (FromFile profileName credsFile, Just profileName)+          buildCreds (KeysOpt accessKey secretKey) =+            return (FromKeys accessKey secretKey, Nothing)++          findRegion :: FilePath -> Maybe Text -> MaybeT IO Region+          findRegion confFile profile = regionFromOpts <|> regionFromCfg+            where regionFromOpts :: MaybeT IO Region+                  regionFromOpts = MaybeT . return $ opts ^. grootRegion++                  regionFromCfg :: MaybeT IO Region+                  regionFromCfg = MaybeT $ do+                    reg <- runExceptT $ regionFromConfig confFile profile+                    case reg of+                      Left err -> do+                        putWarn $ T.pack err+                        return Nothing+                      Right r -> return (Just r)++          assignRegion :: MaybeT IO Region -> Env -> IO Env+          assignRegion r env = do+            maybeRegion <- runMaybeT r+            return $ maybe id (\x -> envRegion .~ x) maybeRegion env++          setupLogger :: Env -> IO Env+          setupLogger env = if opts ^. grootDebug+            then do+              lgr <- newLogger AWS.Debug stdout+              return $ env & envLogger .~ lgr+            else return env++-- Groot Error handlers++handleClusterNotFound :: ClusterNotFound -> IO ()+handleClusterNotFound (ClusterNotFound' clusterRef) =+  putError $ "Could not find cluster " <> (styled yellowStyle $ toText clusterRef)++handleInvalidClusterStatus :: InvalidClusterStatus -> IO ()+handleInvalidClusterStatus (InvalidClusterStatus' clusterRef currentSt desiredSt) =+  putError $ "Can't operate on cluster " <> (styled yellowStyle $ toText clusterRef)+    <> " because it is " <> (styled redStyle $ toText currentSt)+    <> maybe "." (\x -> ", it should be " <> (styled greenStyle $ toText x) <> " to continue.") desiredSt++handleServiceNotFound :: ServiceNotFound -> IO ()+handleServiceNotFound (ServiceNotFound' serviceRef clusterRef) =+  putError $ "Could not find service " <> (styled yellowStyle $ toText serviceRef) <>+    maybe "" (\x -> " in cluster " <> (styled yellowStyle $ toText x)) clusterRef++handleAmbiguousServiceName :: AmbiguousServiceName -> IO ()+handleAmbiguousServiceName (AmbiguousServiceName' serviceRef clusters) =+  let stringifyClusters = styleless $ "\n - " <> (T.intercalate "\n - " $ toText <$> clusters)+  in putError $ "Service name " <> (styled yellowStyle $ toText serviceRef)+       <> " is ambiguous. It was found in the following clusters:" <> stringifyClusters++handleInactiveService :: InactiveService -> IO ()+handleInactiveService (InactiveService' serviceRef clusterRef) =+  putError $ "Service " <> (styled yellowStyle $ toText serviceRef) <> " in cluster "+    <> (styled yellowStyle $ toText $ clusterRef)+    <> " is not active."++handleTaskNotFound :: TaskNotFound -> IO ()+handleTaskNotFound (TaskNotFound' taskRef clusterRef) =+  putError $ "Could not find task " <> (styled yellowStyle $ toText taskRef) <>+    maybe "" (\x -> " in cluster " <> (styled yellowStyle $ toText x)) clusterRef++-- Main Program execution++handleExceptions :: IO () -> IO ()+handleExceptions act = catches act [+    handler _TransportError          handleHttpException+  , handler _ServiceError            handleServiceError+  , handler _ClusterNotFound         handleClusterNotFound+  , handler _InvalidClusterStatus    handleInvalidClusterStatus+  , handler _ServiceNotFound         handleServiceNotFound+  , handler _AmbiguousServiceName    handleAmbiguousServiceName+  , handler _InactiveService         handleInactiveService+  , handler _TaskNotFound            handleTaskNotFound+  , handler _ManifestParseError      handleManifestParseError+  ]++-- |Runs a Groot command with the given AWS environment+evalCmd :: GrootCmd -> GrootM IO ()+evalCmd (ClusterCmd opts) = runClusterCmd opts+evalCmd (ListCmd opts)    = runListCmd opts+evalCmd (ServiceCmd opts) = runServiceCmd opts+--evalCmd (TaskCmd opts)    = runGrootTask opts++-- |Groot main entry point from the Command line, able to interpret+-- arguments and parameters passed to it+grootCli :: IO ()+grootCli =+  prog =<< (execParser cli)+  where prog opts = do+          env <- loadEnv opts+          handleExceptions $ mainBlock (opts ^. grootCmd) env++        cli = info (grootOpts <**> helper)+          ( fullDesc+          <> progDesc "Utility to manage ECS Clusters"+          <> header "groot" )++        mainBlock cmd = runGroot (evalCmd cmd)
+ src/Groot/CLI/Cluster.hs view
@@ -0,0 +1,37 @@+module Groot.CLI.Cluster+     ( ClusterSubCmd+     , clusterCmds+     , runClusterCmd+     ) where++import           Data.Monoid+import           Options.Applicative++import           Groot.CLI.Cluster.Events+import           Groot.CLI.Cluster.Inspect+import           Groot.Core++data ClusterSubCmd =+    ClusterEventsCmd  ClusterEventOptions+  | ClusterInspectCmd ClusterInspectOpts+  deriving (Eq, Show)++-- CLI++clusterEventsCmd :: Parser ClusterSubCmd+clusterEventsCmd = ClusterEventsCmd <$> clusterEventsOpt++clusterInspectCmd :: Parser ClusterSubCmd+clusterInspectCmd = ClusterInspectCmd <$> clusterInspectOpts++clusterCmds :: Parser ClusterSubCmd+clusterCmds = hsubparser+  ( command "events"  (info clusterEventsCmd  (progDesc "Display events of the given clusters"))+ <> command "inspect" (info clusterInspectCmd (progDesc "Inspect details of a given cluster"))+  )++-- run function++runClusterCmd :: ClusterSubCmd -> GrootM IO ()+runClusterCmd (ClusterEventsCmd  eventsOpts)  = runClusterEvents  eventsOpts+runClusterCmd (ClusterInspectCmd inspectOpts) = runClusterInspect inspectOpts
+ src/Groot/CLI/Cluster/Events.hs view
@@ -0,0 +1,45 @@+module Groot.CLI.Cluster.Events+     ( ClusterEventOptions+     , clusterEventsOpt+     , runClusterEvents+     ) where++import           Control.Monad.Reader+import           Data.Conduit+import qualified Data.Conduit.List    as CL+import           Data.Semigroup       ((<>))+import           Data.String+import           Network.AWS+import           Options.Applicative++import           Groot.CLI.Common+import           Groot.Core+import           Groot.Core.Events+import           Groot.Types++data ClusterEventOptions = ClusterEventOptions+  { _follow       :: Bool+  , _eventCount   :: Int+  , _clusterNames :: [ClusterRef]+  } deriving (Eq, Show)++clusterRefArg :: Parser ClusterRef+clusterRefArg = fromString <$> argument str (metavar "CLUSTER_NAMES")++clusterEventsOpt :: Parser ClusterEventOptions+clusterEventsOpt = ClusterEventOptions+                <$> switch+                  ( long "follow"+                <> short 'f'+                <> help "Folow the trail of events" )+                <*> eventCountOpt+                <*> many clusterRefArg++runClusterEvents :: ClusterEventOptions -> GrootM IO ()+runClusterEvents (ClusterEventOptions follow lastN []) = do+  env <- ask+  clusterRefs <- runResourceT . runAWS env . sourceToList $ fetchClusters =$= CL.mapMaybe clusterName+  runClusterEvents (ClusterEventOptions follow lastN clusterRefs)+runClusterEvents (ClusterEventOptions follow lastN clusterRefs) = mapReaderT runResourceT $ do+  eventSource <- clusterServiceEventLog clusterRefs follow lastN+  runConduit $ eventSource =$ printEventSink
+ src/Groot/CLI/Cluster/Inspect.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.CLI.Cluster.Inspect+     ( ClusterInspectOpts+     , clusterInspectOpts+     , runClusterInspect+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import qualified Data.HashMap.Lazy          as Map+import           Data.Maybe+import           Data.Monoid+import           Data.String+import           Data.Text                  (Text)+import           Network.AWS+import qualified Network.AWS.EC2            as EC2+import qualified Network.AWS.ECS            as ECS+import           Options.Applicative        (Parser)+import qualified Options.Applicative        as Opts++import           Groot.Core+import           Groot.Internal.PrettyPrint (Doc, defaultIndent, (<+>))+import qualified Groot.Internal.PrettyPrint as Doc+import           Groot.Types++data InspectFlag =+  ShowInstanceAttrs+  deriving (Eq, Show)++showInstanceAttrsOpt :: Parser InspectFlag+showInstanceAttrsOpt = Opts.flag' ShowInstanceAttrs+                     ( Opts.long "show-instance-attrs"+                    <> Opts.help "displays instance attributes" )++inspectFlagOpts :: Parser [InspectFlag]+inspectFlagOpts = Opts.many showInstanceAttrsOpt++data ClusterInspectOpts = ClusterInspectOpts ClusterRef [InspectFlag]+  deriving (Eq, Show)++clusterInspectOpts :: Parser ClusterInspectOpts+clusterInspectOpts = ClusterInspectOpts+                  <$> clusterRefArg+                  <*> inspectFlagOpts++clusterRefArg :: Parser ClusterRef+clusterRefArg = fromString <$> Opts.argument Opts.str (Opts.metavar "CLUSTER_NAME")++pprintCluster :: ECS.Cluster -> [(ECS.ContainerInstance, Maybe EC2.Instance)] -> [InspectFlag] -> Doc+pprintCluster cluster nodes flags = Doc.vsep [+      Doc.bold . Doc.dullblue $ maybe mempty Doc.pretty $ cluster ^. ECS.cClusterName+    , Doc.indent defaultIndent (Doc.vsep $ catMaybes [+        Doc.field Doc.status "Status:" <$> cluster ^. ECS.cStatus+      , Doc.field' "Active Services:" <$> cluster ^. ECS.cActiveServicesCount+      , Doc.field' "Running Tasks:" <$> cluster ^. ECS.cRunningTasksCount+      , Doc.field' "Pending Tasks:" <$> cluster ^. ECS.cPendingTasksCount+      , Doc.listField ppInstance "Nodes:" nodes+    ])+  ]+  where showInstanceAttrs = elem ShowInstanceAttrs flags++        ppInstance :: (ECS.ContainerInstance, Maybe EC2.Instance) -> Doc+        ppInstance (ecsInst, ec2Inst) = Doc.vsep [+              Doc.bold . Doc.dullblue $ maybe mempty Doc.pretty $ ecsInst ^. ECS.ciEc2InstanceId+            , Doc.indent defaultIndent (Doc.vsep $ catMaybes [+                Doc.field Doc.status "Status:" <$> ecsInst ^. ECS.ciStatus+              , Doc.field' "Connected:" <$> ecsInst ^. ECS.ciAgentConnected+              , Doc.field' "Private IP:" <$> (ec2Inst >>= view EC2.insPrivateIPAddress)+              , Doc.field' "Running Tasks:" <$> ecsInst ^. ECS.ciRunningTasksCount+              , Doc.field' "Pending Tasks:" <$> ecsInst ^. ECS.ciPendingTasksCount+              , Doc.field Doc.defaultTime "Registered At:" <$> ecsInst ^. ECS.ciRegisteredAt+              , if showInstanceAttrs then Doc.listField ppInstanceAttr "Attributes:" $ ecsInst ^. ECS.ciAttributes+                else Nothing+            ])+          ]++        ppInstanceAttr :: ECS.Attribute -> Doc+        ppInstanceAttr attr = Doc.hsep $ catMaybes [+              Just (Doc.bold . Doc.dullblue . Doc.pretty $ attr ^. ECS.aName)+            , (\x -> Doc.pretty ("=" :: Text) <+> Doc.pretty x) <$> attr ^. ECS.aValue+          ]++runClusterInspect :: ClusterInspectOpts -> GrootM IO ()+runClusterInspect (ClusterInspectOpts clusterRef flags) = do+  env              <- ask++  (cluster, nodes) <- runResourceT . runAWS env $ do+    clus        <- getCluster clusterRef+    fromCluster <- runConduit $ fetchInstances clusterRef =$ CL.consume+    ids         <- pure $ fmap EC2InstanceId $ catMaybes $ (view ECS.ciEc2InstanceId) <$> fromCluster+    fromEc2     <- runConduit $ findEc2Instances ids =$ CL.consume+    return (clus, pairInstances fromCluster fromEc2)++  liftIO . Doc.putDoc $ pprintCluster cluster nodes flags++  where pairInstances :: [ECS.ContainerInstance] -> [EC2.Instance] -> [(ECS.ContainerInstance, Maybe EC2.Instance)]+        pairInstances ecsInsts ec2Insts =+          let ec2InstanceMap = Map.fromList $ (\x -> (x ^. EC2.insInstanceId, x)) <$> ec2Insts+          in fmap (\x -> (x, (flip Map.lookup) ec2InstanceMap =<< (x ^. ECS.ciEc2InstanceId))) ecsInsts
+ src/Groot/CLI/Common.hs view
@@ -0,0 +1,49 @@+module Groot.CLI.Common where++import qualified Data.Attoparsec.Text as A+import           Data.Semigroup       ((<>))+import           Data.String+import           Options.Applicative++import           Groot.Manifest       (defaultManifestFilePath)+import           Groot.Types          (ClusterRef (..),+                                       ContainerServiceRef (..),+                                       TaskFamily (..))++attoReadM :: A.Parser a -> ReadM a+attoReadM p = eitherReader (A.parseOnly p . fromString)++clusterOpt :: Parser ClusterRef+clusterOpt = fromString <$> strOption+            ( long "cluster"+          <> short 'c'+          <> metavar "CLUSTER_REF"+          <> help "ECS Cluster reference (name or ARN)" )++containerServiceOpt :: Parser ContainerServiceRef+containerServiceOpt = fromString <$> strOption+                    ( long "service"+                   <> short 's'+                   <> metavar "SERVICE_REF"+                   <> help "ECS Service reference (name or ARN)" )++taskFamilyOpt :: Parser TaskFamily+taskFamilyOpt = fromString <$> strOption+              ( long "family"+              <> metavar "TASK_FAMILY"+              <> help "ECS Task Family" )++eventCountOpt :: Parser Int+eventCountOpt = option auto+              ( long "number"+             <> short 'n'+             <> help "Number of events"+             <> showDefault+             <> value 25 )++manifestFileOpt :: Parser FilePath+manifestFileOpt = strOption+                ( long "file"+               <> short 'f'+               <> metavar "MANIFEST_FILE"+               <> help ("Groot manifest file (default: " ++ defaultManifestFilePath ++ ")" ))
+ src/Groot/CLI/List.hs view
@@ -0,0 +1,56 @@+module Groot.CLI.List+     ( ListSubCmd+     , listCmds+     , runListCmd+     ) where++import           Data.Semigroup                   ((<>))+import           Options.Applicative++import           Groot.CLI.Common+import           Groot.CLI.List.Cluster+import           Groot.CLI.List.ContainerInstance+import           Groot.CLI.List.ContainerService+import           Groot.CLI.List.Task+import           Groot.CLI.List.TaskDef+import           Groot.Core+import           Groot.Types++data ListSubCmd =+    ListClustersCmd (Maybe ClusterRef)+  | ListInstancesCmd (Maybe ClusterRef)+  | ListTasksCmd ListTaskOpts+  | ListTaskDefsCmd ListTaskDefsOpts+  | ListServicesCmd (Maybe ClusterRef)+  deriving (Eq, Show)++listClustersCmd :: Parser ListSubCmd+listClustersCmd = ListClustersCmd <$> optional clusterOpt++listInstancesCmd :: Parser ListSubCmd+listInstancesCmd = ListInstancesCmd <$> optional clusterOpt++listTasksCmd :: Parser ListSubCmd+listTasksCmd = ListTasksCmd <$> listTaskOpts++listTaskDefsCmd :: Parser ListSubCmd+listTaskDefsCmd = ListTaskDefsCmd <$> listTaskDefsOpts++listServicesCmd :: Parser ListSubCmd+listServicesCmd = ListServicesCmd <$> optional clusterOpt++listCmds :: Parser ListSubCmd+listCmds = hsubparser+  ( command "clusters"  (info listClustersCmd  (progDesc "List clusters"))+ <> command "instances" (info listInstancesCmd (progDesc "List instances"))+ <> command "tasks"     (info listTasksCmd     (progDesc "List tasks"))+ <> command "taskDefs"  (info listTaskDefsCmd  (progDesc "List task definitions"))+ <> command "services"  (info listServicesCmd  (progDesc "List services"))+  )++runListCmd :: ListSubCmd -> GrootM IO ()+runListCmd (ListClustersCmd clusterId)  = printClusterSummary clusterId+runListCmd (ListInstancesCmd clusterId) = printInstanceSummary clusterId+runListCmd (ListTasksCmd opts)          = printTaskSummary opts+runListCmd (ListServicesCmd clusterId)  = printServiceSummary clusterId+runListCmd (ListTaskDefsCmd opts)       = printTaskDefsSummary opts
+ src/Groot/CLI/List/Cluster.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.CLI.List.Cluster+     ( printClusterSummary+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import           Data.Data+import           Data.Maybe                 (maybeToList)+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Text.PrettyPrint.Tabulate  (Tabulate, printTable)+import qualified Text.PrettyPrint.Tabulate  as Tabs++import           Groot.CLI.List.Common+import           Groot.Console+import           Groot.Core+import           Groot.Types++data ClusterSummary = ClusterSummary+  { name         :: String+  , status       :: String+  , runningTasks :: Int+  , pendingTasks :: Int+  , instances    :: Int+  } deriving (Eq, Show, Generic, Data)++instance Tabulate ClusterSummary Tabs.ExpandWhenNested++instance HasSummary ECS.Cluster ClusterSummary where+  summarize cls = ClusterSummary <$> cName <*> cStatus <*> cRunning <*> cPending <*> cInstances+     where cName      = T.unpack <$> cls ^. ECS.cClusterName+           cStatus    = T.unpack <$> cls ^. ECS.cStatus+           cRunning   = cls ^. ECS.cRunningTasksCount+           cPending   = cls ^. ECS.cPendingTasksCount+           cInstances = cls ^. ECS.cRegisteredContainerInstancesCount++summarizeClusters :: Maybe ClusterRef -> AWS [ClusterSummary]+summarizeClusters Nothing  = runConduit $ fetchClusters =$= CL.mapMaybe summarize =$ CL.consume+summarizeClusters (Just c) = maybeToList <$> do+  cl <- runMaybeT (findCluster c)+  return $ cl >>= summarize++printClusterSummary :: Maybe ClusterRef -> GrootM IO ()+printClusterSummary x = do+  env  <- ask+  desc <- runResourceT . runAWS env $ summarizeClusters x+  case desc of+    [] -> putWarn ("No clusters found" :: Text)+    xs -> liftIO $ printTable xs
+ src/Groot/CLI/List/Common.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Groot.CLI.List.Common where++import qualified Data.Text       as T+import           Groot.Data.Text++class HasSummary a b where+  summarize :: a -> Maybe b++asString :: ToText a => a -> String+asString = T.unpack . toText
+ src/Groot/CLI/List/ContainerInstance.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.CLI.List.ContainerInstance+     ( printInstanceSummary+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import           Data.Data+import           Data.List+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Numeric+import           Text.PrettyPrint.Tabulate  (CellValueFormatter, Tabulate,+                                             printTable)+import qualified Text.PrettyPrint.Tabulate  as Tabs++import           Groot.CLI.List.Common+import           Groot.Console+import           Groot.Core+import           Groot.Types++data ResourceType =+    Memory+  | CPU+  deriving (Eq, Show, Generic, Data)++data ResourceSummary = ResourceSummary+  { resourceType :: ResourceType+  , allocated    :: Int+  , available    :: Int+  } deriving (Eq, Generic, Data)++instance Show ResourceSummary where+  show (ResourceSummary resType alloc avail) = concat [show avail, "/", show alloc, " ", units, " ", percent]+    where units = case resType of+            Memory -> "mb"+            CPU    -> "units"+          percent =+            let pvalue = (fromIntegral avail) / (fromIntegral alloc) * 100.0 :: Float+            in concat ["(", showFFloat (Just 1) pvalue "", " %)"]++instance CellValueFormatter ResourceSummary++resourceSummary :: ResourceType -> ECS.ContainerInstance -> Maybe ResourceSummary+resourceSummary resType inst = (ResourceSummary resType) <$> rAlloc <*> rAvail+  where resName = case resType of+          Memory -> "MEMORY"+          CPU    -> "CPU"++        findResource :: [ECS.Resource] -> Maybe Int+        findResource rs = (view ECS.rIntegerValue) =<< find (\x -> maybe False (== resName) $ x ^. ECS.rName) rs++        rAlloc = findResource $ inst ^. ECS.ciRegisteredResources+        rAvail = findResource $ inst ^. ECS.ciRemainingResources++data InstanceSummary = InstanceSummary+  { instanceId    :: String+  , ec2InstaceId  :: String+  , status        :: String+  , runningTasks  :: Int+  , pendingTasks  :: Int+  , memory        :: ResourceSummary+  , cpu           :: ResourceSummary+  , agentVersion  :: String+  , dockerVersion :: String+  } deriving (Eq, Show, Generic, Data)++instance Tabulate InstanceSummary Tabs.ExpandWhenNested++instance HasSummary ECS.ContainerInstance InstanceSummary where+  summarize inst = InstanceSummary <$> iId <*> iEc2Id <*> iStatus <*> iRunning <*> iPending <*> iMem <*> iCpu <*> iAgentV <*> iDockerV+    where iId      = (asString . view arnContainerInstanceId) <$> viewArn (ECS.ciContainerInstanceARN . _Just) inst+          iEc2Id   = T.unpack <$> inst ^. ECS.ciEc2InstanceId+          iStatus  = T.unpack <$> inst ^. ECS.ciStatus+          iRunning = inst ^. ECS.ciRunningTasksCount+          iPending = inst ^. ECS.ciPendingTasksCount+          iMem     = resourceSummary Memory inst+          iCpu     = resourceSummary CPU inst+          iAgentV  = T.unpack <$> (inst ^. ECS.ciVersionInfo >>= view ECS.viAgentVersion)+          iDockerV = T.unpack <$> (inst ^. ECS.ciVersionInfo >>= view ECS.viDockerVersion)++summarizeInstances :: Maybe ClusterRef -> AWS [InstanceSummary]+summarizeInstances cId =+  sourceToList $ instanceSource cId =$= CL.mapMaybe summarize+  where instanceSource Nothing  = fetchAllInstances+        instanceSource (Just x) = fetchInstances x++printInstanceSummary :: Maybe ClusterRef -> GrootM IO ()+printInstanceSummary cId = do+  env  <- ask+  desc <- runResourceT . runAWS env $ summarizeInstances cId+  case desc of+    [] -> putWarn ("No container instances found" :: Text)+    xs -> liftIO $ printTable xs
+ src/Groot/CLI/List/ContainerService.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.CLI.List.ContainerService+     ( printServiceSummary+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import           Data.Data+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Text.PrettyPrint.Tabulate  (Tabulate, printTable)+import qualified Text.PrettyPrint.Tabulate  as Tabs++import           Groot.CLI.List.Common+import           Groot.Console+import           Groot.Core+import           Groot.Data.Text+import           Groot.Types++data ServiceSummary = ServiceSummary+  { name    :: String+  , cluster :: String+  , task    :: String+  , running :: Int+  , pending :: Int+  , desired :: Int+  } deriving (Eq, Show, Generic, Data)++instance Tabulate ServiceSummary Tabs.ExpandWhenNested++data ServiceAndRelatives = SR ECS.ContainerService ECS.Cluster++instance HasSummary ServiceAndRelatives ServiceSummary where+  summarize (SR service cluster) = ServiceSummary <$> sName <*> sClusterName <*> sTask <*> sRunning <*> sPending <*> sDesired+    where sName        = T.unpack <$> service ^. ECS.csServiceName+          sClusterName = T.unpack <$> cluster ^. ECS.cClusterName+          sTask        = T.unpack . toText . (view arnTaskDefId) <$> serviceTaskDefArn service+          sRunning     = service ^. ECS.csRunningCount+          sPending     = service ^. ECS.csPendingCount+          sDesired     = service ^. ECS.csDesiredCount++annotateService :: MonadAWS m => Conduit ECS.ContainerService m ServiceAndRelatives+annotateService = CL.mapMaybeM (\s -> runMaybeT $+    (SR s) <$> serviceCluster s+  )++summarizeServices :: Maybe ClusterRef -> AWS [ServiceSummary]+summarizeServices clusterId =+  sourceToList $ serviceSource clusterId =$= annotateService =$= CL.mapMaybe summarize+    where serviceSource Nothing    = fetchAllServices+          serviceSource (Just cid) = fetchServices cid++printServiceSummary :: Maybe ClusterRef -> GrootM IO ()+printServiceSummary clusterId = do+  env  <- ask+  desc <- runResourceT . runAWS env $ summarizeServices clusterId+  case desc of+    [] -> putWarn ("No services found" :: Text)+    xs -> liftIO $ printTable xs
+ src/Groot/CLI/List/Task.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.CLI.List.Task+     ( ListTaskOpts+     , listTaskOpts+     , printTaskSummary+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import           Data.Data+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Options.Applicative+import           Text.PrettyPrint.Tabulate  (Tabulate, printTable)+import qualified Text.PrettyPrint.Tabulate  as Tabs++import           Groot.CLI.Common+import           Groot.CLI.List.Common+import           Groot.Console+import           Groot.Core+import           Groot.Types++data ListTaskOpts = ListTaskOpts (Maybe ClusterRef) (Maybe ContainerServiceRef)+  deriving (Eq, Show)++listTaskOpts :: Parser ListTaskOpts+listTaskOpts = ListTaskOpts+           <$> optional clusterOpt+           <*> optional containerServiceOpt++data TaskSummary = TaskSummary+  { taskId     :: String+  , task       :: String+  , status     :: String+  , cluster    :: String+  , instanceId :: String+  , startedAt  :: String+  , stoppedAt  :: String+  } deriving (Eq, Show, Generic, Data)++instance Tabulate TaskSummary Tabs.ExpandWhenNested++data TaskAndRelatives = TR ECS.Task ECS.ContainerInstance++instance HasSummary TaskAndRelatives TaskSummary where+  summarize (TR t i) = TaskSummary <$> tId <*> tTaskDef <*> tStatus <*> tCluster <*> tInstanceId <*> tStartedAt <*> tStoppedAt+    where tId         = (asString . view arnTaskId) <$> viewArn (ECS.tTaskARN . _Just) t+          tTaskDef    = (asString . view arnTaskDefId) <$> viewArn (ECS.tTaskDefinitionARN . _Just) t+          tStatus     = T.unpack <$> t ^. ECS.tLastStatus+          tCluster    = (asString . view arnClusterName) <$> viewArn (ECS.tClusterARN . _Just) t+          tInstanceId = T.unpack <$> i ^. ECS.ciEc2InstanceId+          tStartedAt  = pure $ maybe "" show $ t ^. ECS.tStartedAt+          tStoppedAt  = pure $ maybe "" show $ t ^. ECS.tStoppedAt++annotateTask :: MonadAWS m => Conduit ECS.Task m TaskAndRelatives+annotateTask = CL.mapMaybeM (\t -> runMaybeT $+    (TR t) <$> taskInstance t+  )++summarizeTasks :: ListTaskOpts -> AWS [TaskSummary]+summarizeTasks opts = sourceToList $ taskSource opts =$= annotateTask =$= CL.mapMaybe summarize+  where taskSource (ListTaskOpts Nothing    Nothing)           = fetchAllTasks+        taskSource (ListTaskOpts (Just cid) Nothing)           = fetchTasks cid+        taskSource (ListTaskOpts cref       (Just serviceRef)) = fetchServiceTasks cref serviceRef++printTaskSummary :: ListTaskOpts -> GrootM IO ()+printTaskSummary opts = do+  env  <- ask+  desc <- runResourceT . runAWS env $ summarizeTasks opts+  case desc of+    [] -> putWarn ("No tasks found" :: Text)+    xs -> liftIO $ printTable xs
+ src/Groot/CLI/List/TaskDef.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.CLI.List.TaskDef+     ( ListTaskDefsOpts+     , listTaskDefsOpts+     , printTaskDefsSummary+     , TaskDefFilter(..)+     ) where++import           Control.Lens+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Conduit+import qualified Data.Conduit.List          as CL+import           Data.Data+import           Data.Maybe                 (maybeToList)+import           Data.Semigroup             ((<>))+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           GHC.Generics+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Options.Applicative+import           Text.PrettyPrint.Tabulate  (Tabulate, printTable)+import qualified Text.PrettyPrint.Tabulate  as Tabs++import           Groot.CLI.Common+import           Groot.CLI.List.Common+import           Groot.Console+import           Groot.Core+import           Groot.Types++data ListTaskDefsOpts =+  ListTaskDefsOpts Bool (Maybe TaskFamily)+  deriving (Eq, Show)++listTaskDefsOpts :: Parser ListTaskDefsOpts+listTaskDefsOpts = ListTaskDefsOpts+              <$> switch+                ( long "inactive"+                <> short 'i'+                <> help "Show inactive task definitions" )+              <*> optional taskFamilyOpt++data TaskDefSummary = TaskDefSummary+  { family   :: String+  , revision :: Int+  , status   :: String+  } deriving (Eq, Show, Generic, Data)++instance Tabulate TaskDefSummary Tabs.ExpandWhenNested++instance HasSummary ECS.TaskDefinition TaskDefSummary where+  summarize taskDef = TaskDefSummary <$> tFamily <*> tRev <*> tStatus+    where tFamily = T.unpack <$> taskDef ^. ECS.tdFamily+          tRev    = taskDef ^. ECS.tdRevision+          tStatus = statusAsText <$> taskDef ^. ECS.tdStatus+            where statusAsText ECS.TDSActive   = "Active"+                  statusAsText ECS.TDSInactive = "Inactive"++summarizeTaskDefs :: [TaskDefFilter] -> AWS [TaskDefSummary]+summarizeTaskDefs filters =+  runConduit $ (fetchTaskDefs filters)+     =$= CL.mapMaybe summarize+     =$ CL.consume++printTaskDefsSummary :: ListTaskDefsOpts -> GrootM IO ()+printTaskDefsSummary (ListTaskDefsOpts showInactive fam) =+  let statusFilter = if showInactive then [TDFStatus TDSInactive] else []+      familyFilter = maybeToList $ TDFFamily <$> fam+      filters      = statusFilter ++ familyFilter+  in do+    env  <- ask+    desc <- runResourceT . runAWS env $ summarizeTaskDefs filters+    case desc of+      [] -> putWarn ("No task definitions found" :: Text)+      xs -> liftIO $ printTable xs
+ src/Groot/CLI/Service.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.CLI.Service+     ( ServiceSubCmd+     , serviceCmds+     , runServiceCmd+     ) where++import           Control.Exception.Lens+import           Control.Monad.Catch+import           Data.Semigroup            ((<>))+import qualified Data.Text                 as T+import           Options.Applicative++import           Groot.CLI.Service.Compose+import           Groot.CLI.Service.Events+import           Groot.CLI.Service.Inspect+import           Groot.Console+import           Groot.Core+import           Groot.Data.Text+import           Groot.Exception++data ServiceSubCmd =+    ServiceEventsCmd  ServiceEventOpts+  | ServiceUpCmd      ServiceComposeOpts+  | ServiceDeleteCmd  ServiceComposeOpts+  | ServiceInspectCmd ServiceInspectOpts+  deriving (Eq, Show)++-- CLI++serviceEventsCmd :: Parser ServiceSubCmd+serviceEventsCmd = ServiceEventsCmd <$> serviceEventsOpt++serviceUpCmd :: Parser ServiceSubCmd+serviceUpCmd = ServiceUpCmd <$> serviceComposeOpts++serviceDeleteCmd :: Parser ServiceSubCmd+serviceDeleteCmd = ServiceDeleteCmd <$> serviceComposeOpts++serviceInspectCmd :: Parser ServiceSubCmd+serviceInspectCmd = ServiceInspectCmd <$> serviceInspectOpts++serviceCmds :: Parser ServiceSubCmd+serviceCmds = hsubparser+  ( command "events"  (info serviceEventsCmd  (progDesc "Display events of the given services."))+ <> command "up"      (info serviceUpCmd      (progDesc "Deploy services as stated in a service file."))+ <> command "rm"      (info serviceDeleteCmd  (progDesc "Delete previously deployed services."))+ <> command "inspect" (info serviceInspectCmd (progDesc "Inspect details of a given service."))+  )++-- Error handlers++handleUndefinedService :: MonadConsole m => UndefinedService -> m ()+handleUndefinedService (UndefinedService' serviceName manifestFile) =+  putError $ "Service" <+> (styled yellowStyle serviceName)+    <+> "has not been defined in compose file:"+    <+> (styled yellowStyle $ T.pack manifestFile)++handleDeploymentFailed :: MonadConsole m => FailedServiceDeployment -> m ()+handleDeploymentFailed (FailedServiceDeployment' serviceRef clusterRef reason) =+  putError $ "Failed to deploy service" <+> (styled yellowStyle $ toText serviceRef)+    <+> "in cluster" <+> (styled yellowStyle $ toText clusterRef)+    <> (maybe "" (\x -> " because" <+> (styled yellowStyle x)) reason)++handleDeletionFailed :: MonadConsole m => FailedServiceDeletion -> m ()+handleDeletionFailed (FailedServiceDeletion' serviceRef clusterRef) =+  putError $ "Failed to delete service" <+> (styled yellowStyle $ toText serviceRef)+    <+> "from cluster" <+> (styled yellowStyle $ toText clusterRef)++handleErrors :: GrootIO () -> GrootIO ()+handleErrors act = catches act [+    handler _UndefinedService        handleUndefinedService+  , handler _FailedServiceDeployment handleDeploymentFailed+  , handler _FailedServiceDeletion   handleDeletionFailed+  ]++-- run function++runServiceCmd :: ServiceSubCmd -> GrootM IO ()+runServiceCmd (ServiceEventsCmd eventsOpts)   = runServiceEvents  eventsOpts+runServiceCmd (ServiceUpCmd     composeOpts)  = handleErrors $ runServiceUp      composeOpts+runServiceCmd (ServiceDeleteCmd composeOpts)  = handleErrors $ runServiceDelete  composeOpts+runServiceCmd (ServiceInspectCmd inspectOpts) = runServiceInspect inspectOpts
+ src/Groot/CLI/Service/Compose.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.CLI.Service.Compose+     ( ServiceComposeOpts(..)+     , serviceComposeOpts+     , runServiceUp+     , runServiceDelete+     ) where++import           Control.Lens        hiding (argument)+import           Control.Monad.Catch+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import           Data.Semigroup      ((<>))+import           Data.String+import           Data.Text           (Text)+import           Options.Applicative++import           Groot.CLI.Common+import           Groot.Compose+import           Groot.Core+import           Groot.Exception+import           Groot.Manifest+import           Groot.Types++-- Command Line++data ServiceComposeOpts = ServiceComposeOpts+  { manifestFile :: Maybe FilePath+  , cluster      :: ClusterRef+  , runMode      :: Maybe RunMode+  , serviceNames :: [Text]+  } deriving (Eq, Show)++dryRunOpt :: Parser RunMode+dryRunOpt = flag' DryRun+          ( long "dryRun"+         <> short 't'+         <> help "Just emulate but do not perform any changes" )++unattendedOpt :: Parser RunMode+unattendedOpt = flag' Unattended+              ( long "yes"+             <> short 'y'+             <> help "Answer 'yes' to all questions." )++runModeOpt :: Parser RunMode+runModeOpt = dryRunOpt <|> unattendedOpt++serviceNameArg :: Parser Text+serviceNameArg = fromString <$> argument str (metavar "SERVICES")++serviceComposeOpts :: Parser ServiceComposeOpts+serviceComposeOpts = ServiceComposeOpts+                 <$> optional manifestFileOpt+                 <*> clusterOpt+                 <*> optional runModeOpt+                 <*> many serviceNameArg++-- Main functions++selectServices :: MonadThrow m => FilePath -> [Text] -> HashMap Text ServiceDeployment -> m [NamedServiceDeployment]+selectServices _        [] m = pure $ Map.toList m+selectServices manifest xs m = traverse selectService xs+  where selectService :: MonadThrow m => Text -> m NamedServiceDeployment+        selectService serviceName =+          let dep = maybe (throwM $ undefinedService serviceName manifest) pure $ Map.lookup serviceName m+              pairUp x = (serviceName,x)+          in pairUp <$> dep++performAction :: Text -> (ServiceComposeCfg -> ServiceComposeM ()) -> ServiceComposeOpts -> GrootM IO ()+performAction userMsg buildComposeAction opts = do+  let manifestFileName = maybe defaultManifestFilePath id $ manifestFile opts+  manifest      <- loadManifest manifestFileName+  serviceList   <- selectServices manifestFileName (serviceNames opts) $ manifest ^. gmServices+  cfg           <- pure $ ServiceComposeCfg manifest (cluster opts) serviceList (runMode opts)+  composeAction <- pure $ buildComposeAction cfg+  interpretServiceComposeM userMsg composeAction cfg++doDeployServices :: ServiceComposeCfg -> ServiceComposeM ()+doDeployServices (ServiceComposeCfg _ clusterRef serviceList _) =+  deployServices clusterRef serviceList++doDeleteServices :: ServiceComposeCfg -> ServiceComposeM ()+doDeleteServices (ServiceComposeCfg _ clusterRef serviceList _) =+  deleteServices clusterRef serviceList++runServiceUp :: ServiceComposeOpts -> GrootM IO ()+runServiceUp = performAction "This will start deployment of the following services:" doDeployServices++runServiceDelete :: ServiceComposeOpts -> GrootM IO ()+runServiceDelete = performAction "This will delete the following services:" doDeleteServices
+ src/Groot/CLI/Service/Events.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}++module Groot.CLI.Service.Events+     ( ServiceEventOpts+     , serviceEventsOpt+     , runServiceEvents+     ) where++import           Control.Monad.Catch+import           Control.Monad.IO.Class+import           Control.Monad.Reader+import           Control.Monad.Trans.Resource+import           Data.Conduit+import           Data.Foldable+import           Data.List.NonEmpty           (NonEmpty ((:|)), intersperse)+import           Data.Semigroup               ((<>))+import           Data.String+import           Data.Typeable+import           Network.AWS+import qualified Network.AWS.ECS              as ECS+import           Options.Applicative++import           Groot.CLI.Common+import           Groot.Console+import           Groot.Core+import           Groot.Core.Events+import           Groot.Data.Text+import           Groot.Types++data ServiceEventOpts = ServiceEventOpts+  { _clusterId    :: Maybe ClusterRef+  , _follow       :: Bool+  , _eventCount   :: Int+  , _serviceNames :: NonEmpty ContainerServiceRef+  } deriving (Eq, Show)++serviceRefArg :: Parser ContainerServiceRef+serviceRefArg = fromString <$> argument str (metavar "SERVICE_NAMES")++serviceRefArgList :: Parser (NonEmpty ContainerServiceRef)+serviceRefArgList = fmap (\x -> (head x) :| (tail x)) (some serviceRefArg)++serviceEventsOpt :: Parser ServiceEventOpts+serviceEventsOpt = ServiceEventOpts+               <$> optional clusterOpt+               <*> switch+                 ( long "follow"+                 <> short 'f'+                 <> help "Follow the trail of events" )+               <*> eventCountOpt+               <*> serviceRefArgList++fetchEvents :: (Typeable mi, MonadResource mi, MonadBaseControl IO mi, MonadCatch mi, MonadConsole mi, MonadIO mo, Foldable f)+            => f ContainerServiceCoords+            -> Bool+            -> Int+            -> GrootM mi (Source mo ECS.ServiceEvent)+fetchEvents coords inf = serviceEventLog (toList coords) inf++runServiceEvents :: ServiceEventOpts -> GrootM IO ()+runServiceEvents (ServiceEventOpts (Just clusterRef) follow lastN serviceRefs) = mapReaderT runResourceT $ do+  eventSource <- fetchEvents (fmap (\x -> ContainerServiceCoords x clusterRef) serviceRefs) follow lastN+  runConduit $ eventSource =$ printEventSink+runServiceEvents (ServiceEventOpts Nothing follow lastN serviceRefs) = mapReaderT runResourceT $ do+  env         <- ask+  putInfo $ "Scanning clusters for services: " <> (fold . intersperse (styleless ", ") $ (styled yellowStyle . toText) <$> serviceRefs)+  coords      <- runAWS env $ findServiceCoords serviceRefs+  eventSource <- fetchEvents coords follow lastN+  runConduit $ eventSource =$ printEventSink
+ src/Groot/CLI/Service/Inspect.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.CLI.Service.Inspect+     ( ServiceInspectOpts+     , serviceInspectOpts+     , runServiceInspect+     ) where++import           Control.Lens               hiding (argument)+import           Control.Monad.Catch+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+import           Data.Maybe+import           Data.Monoid+import           Data.String+import           Data.Text                  (Text)+import           Network.AWS+import qualified Network.AWS.ECS            as ECS+import           Options.Applicative++import           Groot.AWS+import           Groot.CLI.Common+import           Groot.Console+import           Groot.Core+import           Groot.Data.Text            (styled, toText, yellowStyle)+import           Groot.Exception+import           Groot.Internal.PrettyPrint (Doc, defaultIndent, (<+>))+import qualified Groot.Internal.PrettyPrint as Doc+import           Groot.Types++data ServiceInspectOpts =+  ServiceInspectOpts (Maybe ClusterRef) ContainerServiceRef+  deriving (Eq, Show)++serviceNameArg :: Parser ContainerServiceRef+serviceNameArg = fromString <$> argument str (metavar "SERVICE")++serviceInspectOpts :: Parser ServiceInspectOpts+serviceInspectOpts = ServiceInspectOpts+                 <$> optional clusterOpt+                 <*> serviceNameArg++pprintService :: ECS.ContainerService -> Doc+pprintService service = Doc.vsep [+    Doc.bold . Doc.dullblue $ maybe mempty Doc.pretty $ service ^. ECS.csServiceName+  , Doc.indent defaultIndent (Doc.vsep $ catMaybes [+        Doc.field Doc.status "Status:" <$> service ^. ECS.csStatus+      , Doc.field' "Running:" <$> service ^. ECS.csRunningCount+      , Doc.field' "Desired:" <$> service ^. ECS.csDesiredCount+      , Doc.field' "Pending:" <$> service ^. ECS.csPendingCount+      , (Just . Doc.blue . Doc.pretty $ ("ARNs:" :: Text))+      , Just $ Doc.indent defaultIndent (Doc.vsep $ catMaybes [+          Doc.field ppArn "Service:" <$> service ^. ECS.csServiceARN+        , Doc.field ppArn "Task:" <$> service ^. ECS.csTaskDefinition+        , Doc.field ppArn "Cluster:" <$> service ^. ECS.csClusterARN+        , Doc.field ppArn "Role:" <$> service ^. ECS.csRoleARN+      ])+      , Doc.field Doc.defaultTime "Created:" <$> service ^. ECS.csCreatedAt+      , Doc.listField ppLoadBalancer "Load Balancers:" $ service ^. ECS.csLoadBalancers+      , Doc.listField ppDeployment "Deployments:" $ service ^. ECS.csDeployments+      , Doc.listField ppPlacementStrategy "Placement Strategies:" $ service ^. ECS.csPlacementStrategy+      , Doc.listField ppPlacementConstraint "Placement Constraints" $ service ^. ECS.csPlacementConstraints+    ])+  ]+  where ppArn :: Text -> Doc+        ppArn = Doc.underline . Doc.pretty++        ppLoadBalancer :: ECS.LoadBalancer -> Doc+        ppLoadBalancer lb = Doc.vsep [+            Doc.bold . Doc.dullblue $ maybe mempty Doc.pretty $ lb ^. ECS.lbContainerName+          , Doc.indent defaultIndent (Doc.vsep $ catMaybes [+                Doc.field' "Port:" <$> lb ^. ECS.lbContainerPort+              , Doc.field' "ELB:" <$> lb ^. ECS.lbLoadBalancerName+              , Doc.field ppArn "Target Group:" <$> lb ^. ECS.lbTargetGroupARN+            ])+          ]++        ppDeployment :: ECS.Deployment -> Doc+        ppDeployment dep = Doc.vsep [+              Doc.bold . Doc.dullblue $ maybe mempty Doc.pretty $ dep ^. ECS.dId+            , Doc.indent defaultIndent (Doc.vsep $ catMaybes [+                  Doc.field ppArn "Task:" <$> dep ^. ECS.dTaskDefinition+                , Doc.field' "Running:" <$> dep ^. ECS.dRunningCount+                , Doc.field' "Desired:" <$> dep ^. ECS.dDesiredCount+                , Doc.field Doc.defaultTime "Updated:" <$> dep ^. ECS.dUpdatedAt+                , Doc.field Doc.defaultTime "Created:" <$> dep ^. ECS.dCreatedAt+              ])+            ]++        ppPlacementStrategy :: ECS.PlacementStrategy -> Doc+        ppPlacementStrategy ps = Doc.cyan $ Doc.hsep $ catMaybes [+              Doc.pretty . toText <$> ps ^. ECS.psType+            , Doc.pretty <$> ps ^. ECS.psField+          ]++        ppPlacementConstraint :: ECS.PlacementConstraint -> Doc+        ppPlacementConstraint pc = Doc.cyan $ Doc.hsep $ catMaybes [+             Doc.pretty . toText <$> pc ^. ECS.pcType+           , Doc.pretty <$> pc ^. ECS.pcExpression+         ]++runServiceInspect :: ServiceInspectOpts -> GrootM IO ()+runServiceInspect (ServiceInspectOpts clusterRef serviceRef) = do+  env <- ask+  case clusterRef of+    Nothing -> putInfo $ "Scanning clusters for service " <> (styled yellowStyle $ toText serviceRef)+    _       -> pure ()+  xs <- runResourceT . runAWS env $ runMaybeT $ findService serviceRef clusterRef+  case xs of+    Nothing -> throwM $ serviceNotFound serviceRef clusterRef+    Just  s -> liftIO . Doc.putDoc $ pprintService s
+ src/Groot/Compose.hs view
@@ -0,0 +1,5 @@+module Groot.Compose+     ( module Groot.Compose.Service+     ) where++import           Groot.Compose.Service
+ src/Groot/Compose/Service.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module Groot.Compose.Service+     ( ServiceComposeM+     , ServiceComposeCfg(..)+     , RunMode(..)+     , deployService+     , deployServices+     , deleteServices+     , interpretServiceComposeM+     ) where++import           Control.Lens+import           Control.Monad.Morph+import           Control.Monad.Trans.Resource+import           Data.Semigroup               ((<>))+import           Data.Text                    (Text)+import qualified Data.Text                    as T++import           Groot.Compose.Service.AWS    (awsServiceCompose)+import           Groot.Compose.Service.DryRun+import           Groot.Compose.Service.Free+import           Groot.Console+import           Groot.Core+import           Groot.Manifest+import           Groot.Types++data RunMode = DryRun | Unattended+  deriving (Eq, Show, Enum, Ord)++_DryRun :: Prism' RunMode Bool+_DryRun = prism (const DryRun) $ \case+  DryRun -> Right True+  x      -> Left x++_Unattended :: Prism' RunMode Bool+_Unattended = prism (const Unattended) $ \case+  Unattended -> Right True+  x          -> Left x++data ServiceComposeCfg = ServiceComposeCfg+  { composeManifest :: GrootManifest+  , composeCluster  :: ClusterRef+  , composeServices :: [NamedServiceDeployment]+  , composeRunMode  :: Maybe RunMode+  } deriving (Eq, Show)++interpretServiceComposeM :: Text+                         -> ServiceComposeM ()+                         -> ServiceComposeCfg+                         -> GrootM IO ()+interpretServiceComposeM userMsg action cfg =+  let shouldConfirm   = maybe True (isn't _Unattended) (composeRunMode cfg)+      isDryRun        = maybe False (\x -> not $ isn't _DryRun x) (composeRunMode cfg)+      confirmMsg srvs = userMsg <> "\n"+                     <> (T.intercalate "\n" $ T.append "   - " . fst <$> srvs)+                     <> ".\nDo you want to continue? "+      interpret       = if isDryRun then dryRunServiceCompose else awsServiceCompose+      performFor srvs =+        if shouldConfirm+        then askUserToContinue (confirmMsg srvs) $ interpret (composeManifest cfg) action+        else interpret (composeManifest cfg) action+  in hoist runResourceT $ performFor (composeServices cfg)
+ src/Groot/Compose/Service/AWS.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}++module Groot.Compose.Service.AWS+     ( serviceExists'+     , verifyActiveCluster'+     , awsServiceCompose+     ) where++import           Control.Lens+import           Control.Monad.Free+import           Control.Monad.Morph+import           Control.Monad.Reader         hiding (filterM)+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Resource+import qualified Data.HashMap.Strict          as Map+import           Data.Maybe+import           Data.Semigroup               ((<>))+import qualified Data.Text                    as T+import           Network.AWS+import qualified Network.AWS.ECS              as ECS+import           Network.AWS.Waiter++import           Groot.Compose.Service.Free+import           Groot.Console+import           Groot.Core+import           Groot.Data.Filter+import           Groot.Data.Text+import           Groot.Exception+import           Groot.Manifest+import           Groot.Types++-- Model mapping functions++serviceDeploymentConf :: DeploymentStrategy -> ECS.DeploymentConfiguration+serviceDeploymentConf DSBlueGreen =+    ECS.dcMinimumHealthyPercent ?~ 100+  $ ECS.dcMaximumPercent ?~ 200+  $ ECS.deploymentConfiguration+serviceDeploymentConf DSRolling =+    ECS.dcMinimumHealthyPercent ?~ 50+  $ ECS.dcMaximumPercent ?~ 200+  $ ECS.deploymentConfiguration+serviceDeploymentConf DSTearDown =+    ECS.dcMinimumHealthyPercent ?~ 0+  $ ECS.dcMaximumPercent ?~ 100+  $ ECS.deploymentConfiguration++createTaskDefinitionReq :: GrootManifest -> NamedServiceDeployment -> ECS.RegisterTaskDefinition+createTaskDefinitionReq manifest (serviceName, deployment) =+    ECS.rtdNetworkMode .~ (deployment ^. sdNetworkMode)+  $ ECS.rtdTaskRoleARN .~ (deployment ^. sdTaskRole)+  $ ECS.rtdContainerDefinitions .~ (containerDef <$> deployment ^. sdContainers)+  $ ECS.rtdVolumes .~ (taskVolume <$> Map.elems (manifest ^. gmVolumes))+  $ ECS.rtdPlacementConstraints .~ (concat $ taskPlacementConstaints <$> deployment ^. sdDeploymentConstraints)+  $ ECS.registerTaskDefinition serviceName+  where containerEnv =+          Map.foldrWithKey (\k v acc -> (ECS.kvpName ?~ k $ ECS.kvpValue ?~ v $ ECS.keyValuePair):acc) []++        containerPort port =+            ECS.pmProtocol .~ (port ^. pmProtocol)+          $ ECS.pmHostPort .~ (port ^. pmHostPort)+          $ ECS.pmContainerPort ?~ (port ^. pmContainerPort)+          $ ECS.portMapping++        taskVolume v =+            ECS.vName ?~ (v ^. vName)+          $ ECS.vHost ?~ (ECS.hvpSourcePath ?~ (v ^. vSourcePath) $ ECS.hostVolumeProperties)+          $ ECS.volume++        mountPoint mp =+            ECS.mpSourceVolume ?~ (mp ^. mpVolume)+          $ ECS.mpContainerPath ?~ (mp ^. mpTargetPath)+          $ ECS.mpReadOnly .~ (mp ^. mpReadOnly)+          $ ECS.mountPoint++        containerExtraHosts =+          Map.foldrWithKey (\host ip acc -> (ECS.hostEntry host ip):acc) []++        taskPlacementConstaints (InstanceAttributesConstraint attrs) =+          Map.foldrWithKey (\k v acc -> (attrExpr k v):acc) [] attrs+          where attrExpr k v =+                    ECS.tdpcType ?~ ECS.MemberOf+                  $ ECS.tdpcExpression ?~ (T.concat ["attribute:", k, " == ", v])+                  $ ECS.taskDefinitionPlacementConstraint++        containerDef c =+            ECS.cdImage ?~ (c ^. cImage)+          $ ECS.cdEnvironment .~ (containerEnv $ c ^. cEnvironment)+          $ ECS.cdPortMappings .~ (containerPort <$> c ^. cPortMappings)+          $ ECS.cdMemory .~ (c ^? cMemory . _AssignedMemory)+          $ ECS.cdMemoryReservation .~ (c ^? cMemory . _ReservedMemory)+          $ ECS.cdHostname .~ (c ^. cHostname)+          $ ECS.cdExtraHosts .~ (containerExtraHosts $ c ^. cExtraHosts)+          $ ECS.cdCpu .~ (c ^. cCpu)+          $ ECS.cdDockerLabels .~ (c ^. cLabels)+          $ ECS.cdLinks .~ (c ^. cLinks)+          $ ECS.cdLogConfiguration .~ (c ^. cLogConfig)+          $ ECS.cdName ?~ (c ^. cName)+          $ ECS.cdPrivileged .~ (c ^. cPriviledged)+          $ ECS.cdEssential .~ (c ^. cEssential)+          $ ECS.cdWorkingDirectory .~ (c ^. cWorkDir)+          $ ECS.cdMountPoints .~ (mountPoint <$> c ^. cMountPoints)+          $ ECS.cdEntryPoint .~ (c ^. cEntryPoint)+          $ ECS.cdDnsSearchDomains .~ (c ^. cDnsSearch)+          $ ECS.cdUser .~ (c ^. cUser)+          $ ECS.cdCommand .~ (c ^. cCommand)+          $ ECS.containerDefinition++createServiceReq :: ClusterRef -> NamedServiceDeployment -> TaskDefId -> ECS.CreateService+createServiceReq clusterRef (serviceName, deployment) tdId =+    ECS.cCluster ?~ (toText clusterRef)+  $ ECS.cRole .~ (deployment ^. sdServiceRole)+  $ ECS.cLoadBalancers .~ containerLoadBalancers+  $ ECS.cDeploymentConfiguration ?~ (serviceDeploymentConf $ deployment ^. sdDeploymentStrategy)+  $ ECS.cPlacementStrategy .~ (deployment ^. sdPlacementStrategy)+  $ ECS.createService serviceName (toText tdId) (deployment ^. sdDesiredCount)+  where loadBalancerConf container pm =+          let linkElb lnk =+                  ECS.lbContainerName ?~ (container ^. cName)+                $ ECS.lbContainerPort ?~ (pm ^. pmContainerPort)+                $ assignLink+                $ ECS.loadBalancer+                where assignLink = case lnk of+                        ELBNameLink     x -> ECS.lbLoadBalancerName ?~ x+                        TargetGroupLink x -> ECS.lbTargetGroupARN   ?~ x+          in linkElb <$> (pm ^. pmElbLink)++        containerLoadBalancers = catMaybes $ do+          cont <- deployment ^. sdContainers+          pm   <- cont ^. cPortMappings+          return $ loadBalancerConf cont pm++updateServiceReq :: ClusterRef -> NamedServiceDeployment -> TaskDefId -> ECS.UpdateService+updateServiceReq clusterRef (serviceName, deployment) tdId =+    ECS.usCluster ?~ (toText clusterRef)+  $ ECS.usTaskDefinition ?~ (toText tdId)+  $ ECS.usDesiredCount ?~ (deployment ^. sdDesiredCount)+  $ ECS.usDeploymentConfiguration ?~ (serviceDeploymentConf $ deployment ^. sdDeploymentStrategy)+  $ ECS.updateService serviceName++deleteServiceReq :: ClusterRef -> NamedServiceDeployment -> ECS.DeleteService+deleteServiceReq clusterRef (serviceName, _) =+    ECS.dsCluster ?~ (toText clusterRef)+  $ ECS.deleteService serviceName++-- Implementation helper functions++deploymentComplete :: TaskDefId -> Getter ECS.ContainerService Bool+deploymentComplete tdi = to $ isComplete . taskDeployment+  where taskDeployment :: ECS.ContainerService -> Maybe ECS.Deployment+        taskDeployment service = listToMaybe+          $ filter (\x -> maybe False (T.isSuffixOf (toText tdi)) (x ^. ECS.dTaskDefinition))+          $ service ^. ECS.csDeployments++        isComplete :: Maybe ECS.Deployment -> Bool+        isComplete mdeployment = maybe False id $ do+          deployment <- mdeployment+          running    <- deployment ^. ECS.dRunningCount+          desired    <- deployment ^. ECS.dDesiredCount+          return (running == desired)++serviceDeployed :: TaskDefId -> Wait ECS.DescribeServices+serviceDeployed taskId = Wait+  { _waitName = "serviceDeployed"+  , _waitAttempts = 100+  , _waitDelay = 6+  , _waitAcceptors =+    [ matchAny+        "MISSING"+        AcceptFailure+        (folding (concatOf ECS.dssrsFailures) . ECS.fReason . _Just . to toTextCI)+    , matchAny+        True+        AcceptSuccess+        (folding (concatOf ECS.dssrsServices) . (deploymentComplete taskId))+    ]+  }++waitServiceStateChange :: (MonadResource m, MonadBaseControl IO m)+                       => (ContainerServiceRef -> m ())+                       -> (ContainerServiceRef -> m ())+                       -> (ContainerServiceRef -> m ())+                       -> Wait ECS.DescribeServices+                       -> ECS.ContainerService+                       -> GrootM m ()+waitServiceStateChange onStart onSuccess onFailure waiter service = do+  env <- ask+  serviceRef <- case (service ^. ECS.csServiceName) of+    Nothing -> fail "No service name defined!"+    Just  x -> pure $ ContainerServiceRef x+  lift $ onStart serviceRef+  waitResult <- runAWS env $ await waiter describeIt+  lift $ case waitResult of+    AcceptSuccess -> onSuccess serviceRef+    _             -> onFailure serviceRef+  where describeIt :: ECS.DescribeServices+        describeIt =+            ECS.dCluster .~ (service ^. ECS.csClusterARN)+          $ ECS.dServices .~ (maybeToList $ service ^. ECS.csServiceARN)+          $ ECS.describeServices++waitForServiceDeployed :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+                       => ClusterRef+                       -> (ECS.ContainerService, Wait ECS.DescribeServices)+                       -> GrootM m ()+waitForServiceDeployed clusterRef (service, waiter) =+  let onStart serviceRef =+        putInfo $ "Waiting for service"+          <+> (styled yellowStyle $ toText serviceRef)+          <+> "to complete deployment on cluster"+          <+> (styled yellowStyle $ toText clusterRef)+          <+> "..."+      onSuccess serviceRef =+        putSuccess $ "Service"+          <+> (styled yellowStyle $ toText serviceRef)+          <+> "successfully deployed on cluster"+          <+> (styled yellowStyle $ toText clusterRef)+          <+> "."+      onFailure serviceRef = do+        errMsg <- pure "Service did not stabilize."+        throwM $ failedServiceDeployment serviceRef clusterRef (Just errMsg)+  in waitServiceStateChange onStart onSuccess onFailure waiter service++waitForServiceUndeployed :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+                         => ClusterRef+                         -> ECS.ContainerService+                         -> GrootM m ()+waitForServiceUndeployed clusterRef =+  let onStart serviceRef =+        putInfo $ "Waiting for service"+          <+> (styled yellowStyle $ toText serviceRef)+          <+> "to be removed from cluster"+          <+> (styled yellowStyle $ toText clusterRef)+          <+> "..."+      onSuccess serviceRef =+        putSuccess $ "Service"+          <+> (styled yellowStyle $ toText serviceRef)+          <+> "has been successfully removed from cluster"+          <+> (styled yellowStyle $ toText clusterRef)+          <+> "."+      onFailure serviceRef =+        throwM $ failedServiceDeletion serviceRef clusterRef+  in waitServiceStateChange onStart onSuccess onFailure ECS.servicesInactive++-- Free monad operations implementation++serviceExists' :: (MonadResource m, MonadBaseControl IO m)+               => Text+               -> ClusterRef+               -> GrootM m Bool+serviceExists' serviceName clusterRef = do+  env <- ask+  hoist (runAWS env) $ awsToGrootM $ (maybe False (const True) <$> check)+  where foundServices = findService (ContainerServiceRef serviceName) (Just clusterRef)+        check         = runMaybeT $ filterM isActiveContainerService foundServices++verifyActiveCluster' :: (MonadResource m, MonadBaseControl IO m) => ClusterRef -> GrootM m ()+verifyActiveCluster' clusterRef = do+  env <- ask+  runAWS env $ do+    cluster <- getCluster clusterRef+    case (maybeMatches isActiveCluster cluster) of+      Nothing -> throwM $ invalidClusterStatus clusterRef CSInactive (Just CSActive)+      Just  _ -> return ()++registerTask' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+              => GrootManifest+              -> NamedServiceDeployment+              -> GrootM m TaskDefId+registerTask' manifest service@(serviceName, _) = do+  putInfo $ "Registering task definition for service " <> styled yellowStyle serviceName+  env   <- ask+  res   <- lift $ runAWS env . send $ createTaskDefinitionReq manifest service+  mtask <- pure $ res ^. ECS.rtdrsTaskDefinition >>= taskDefId+  case mtask of+    Nothing   -> throwM $ failedToRegisterTaskDef (TaskDefRef serviceName)+    Just task -> do+      putSuccess $ "Task for service"+        <+> styled yellowStyle serviceName+        <+> "has been registed as"+        <+> styled yellowStyle (toText task)+      return task++modifyService' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+               => (NamedServiceDeployment -> ClusterRef -> TaskDefId -> GrootM m (Maybe ECS.ContainerService))+               -> NamedServiceDeployment+               -> ClusterRef+               -> TaskDefId+               -> GrootM m (ECS.ContainerService, Wait ECS.DescribeServices)+modifyService' awsAction service@(serviceName, _) clusterRef taskId = do+  mservice <- awsAction service clusterRef taskId+  case mservice of+    Nothing  -> throwM $ failedServiceDeployment (ContainerServiceRef serviceName) clusterRef Nothing+    Just srv -> return (srv, serviceDeployed taskId)++createService' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+               => NamedServiceDeployment+               -> ClusterRef+               -> TaskDefId+               -> GrootM m (ECS.ContainerService, Wait ECS.DescribeServices)+createService' = modifyService' $ \service@(serviceName, _) clusterRef taskId -> do+  putInfo $ "Creating service" <+> styled yellowStyle serviceName <+> "with task" <+> (styled yellowStyle $ toText taskId)+  env       <- ask+  createReq <- pure $ createServiceReq clusterRef service taskId+  runAWS env $ fmap (\x -> x ^. ECS.csrsService) . send $ createReq++updateService' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+               => NamedServiceDeployment+               -> ClusterRef+               -> TaskDefId+               -> GrootM m (ECS.ContainerService, Wait ECS.DescribeServices)+updateService' = modifyService' $ \service@(serviceName, _) clusterRef taskId -> do+  putInfo $ "Updating service" <+> styled yellowStyle serviceName <+> "with task" <+> (styled yellowStyle $ toText taskId)+  env       <- ask+  updateReq <- pure $ updateServiceReq clusterRef service taskId+  runAWS env $ fmap (\x -> x ^. ECS.usrsService) . send $ updateReq++removeService' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+               => NamedServiceDeployment+               -> ClusterRef+               -> GrootM m ECS.ContainerService+removeService' service@(serviceName, _) clusterRef = do+  putInfo $ "Deleting service" <+> styled yellowStyle serviceName <> "."+  env       <- ask++  let csRef = ContainerServiceRef serviceName+  current   <- runAWS env $ runMaybeT $ findService csRef (Just clusterRef)++  case current of+    Nothing -> throwM $ serviceNotFound csRef (Just clusterRef)+    Just  c -> do+      updateReq <- pure $ ECS.usDesiredCount ?~ 0 $ ECS.usCluster ?~ (toText clusterRef) $ ECS.updateService serviceName+      runAWS env $ send updateReq+      deleteReq <- pure $ deleteServiceReq clusterRef service+      res <- runAWS env $ send deleteReq+      case (res ^. ECS.dsrsService) of+        Nothing -> throwM $ serviceNotFound csRef (Just clusterRef)+        Just  x -> return x++awsServiceCompose :: (MonadConsole m, MonadResource m, MonadBaseControl IO m) => GrootManifest -> ServiceComposeM a -> GrootM m a+awsServiceCompose manifest = foldFree $ \case+  RegisterTask service next ->+    next <$> registerTask' manifest service+  ServiceExists name clusterRef next ->+    next <$> serviceExists' name clusterRef+  CreateService service cluster taskId next ->+    (const next) <$> (createService' service cluster taskId >>= waitForServiceDeployed cluster)+  UpdateService service cluster taskId next ->+    (const next) <$> (updateService' service cluster taskId >>= waitForServiceDeployed cluster)+  RemoveService service cluster next ->+    (const next) <$> (removeService' service cluster >>= waitForServiceUndeployed cluster)+  VerifyActiveCluster cluster next ->+    (const next) <$> verifyActiveCluster' cluster
+ src/Groot/Compose/Service/DryRun.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.Compose.Service.DryRun (dryRunServiceCompose) where++import           Control.Monad.Free+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Resource+import           Data.Semigroup               ((<>))+import           Network.AWS++import           Groot.Compose.Service.AWS    (serviceExists',+                                               verifyActiveCluster')+import           Groot.Compose.Service.Free+import           Groot.Console+import           Groot.Core+import           Groot.Data.Text+import           Groot.Exception+import           Groot.Manifest+import           Groot.Types++registerTask' :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+              => NamedServiceDeployment+              -> GrootM m TaskDefId+registerTask' (serviceName, _) = do+  putInfo $ "Registering task definition for service " <> styled yellowStyle serviceName+  env  <- ask+  tdId <- runAWS env . runMaybeT $ do+    taskDef <- getTaskDef (TaskDefRef serviceName)+    MaybeT . pure $ nextTaskDefId <$> taskDefId taskDef+  case tdId of+    Nothing    -> do+      let theId = TaskDefId (TaskFamily serviceName) 0+      putSuccess $ "Would have created task" <+> (styled yellowStyle $ toText theId)+      return theId+    Just theId -> do+      putSuccess $ "Would have upgrade task to" <+> (styled yellowStyle $ toText theId)+      return theId++createService' :: MonadConsole m+               => NamedServiceDeployment+               -> ClusterRef+               -> TaskDefId+               -> m ()+createService' (serviceName, _) clusterRef tdId =+  putInfo $ "Creates a new service named" <+> (styled yellowStyle serviceName)+    <+> "in cluster" <+> (styled yellowStyle $ toText clusterRef)+    <+> "linked to task" <+> (styled yellowStyle $ toText tdId)++updateService' :: MonadConsole m+               => NamedServiceDeployment+               -> ClusterRef+               -> TaskDefId+               -> m ()+updateService' (serviceName, _) clusterRef tdId =+  putInfo $ "Updates service named" <+> (styled yellowStyle serviceName)+    <+> "in cluster" <+> (styled yellowStyle $ toText clusterRef)+    <+> "linked to task" <+> (styled yellowStyle $ toText tdId)++removeService' :: MonadConsole m+               => NamedServiceDeployment+               -> ClusterRef+               -> m ()+removeService' (serviceName, _) clusterRef =+  putInfo $ "Deletes service named" <+> (styled yellowStyle serviceName)+    <+> "from cluster" <+> (styled yellowStyle $ toText clusterRef)++dryRunServiceCompose :: (MonadConsole m, MonadResource m, MonadBaseControl IO m)+                     => GrootManifest+                     -> ServiceComposeM a+                     -> GrootM m a+dryRunServiceCompose _ = foldFree $ \case+  RegisterTask service next ->+    next <$> registerTask' service+  ServiceExists name clusterRef next ->+    next <$> serviceExists' name clusterRef+  CreateService service cluster taskId next ->+    (const next) <$> createService' service cluster taskId+  UpdateService service cluster taskId next ->+    (const next) <$> updateService' service cluster taskId+  RemoveService service cluster next ->+    (const next) <$> removeService' service cluster+  VerifyActiveCluster cluster next ->+    (const next) <$> verifyActiveCluster' cluster
+ src/Groot/Compose/Service/Free.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveFunctor    #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell  #-}++module Groot.Compose.Service.Free where++import           Control.Monad+import           Control.Monad.Free+import           Control.Monad.Free.TH+import           Data.Text             (Text)++import           Groot.Manifest+import           Groot.Types++data ServiceComposeOp next =+    RegisterTask NamedServiceDeployment (TaskDefId -> next)+  | ServiceExists Text ClusterRef (Bool -> next)+  | CreateService NamedServiceDeployment ClusterRef TaskDefId next+  | UpdateService NamedServiceDeployment ClusterRef TaskDefId next+  | RemoveService NamedServiceDeployment ClusterRef next+  | VerifyActiveCluster ClusterRef next+  deriving Functor++makeFree ''ServiceComposeOp++type ServiceComposeM = Free ServiceComposeOp++deployService :: ClusterRef -> NamedServiceDeployment -> ServiceComposeM ()+deployService clusterRef service = do+  verifyActiveCluster clusterRef+  taskDefId <- registerTask service+  exists    <- serviceExists (fst service) clusterRef+  if exists+  then updateService service clusterRef taskDefId+  else createService service clusterRef taskDefId++deployServices :: Traversable f => ClusterRef -> f NamedServiceDeployment -> ServiceComposeM ()+deployServices clusterRef = void . traverse (\serv -> deployService clusterRef serv)+{-# INLINE deployServices #-}++deleteServices :: Traversable f => ClusterRef -> f NamedServiceDeployment -> ServiceComposeM ()+deleteServices clusterRef = void . traverse (\serv -> removeService serv clusterRef)+{-# INLINE deleteServices #-}
+ src/Groot/Config.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.Config+       (+       -- Default config values+         defaultSectionName+       , defaultConfigFile+       , defaultCredsFile+       -- Utilities+       , regionFromConfig+       ) where++import           Control.Applicative+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except+import           Data.Ini+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Network.AWS                (Region)+import           Network.AWS.Data.Text+import           System.Directory++defaultSectionName :: Text+defaultSectionName = "default"++defaultConfigFile :: IO FilePath+defaultConfigFile = (++ "/.aws/config") <$> getHomeDirectory++defaultCredsFile :: IO FilePath+defaultCredsFile = (++ "/.aws/credentials") <$> getHomeDirectory++sectionNameFromProfile :: Text -> Text+sectionNameFromProfile s+  | s == defaultSectionName = s+  | otherwise               = T.append "profile " s++lookupRegionFromConfig :: Maybe Text -> Ini -> Either String Region+lookupRegionFromConfig profile config =+  fromText =<< lookupWithFallback profile "region" config+  where lookupWithFallback :: Maybe Text -> Text -> Ini -> Either String Text+        lookupWithFallback Nothing  key cfg =+          lookupValue defaultSectionName key cfg+        lookupWithFallback (Just x) key cfg =+              lookupValue (sectionNameFromProfile x) key cfg+          <|> lookupWithFallback Nothing key cfg++regionFromConfig :: MonadIO m => FilePath -> Maybe Text -> ExceptT String m Region+regionFromConfig filename profile = do+  ini <- ExceptT . liftIO $ readIniFile filename+  ExceptT . return $ lookupRegionFromConfig profile ini
+ src/Groot/Console.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module      : Groot.Console+Description : Code abstrations for Groot to operate with the terminal/console+Copyright   : A. Alonso Dominguez (c) 2017, http://github.com/alonsodomin+License     : Apache 2.0+Maintainer  : A. Alonso Dominguez <alonso.domin (λ) google>+Stability   : experimental+Portability : portable++This is a module providing some abstractions to interact with the user via the+terminal's console in a rich maner.+-}+module Groot.Console+     ( Severity (..)+     , MonadConsole (..)+     -- User Prompts+     , askUserYN+     , askUserToContinue+     -- User messages+     , putInfo+     , putWarn+     , putError+     , putSuccess+     , putDebug+     ) where++import           Control.Monad.IO.Class+import           Control.Monad.Trans+import           Control.Monad.Trans.Identity (IdentityT)+import           Control.Monad.Trans.Maybe    (MaybeT)+import           Data.Semigroup+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import qualified Data.Text.IO                 as T+import           System.IO++import           Groot.Data.Text.Display+import           Groot.Data.Text.Styled       as ST++errorText, warnText, infoText, successText, debugText :: StyledText+errorText   = styled redStyle    "ERROR"+warnText    = styled yellowStyle "WARN"+infoText    = styled blueStyle   "INFO"+successText = styled greenStyle  "DONE"+debugText   = styled cyanStyle   "DEBUG"++-- |Severity level of the different output messages+data Severity = Error | Warn | Info | Success | Debug+  deriving (Eq, Show, Enum, Bounded, Ord)++-- |Definition of operations availbale when interacting with the user via the+-- terminal console+class Monad m => MonadConsole m where+  -- |Puts a message with a given severity in the console output+  putMessage :: Display a => Severity -> a -> m ()+  -- |Prompts the user for input+  askUser :: Display a => a -> m (Maybe Text)++instance (Monad m, MonadIO m) => MonadConsole m where+  putMessage sev txt = do+    display $ levelStr <> (ST.singleton ' ')+    displayLn txt+      where levelStr = case sev of+              Error   -> errorText+              Warn    -> warnText+              Info    -> infoText+              Success -> successText+              Debug   -> debugText++  askUser prompt = do+    answer <- liftIO $ do+      display prompt+      hFlush stdout+      T.getLine+    return $ if answer == ""+      then Nothing+      else Just answer++instance MonadConsole m => MonadConsole (IdentityT m) where+  putMessage sev txt = lift $ putMessage sev txt+  askUser = lift . askUser+instance MonadConsole m => MonadConsole (MaybeT m) where+  putMessage sev txt = lift $ putMessage sev txt+  askUser = lift . askUser++-- |Prompts the user for a 'yes' or 'no' answer+askUserYN :: MonadConsole m => Bool -> Text -> m Bool+askUserYN def msg = do+  answer <- askUser $ T.append msg defStr+  return $ handleAnswer answer+  where defStr = T.concat [ " [", (if def then "Yn" else "yN"), "] "]++        parseAnswer s =+          let s' = T.toLower s+          in (s' == "y") || (s' == "yes")++        handleAnswer Nothing  = def+        handleAnswer (Just s) = parseAnswer s++-- |Prompts the user for a 'yes' or 'no' answer. The given continuation+-- action will be performed in case she answers 'yes' or a synonym.+askUserToContinue :: MonadConsole m => Text -> m () -> m ()+askUserToContinue msg cont = do+  answer <- askUserYN False msg+  if answer then cont+  else return ()++-- |Outputs an 'INFO' message+putInfo :: (MonadConsole m, Display a) => a -> m ()+putInfo = putMessage Info++-- |Outputs an 'WARN' message+putWarn :: (MonadConsole m, Display a) => a -> m ()+putWarn = putMessage Warn++-- |Outputs an 'ERROR' message+putError :: (MonadConsole m, Display a) => a -> m ()+putError = putMessage Error++-- |Outputs an 'SUCCESS' message+putSuccess :: (MonadConsole m, Display a) => a -> m ()+putSuccess = putMessage Success++-- |Outputs an 'DEBUG' message+putDebug :: (MonadConsole m, Display a) => a -> m ()+putDebug = putMessage Debug
+ src/Groot/Core.hs view
@@ -0,0 +1,42 @@+module Groot.Core+     (+       module Groot.AWS+     , module Groot.Core.Common+     ) where++import           Groot.AWS+import           Groot.Core.Common++-- Tasks++-- stopTask :: MonadAWS m+--          => TaskRef+--          -> ClusterRef+--          -> (TaskRef -> ClusterRef -> m ())+--          -> (TaskRef -> ClusterRef -> m ())+--          -> m ()+-- stopTask tref@(TaskRef taskRef) clusterRef onStop onStopped =+--   let describeReq = dtCluster ?~ (toText clusterRef) $ dtTasks .~ [taskRef] $ describeTasks+--   in do+--     send $ stCluster ?~ (toText clusterRef) $ ECS.stopTask taskRef+--     onStop tref clusterRef+--     result <- A.await tasksStopped describeReq+--     case result of+--       AcceptSuccess -> onStopped tref clusterRef+--       _             -> throwM $ taskStatusTransitionFailed tref TSRunning TSStopped++-- startTask :: MonadAWS m+--           => TaskRef+--           -> ClusterRef+--           -> (TaskRef -> ClusterRef -> m ())+--           -> (TaskRef -> ClusterRef -> m ())+--           -> m ()+-- startTask tref@(TaskRef taskRef) clusterRef onStart onStarted =+--   let describeReq = dtCluster ?~ (toText clusterRef) $ dtTasks .~ [taskRef] $ describeTasks+--   in do+--     send $ sCluster ?~ (toText clusterRef) $ ECS.startTask taskRef+--     onStart tref clusterRef+--     result <- A.await tasksRunning describeReq+--     case result of+--       AcceptSuccess -> onStarted tref clusterRef+--       _             -> throwM $ taskStatusTransitionFailed tref TSStopped TSRunning
+ src/Groot/Core/Common.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Groot.Core.Common where++import           Control.Monad.Catch+import           Control.Monad.Reader+import           Control.Monad.Trans.Identity (IdentityT)+import           Control.Monad.Trans.Maybe    (MaybeT)+import           Control.Monad.Trans.Resource+import           Control.Monad.Trans.State    (StateT)+import           Network.AWS++type GrootM = ReaderT Env+type GrootAWS = GrootM AWS+type GrootIO = GrootM IO++awsToGrootM :: (MonadResource m, MonadBaseControl IO m) => AWS a -> GrootM m a+awsToGrootM act = do+  env <- ask+  runAWS env act++awsToGrootM_ :: (MonadResource m, MonadBaseControl IO m) => AWS a -> GrootM m ()+awsToGrootM_ aws = (\_ -> pure ()) =<< awsToGrootM aws++runGroot :: (MonadBaseControl IO m, MonadIO m) => GrootM m a -> Env -> m a+runGroot = runReaderT+{-# INLINE runGroot #-}++mapGrootM :: (m a -> n b) -> GrootM m a -> GrootM n b+mapGrootM = mapReaderT+{-# INLINE mapGrootM #-}++class (MonadBaseControl n m, MonadIO m, MonadCatch m, MonadReader Env m) => MonadGroot n m where+  liftGroot :: GrootM n a -> m a++instance MonadGroot IO GrootIO where+  liftGroot = id++instance MonadGroot n m => MonadGroot n (IdentityT   m) where liftGroot = lift . liftGroot+instance MonadGroot n m => MonadGroot n (MaybeT      m) where liftGroot = lift . liftGroot+instance MonadGroot n m => MonadGroot n (ReaderT Env m) where liftGroot = lift . liftGroot+instance MonadGroot n m => MonadGroot n (ResourceT   m) where liftGroot = lift . liftGroot+instance MonadGroot n m => MonadGroot n (StateT    s m) where liftGroot = lift . liftGroot
+ src/Groot/Core/Events.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Groot.Core.Events+       ( serviceEventLog+       , clusterServiceEventLog+       , printEventSink+       ) where++import           Control.Applicative+import           Control.Concurrent             (killThread)+import           Control.Concurrent.STM+import           Control.Concurrent.STM.Delay+import           Control.Concurrent.STM.TBMChan+import           Control.Exception.Lens+import qualified Control.Exception.Lifted       as Lifted+import           Control.Lens                   hiding (argument)+import           Control.Monad+import           Control.Monad.Catch+import           Control.Monad.Morph+import           Control.Monad.Reader+import           Control.Monad.Trans.Control+import           Control.Monad.Trans.Resource+import           Control.Monad.Trans.State.Lazy+import           Data.Conduit+import qualified Data.Conduit.List              as CL+import           Data.Maybe                     (listToMaybe)+import           Data.Text                      (Text)+import qualified Data.Text                      as T+import           Data.Time+import           Data.Typeable+import           Network.AWS                    hiding (await)+import qualified Network.AWS.ECS                as ECS++import           Groot.AWS+import           Groot.Console+import           Groot.Data.Conduit.STM+import           Groot.Data.Filter+import           Groot.Data.Text+import           Groot.Exception+import           Groot.Types++formatEventTime :: MonadIO m => UTCTime -> m Text+formatEventTime time = do+  dt <- liftIO $ utcToLocalZonedTime time+  return . T.pack $ formatTime defaultTimeLocale "%d/%m/%Y %T" dt++pollServiceEvents :: (MonadReader e m, MonadBaseControl IO m, MonadIO m, HasEnv e)+                  => ContainerServiceCoords+                  -> Bool+                  -> Int+                  -> TBMChan ECS.ServiceEvent+                  -> (TBMChan ECS.ServiceEvent -> STM ())+                  -> m ()+pollServiceEvents (ContainerServiceCoords serviceRef clusterRef) inf lastN chan onComplete =+  evalStateT loop Nothing+  where loop :: (MonadReader e m, MonadIO m, HasEnv e) => StateT (Maybe UTCTime) m ()+        loop = do+          env           <- lift $ ask+          lastEventTime <- get+          events        <- liftIO . runResourceT . runAWS env $ serviceEvents lastEventTime+          liftIO $ forM_ (reverse events) $ atomically . tryWriteTBMChan chan+          if inf then do+            delay <- liftIO $ newDelay 2000000+            let nextTime = listToMaybe events >>= view ECS.seCreatedAt+            liftIO . atomically $ waitDelay delay+            put $ nextTime <|> lastEventTime+            loop+          else liftIO . atomically $ onComplete chan++        serviceEvents :: MonadAWS m => Maybe UTCTime -> m [ECS.ServiceEvent]+        serviceEvents lastEventTime = do+          service  <- getService serviceRef (Just clusterRef)+          service' <- if (matches isActiveContainerService service)+                      then return service+                      else throwM $ inactiveService serviceRef clusterRef+          events  <- return $ service' ^. ECS.csEvents+          return $ case lastEventTime of+            Nothing -> take lastN events+            Just t  -> takeWhile (\ev -> maybe False (> t) $ ev ^. ECS.seCreatedAt) events++serviceEventLog :: Typeable mi+                => MonadResource mi+                => MonadBaseControl IO mi+                => MonadCatch mi+                => MonadReader e mi+                => MonadConsole mi+                => MonadIO mo+                => HasEnv e+                => [ContainerServiceCoords]+                -> Bool+                -> Int+                -> mi (Source mo ECS.ServiceEvent)+serviceEventLog coords inf lastN = do+  chan     <- liftIO . atomically $ newTBMChan 500+  refCount <- liftIO . atomically . newTVar $ length coords+  regs     <- forM coords (forkEventStream chan refCount)+  return $ chanSource chan readTBMChan (\ch -> do liftIO . atomically $ closeTBMChan ch+                                                  mapM_ release regs)++  where+    forkEventStream chan refCount serviceCoord = Lifted.mask_ $ do+      threadId <- runResourceT $ resourceForkIO $ lift $ publishInto chan serviceCoord $ decRefCount refCount+      register . killThread $ threadId++    modifyTVar'' :: TVar a -> (a -> a) -> STM a+    modifyTVar'' tvar f = do+      x <- f <$> readTVar tvar+      writeTVar tvar x+      return x++    decRefCount :: TVar Int -> TBMChan a -> STM ()+    decRefCount tvar chan = do+      n <- modifyTVar'' tvar (subtract 1)+      when (n == 0) $ closeTBMChan chan++    handleStreamErrors :: (Typeable m, MonadCatch m, MonadConsole m) => m () -> m ()+    handleStreamErrors action = catches action [+        handler _InactiveService (\_ -> pure ())+      , handler _TransportError  handleHttpException+      , handler _ServiceError    handleServiceError+      ]++    publishInto :: (Typeable m, MonadReader e m, MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadConsole m, HasEnv e)+                => TBMChan ECS.ServiceEvent+                -> ContainerServiceCoords+                -> (TBMChan ECS.ServiceEvent -> STM ())+                -> m ()+    publishInto chan crds onComplete =+      handleStreamErrors $ pollServiceEvents crds inf lastN chan onComplete++clusterServiceEventLog :: Typeable mi+                       => MonadResource mi+                       => MonadBaseControl IO mi+                       => MonadCatch mi+                       => MonadIO mo+                       => MonadConsole mi+                       => MonadReader e mi+                       => HasEnv e+                       => [ClusterRef]+                       -> Bool+                       -> Int+                       -> mi (Source mo ECS.ServiceEvent)+clusterServiceEventLog clusterRefs inf lastN = do+  env    <- ask+  coords <- runResourceT . runAWS env $ allServiceCoords+  serviceEventLog coords inf lastN+  where clusterServiceCoords :: MonadAWS m => ClusterRef -> m [ContainerServiceCoords]+        clusterServiceCoords cref = sourceToList $ fetchServices cref+          =$= filterC isActiveContainerService+          =$= CL.mapMaybe serviceCoords++        allServiceCoords :: MonadAWS m => m [ContainerServiceCoords]+        allServiceCoords = do+          coords <- concat <$> mapM clusterServiceCoords clusterRefs+          return coords++printEvent :: MonadIO m => ECS.ServiceEvent -> m ()+printEvent event = do+  eventTime <- maybe (return "") formatEventTime $ event ^. ECS.seCreatedAt+  displayLn $ (styled yellowStyle eventTime) <+> (styleless $ maybe "" id $ event ^. ECS.seMessage)++printEventSink :: MonadIO m => Sink ECS.ServiceEvent m ()+printEventSink = do+  mevent <- await+  case mevent of+    Just event -> do+      printEvent event+      printEventSink+    Nothing -> return ()
+ src/Groot/Data/Conduit/STM.hs view
@@ -0,0 +1,20 @@+module Groot.Data.Conduit.STM where++import           Control.Concurrent.STM+import           Control.Monad.IO.Class+import           Data.Conduit++-- | Creates a Conduit Source from an async channel+chanSource :: MonadIO m+           => chan+           -> (chan -> STM (Maybe a))+           -> (chan -> IO ())+           -> Source m a+chanSource ch reader closer = loop+  where loop = do+          a <- liftIO . atomically $ reader ch+          case a of+            Just x  -> yieldOr x close >> loop+            Nothing -> return ()++        close = liftIO $ closer ch
+ src/Groot/Data/Filter.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}++module Groot.Data.Filter where++import           Control.Monad+import           Data.Conduit+import qualified Data.Conduit.List     as CL+import           Data.Functor.Identity++data FilterOp a =+    Or a a+  | And a a+  | Not a+  deriving (Eq, Show)++class Filter a where+  type FilterItem a :: *++  matches :: a -> FilterItem a -> Bool++  maybeMatchesM :: Monad m => a -> m (FilterItem a) -> m (Maybe (FilterItem a))+  maybeMatchesM p me = do+    e <- me+    return $ if (matches p e) then (Just e) else Nothing++  maybeMatches :: a -> FilterItem a -> Maybe (FilterItem a)+  maybeMatches p e = runIdentity $ maybeMatchesM p (Identity e)++  (|||) :: a -> a -> FilterOp a+  (|||) x y = Or x y++  (&&&) :: a -> a -> FilterOp a+  (&&&) x y = And x y++  notP :: a -> FilterOp a+  notP x = Not x++instance Filter a => Filter (FilterOp a) where+  type FilterItem (FilterOp a) = FilterItem a++  matches (Or x y)  res = (matches x res) || (matches y res)+  matches (And x y) res = (matches x res) && (matches y res)+  matches (Not x)   res = not (matches x res)++filterOnM :: (MonadPlus m, Filter p)+          => (a -> FilterItem p)+          -> p                        -- The actual predicate+          -> m a                      -- The item to which to apply the filter, wrapped in a Monad+          -> m a                      -- The result after applying the predicate, wrapped in the same Monad+filterOnM f p = mfilter (\x -> matches p $ f x)++filterM :: (MonadPlus m, Filter p)+        => p+        -> m (FilterItem p)+        -> m (FilterItem p)+filterM = filterOnM id++filterC :: (Monad m, Filter p)+        => p+        -> Conduit (FilterItem p) m (FilterItem p)+filterC = filterOnC id++filterOnC :: (Monad m, Filter p)+          => (a -> FilterItem p)+          -> p+          -> Conduit a m a+filterOnC f p = CL.filter (\x -> matches p $ f x)
+ src/Groot/Data/Text.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Groot.Data.Text+Description : Generic text manipulation module+Copyright   : A. Alonso Dominguez (c) 2017, http://github.com/alonsodomin+License     : Apache 2.0+Maintainer  : A. Alonso Dominguez <alonso.domin (λ) google>+Stability   : experimental+Portability : portable++This module aggregates the main text manipulation functionality needed+in Groot to operate.+-}+module Groot.Data.Text+     (+       module Network.AWS.Data.Text+     , module Groot.Data.Text.Display+     , module Groot.Data.Text.Styled+     , uuid+     , subparser+     ) where++import           Data.Attoparsec.Text+import           Data.Text               (Text)+import qualified Data.Text               as T+import           Data.UUID               (UUID)+import qualified Data.UUID               as UUID+import           Network.AWS.Data.Text   hiding (takeText)++import           Groot.Data.Text.Display+import           Groot.Data.Text.Styled++-- |Text parser for 'UUID's+uuid :: Parser UUID+uuid = do+  input <- takeText+  case (UUID.fromText input) of+    Nothing -> fromTextError $ T.append "Invalid UUID: " input+    Just x  -> return x++-- |Utility to compose text parsers+subparser :: FromText a => Text -> Parser a+subparser input = either (fromTextError . T.pack) return $ parseOnly parser input
+ src/Groot/Data/Text/Display.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Groot.Data.Text.Display+     ( Display (..)+     ) where++import           Control.Monad.IO.Class+import           Data.Text              (Text)+import qualified Data.Text              as T+import qualified Data.Text.IO           as T+import           Network.AWS.Data.Text++class ToText a => Display a where+  display :: MonadIO m => a -> m ()++  displayLn :: MonadIO m => a -> m ()+  displayLn d = do+    display d+    liftIO $ T.putStrLn ""++instance Display Char where+  display = liftIO . print+  {-# INLINE display #-}++instance Display Text where+  display = liftIO . T.putStr+  {-# INLINE display #-}++instance Display String where+  display = display . T.pack+  {-# INLINE display #-}
+ src/Groot/Data/Text/Styled.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.Data.Text.Styled+     ( Style+     , noStyle+     , blueStyle+     , redStyle+     , yellowStyle+     , greenStyle+     , cyanStyle+     , StyledText+     , styled+     , empty+     , singleton+     , styleless+     , (<+>)+     ) where++import           Control.Monad.IO.Class+import           Data.Foldable+import           Data.Semigroup+import           Data.String+import           Data.Text               (Text)+import qualified Data.Text               as T+import qualified Data.Text.IO            as T+import           Network.AWS.Data.Text+import           System.Console.ANSI++import           Groot.Data.Text.Display++type Style = [SGR]++noStyle, blueStyle, redStyle, yellowStyle, greenStyle, cyanStyle :: Style+noStyle     = [Reset]+blueStyle   = [SetColor Foreground Dull Blue]+redStyle    = [SetColor Foreground Vivid Red]+yellowStyle = [SetColor Foreground Dull Yellow]+greenStyle  = [SetColor Foreground Dull Green]+cyanStyle   = [SetColor Foreground Dull Cyan]++data StyledText =+    TextSpan Style Text+  | TextBlock [StyledText]+  deriving (Eq, Show)++styled :: Style -> Text -> StyledText+styled = TextSpan+{-# INLINE styled #-}++empty :: StyledText+empty = styled noStyle T.empty+{-# INLINE empty #-}++singleton :: Char -> StyledText+singleton ch = styled noStyle (T.singleton ch)+{-# INLINE singleton #-}++styleless :: Text -> StyledText+styleless = styled noStyle+{-# INLINE styleless #-}++instance IsString StyledText where+  fromString str = styled noStyle (T.pack str)++instance Semigroup StyledText where+  lhs@(TextSpan _ _) <> rhs@(TextSpan _ _) = TextBlock [lhs, rhs]+  lhs@(TextSpan _ _) <> (TextBlock bs)     = TextBlock (lhs:bs)+  (TextBlock bs)     <> rhs@(TextSpan _ _) = TextBlock (bs ++ [rhs])+  (TextBlock lhs)    <> (TextBlock rhs)    = TextBlock (lhs ++ rhs)++instance Monoid StyledText where+  mempty = empty+  mappend = (<>)++(<+>) :: StyledText -> StyledText -> StyledText+lhs <+> rhs = lhs <> (singleton ' ') <> rhs++instance ToText StyledText where+  toText (TextSpan _ txt) = txt+  toText (TextBlock xs)   = T.concat $ toText <$> xs++instance Display StyledText where+  display (TextSpan style txt) = liftIO $ do+    setSGR style+    T.putStr txt+  display (TextBlock xs) =+    forM_ xs display
+ src/Groot/Exception.hs view
@@ -0,0 +1,14 @@+module Groot.Exception+     (+       module Groot.Exception.Cluster+     , module Groot.Exception.Instance+     , module Groot.Exception.Task+     , module Groot.Exception.TaskDef+     , module Groot.Exception.Service+     ) where++import           Groot.Exception.Cluster+import           Groot.Exception.Instance+import           Groot.Exception.Service+import           Groot.Exception.Task+import           Groot.Exception.TaskDef
+ src/Groot/Exception/Cluster.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE LambdaCase #-}++module Groot.Exception.Cluster where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch    hiding (Handler)+import           Data.Typeable++import           Groot.Types++data ClusterException =+    ClusterNotFound ClusterNotFound+  | InvalidClusterStatus InvalidClusterStatus+  deriving (Eq, Show, Typeable)++instance Exception ClusterException++data ClusterNotFound =+  ClusterNotFound' ClusterRef+  deriving (Eq, Show, Typeable)++instance Exception ClusterNotFound++clusterNotFound :: ClusterRef -> SomeException+clusterNotFound = toException . ClusterNotFound . ClusterNotFound'++data InvalidClusterStatus =+  InvalidClusterStatus' ClusterRef ClusterStatus (Maybe ClusterStatus)+  deriving (Eq, Show, Typeable)++instance Exception InvalidClusterStatus++invalidClusterStatus :: ClusterRef -> ClusterStatus -> Maybe ClusterStatus -> SomeException+invalidClusterStatus clusterRef currentSt desiredSt =+  toException . InvalidClusterStatus $ InvalidClusterStatus' clusterRef currentSt desiredSt++class AsClusterException t where+  _ClusterException :: Prism' t ClusterException+  {-# MINIMAL _ClusterException #-}++  _ClusterNotFound :: Prism' t ClusterNotFound+  _ClusterNotFound = _ClusterException . _ClusterNotFound++  _InvalidClusterStatus :: Prism' t InvalidClusterStatus+  _InvalidClusterStatus = _ClusterException . _InvalidClusterStatus++instance AsClusterException SomeException where+  _ClusterException = exception++instance AsClusterException ClusterException where+  _ClusterException = id++  _ClusterNotFound = prism ClusterNotFound $ \case+    ClusterNotFound e -> Right e+    x                 -> Left x++  _InvalidClusterStatus = prism InvalidClusterStatus $ \case+    InvalidClusterStatus e -> Right e+    x                      -> Left x
+ src/Groot/Exception/Instance.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE LambdaCase #-}++module Groot.Exception.Instance where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch    hiding (Handler)+import           Data.Typeable+import           Groot.Types++data InstanceException =+    InstanceNotFound InstanceNotFound+  | DrainingInstance DrainingInstance+  deriving (Eq, Show, Typeable)++instance Exception InstanceException++data InstanceNotFound =+  InstanceNotFound' ContainerInstanceRef (Maybe ClusterRef)+  deriving (Eq, Show, Typeable)++instance Exception InstanceNotFound++instanceNotFound :: ContainerInstanceRef -> Maybe ClusterRef -> SomeException+instanceNotFound instanceRef clusterRef =+  toException . InstanceNotFound $ InstanceNotFound' instanceRef clusterRef++data DrainingInstance = DrainingInstance' ContainerInstanceRef+  deriving (Eq, Show, Typeable)++instance Exception DrainingInstance++drainingInstance :: ContainerInstanceRef -> SomeException+drainingInstance = toException . DrainingInstance . DrainingInstance'++class AsInstanceException t where+  _InstanceException :: Prism' t InstanceException+  {-# MINIMAL _InstanceException #-}++  _InstanceNotFound :: Prism' t InstanceNotFound+  _InstanceNotFound = _InstanceException . _InstanceNotFound++  _DrainingInstance :: Prism' t DrainingInstance+  _DrainingInstance = _InstanceException . _DrainingInstance++instance AsInstanceException SomeException where+  _InstanceException = exception++instance AsInstanceException InstanceException where+  _InstanceException = id++  _InstanceNotFound = prism InstanceNotFound $ \case+    InstanceNotFound e -> Right e+    x                  -> Left x++  _DrainingInstance = prism DrainingInstance $ \case+    DrainingInstance e -> Right e+    x                  -> Left x
+ src/Groot/Exception/Service.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE LambdaCase #-}++module Groot.Exception.Service where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch    hiding (Handler)+import           Data.Text              (Text)+import           Data.Typeable+import           Groot.Types++data ServiceException =+    ServiceNotFound ServiceNotFound+  | AmbiguousServiceName AmbiguousServiceName+  | InactiveService InactiveService+  | FailedServiceDeployment FailedServiceDeployment+  | FailedServiceDeletion FailedServiceDeletion+  | UndefinedService UndefinedService+  deriving (Eq, Show, Typeable)++instance Exception ServiceException++data ServiceNotFound =+  ServiceNotFound' ContainerServiceRef (Maybe ClusterRef)+  deriving (Eq, Show, Typeable)++serviceNotFound :: ContainerServiceRef -> Maybe ClusterRef -> SomeException+serviceNotFound serviceName clusterRef =+  toException . ServiceNotFound $ ServiceNotFound' serviceName clusterRef++instance Exception ServiceNotFound++data AmbiguousServiceName =+  AmbiguousServiceName' ContainerServiceRef [ClusterRef]+  deriving (Eq, Typeable, Show)++ambiguousServiceName :: ContainerServiceRef -> [ClusterRef] -> SomeException+ambiguousServiceName serviceName clusters =+  toException . AmbiguousServiceName $ AmbiguousServiceName' serviceName clusters++instance Exception AmbiguousServiceName++data InactiveService =+  InactiveService' ContainerServiceRef ClusterRef+  deriving (Eq, Typeable, Show)++instance Exception InactiveService++inactiveService :: ContainerServiceRef -> ClusterRef -> SomeException+inactiveService serviceRef clusterRef =+  toException . InactiveService $ InactiveService' serviceRef clusterRef++data FailedServiceDeployment =+  FailedServiceDeployment' ContainerServiceRef ClusterRef (Maybe Text)+  deriving (Eq, Typeable, Show)++instance Exception FailedServiceDeployment++failedServiceDeployment :: ContainerServiceRef -> ClusterRef -> Maybe Text -> SomeException+failedServiceDeployment serviceRef clusterRef reason =+  toException . FailedServiceDeployment $ FailedServiceDeployment' serviceRef clusterRef reason++data FailedServiceDeletion =+  FailedServiceDeletion' ContainerServiceRef ClusterRef+  deriving (Eq, Typeable, Show)++instance Exception FailedServiceDeletion++failedServiceDeletion :: ContainerServiceRef -> ClusterRef -> SomeException+failedServiceDeletion serviceRef clusterRef =+  toException . FailedServiceDeletion $ FailedServiceDeletion' serviceRef clusterRef++data UndefinedService =+  UndefinedService' Text FilePath+  deriving (Eq, Typeable, Show)++instance Exception UndefinedService++undefinedService :: Text -> FilePath -> SomeException+undefinedService service sourceFile = toException . UndefinedService $ UndefinedService' service sourceFile++class AsServiceException t where+  _ServiceException :: Prism' t ServiceException+  {-# MINIMAL _ServiceException #-}++  _ServiceNotFound :: Prism' t ServiceNotFound+  _ServiceNotFound = _ServiceException . _ServiceNotFound++  _AmbiguousServiceName :: Prism' t AmbiguousServiceName+  _AmbiguousServiceName = _ServiceException . _AmbiguousServiceName++  _InactiveService :: Prism' t InactiveService+  _InactiveService = _ServiceException . _InactiveService++  _FailedServiceDeployment :: Prism' t FailedServiceDeployment+  _FailedServiceDeployment = _ServiceException . _FailedServiceDeployment++  _FailedServiceDeletion :: Prism' t FailedServiceDeletion+  _FailedServiceDeletion = _ServiceException . _FailedServiceDeletion++  _UndefinedService :: Prism' t UndefinedService+  _UndefinedService = _ServiceException . _UndefinedService++instance AsServiceException SomeException where+  _ServiceException = exception++instance AsServiceException ServiceException where+  _ServiceException = id++  _ServiceNotFound = prism ServiceNotFound $ \case+    ServiceNotFound e -> Right e+    x                 -> Left x++  _AmbiguousServiceName = prism AmbiguousServiceName $ \case+    AmbiguousServiceName e -> Right e+    x                      -> Left x++  _InactiveService = prism InactiveService $ \case+    InactiveService e -> Right e+    x                 -> Left x++  _FailedServiceDeployment = prism FailedServiceDeployment $ \case+    FailedServiceDeployment e -> Right e+    x                         -> Left x++  _FailedServiceDeletion = prism FailedServiceDeletion $ \case+    FailedServiceDeletion e -> Right e+    x                       -> Left x++  _UndefinedService = prism UndefinedService $ \case+    UndefinedService e -> Right e+    x                  -> Left x
+ src/Groot/Exception/Task.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE LambdaCase #-}++module Groot.Exception.Task where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch    hiding (Handler)+import           Data.Typeable+import           Groot.Types++data TaskException =+    TaskNotFound TaskNotFound+  | InvalidTaskStatus InvalidTaskStatus+  | TaskStatusTransitionFailed TaskStatusTransitionFailed+  deriving (Eq, Show, Typeable)++instance Exception TaskException++data TaskNotFound =+  TaskNotFound' TaskRef (Maybe ClusterRef)+  deriving (Eq, Show, Typeable)++instance Exception TaskNotFound++taskNotFound :: TaskRef -> Maybe ClusterRef -> SomeException+taskNotFound taskRef clusterRef =+  toException . TaskNotFound $ TaskNotFound' taskRef clusterRef++data InvalidTaskStatus =+  InvalidTaskStatus' TaskRef TaskStatus (Maybe TaskStatus)+  deriving (Eq, Show, Typeable)++instance Exception InvalidTaskStatus++invalidTaskStatus :: TaskRef -> TaskStatus -> Maybe TaskStatus -> SomeException+invalidTaskStatus taskRef currentSt desiredSt =+  toException . InvalidTaskStatus $ InvalidTaskStatus' taskRef currentSt desiredSt++data TaskStatusTransitionFailed =+  TaskStatusTransitionFailed' TaskRef TaskStatus TaskStatus+  deriving (Eq, Show, Typeable)++taskStatusTransitionFailed :: TaskRef -> TaskStatus -> TaskStatus -> SomeException+taskStatusTransitionFailed taskRef currentSt desiredSt =+  toException . TaskStatusTransitionFailed $ TaskStatusTransitionFailed' taskRef currentSt desiredSt++instance Exception TaskStatusTransitionFailed++class AsTaskException t where+  _TaskException :: Prism' t TaskException+  {-# MINIMAL _TaskException #-}++  _TaskNotFound :: Prism' t TaskNotFound+  _TaskNotFound = _TaskException . _TaskNotFound++  _InvalidTaskStatus :: Prism' t InvalidTaskStatus+  _InvalidTaskStatus = _TaskException . _InvalidTaskStatus++  _TaskStatusTransitionFailed :: Prism' t TaskStatusTransitionFailed+  _TaskStatusTransitionFailed = _TaskException . _TaskStatusTransitionFailed++instance AsTaskException SomeException where+  _TaskException = exception++instance AsTaskException TaskException where+  _TaskException = id++  _TaskNotFound = prism TaskNotFound $ \case+    TaskNotFound e -> Right e+    x              -> Left x++  _InvalidTaskStatus = prism InvalidTaskStatus $ \case+    InvalidTaskStatus e -> Right e+    x                   -> Left x++  _TaskStatusTransitionFailed = prism TaskStatusTransitionFailed $ \case+    TaskStatusTransitionFailed e -> Right e+    x                            -> Left x
+ src/Groot/Exception/TaskDef.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE LambdaCase #-}++module Groot.Exception.TaskDef where++import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch    hiding (Handler)+import           Data.Typeable++import           Groot.Types++data TaskDefException =+    TaskDefNotFound TaskDefNotFound+  | FailedToRegisterTaskDef FailedToRegisterTaskDef+  deriving (Eq, Show, Typeable)++instance Exception TaskDefException++data TaskDefNotFound = TaskDefNotFound' TaskDefRef+  deriving (Eq, Show, Typeable)++instance Exception TaskDefNotFound++taskDefNotFound :: TaskDefRef -> SomeException+taskDefNotFound = toException . TaskDefNotFound . TaskDefNotFound'++data FailedToRegisterTaskDef = FailedToRegisterTaskDef' TaskDefRef+  deriving (Eq, Show, Typeable)++instance Exception FailedToRegisterTaskDef++failedToRegisterTaskDef :: TaskDefRef -> SomeException+failedToRegisterTaskDef = toException . FailedToRegisterTaskDef . FailedToRegisterTaskDef'++class AsTaskDefException t where+  _TaskDefException :: Prism' t TaskDefException+  {-# MINIMAL _TaskDefException #-}++  _TaskDefNotFound :: Prism' t TaskDefNotFound+  _TaskDefNotFound = _TaskDefException . _TaskDefNotFound++  _FailedToRegisterTaskDef :: Prism' t FailedToRegisterTaskDef+  _FailedToRegisterTaskDef = _TaskDefException . _FailedToRegisterTaskDef++instance AsTaskDefException SomeException where+  _TaskDefException = exception++instance AsTaskDefException TaskDefException where+  _TaskDefException = id++  _TaskDefNotFound = prism TaskDefNotFound $ \case+    TaskDefNotFound e -> Right e+    x                 -> Left x++  _FailedToRegisterTaskDef = prism FailedToRegisterTaskDef $ \case+    FailedToRegisterTaskDef e -> Right e+    x                         -> Left x
+ src/Groot/Internal/PrettyPrint.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}++module Groot.Internal.PrettyPrint (+    -- Types+    Doc, SimpleDoc,+    -- Lines+    line, linebreak, softline, softbreak, hardline, hyphen,+    -- Custom utils+    time, defaultTime, status,+    -- Infix operators+    (<>), (<+>), (<$>), (</>), (<$$>), (<//>),+    -- Style+    black, red, green, yellow, blue, magenta, cyan, white, dullblack, dullred,+    dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite, onblack, onred,+    ongreen, onyellow, onblue, onmagenta, oncyan, onwhite, ondullblack,+    ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan,+    ondullwhite, bold, debold, underline, deunderline, plain,+    -- Layout+    defaultIndent, label, field, field', listField, listField',+    -- Modules+    module Data.Text.Prettyprint.Doc,+    module Data.Text.Prettyprint.Doc.Render.Terminal+  ) where++import           Prelude                                   hiding ((<$>))++import           Data.Monoid+import           Data.Text                                 (Text)+import           Data.Text.Prettyprint.Doc                 hiding (Doc,+                                                            hardline, line,+                                                            softline, (<+>),+                                                            (<>))+import qualified Data.Text.Prettyprint.Doc                 as New+import           Data.Text.Prettyprint.Doc.Render.Terminal hiding (bold)+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as NewT+import           Data.Time++import           Groot.Data.Text                           hiding ((<+>))++type Doc = New.Doc NewT.AnsiStyle+type SimpleDoc = New.SimpleDocStream NewT.AnsiStyle++line :: Doc+line = New.line++linebreak :: Doc+linebreak = New.flatAlt New.line mempty++softline :: Doc+softline = New.softline++softbreak :: Doc+softbreak = New.group linebreak++hardline :: Doc+hardline = New.hardline++(<+>), (<$>), (</>), (<$$>), (<//>) :: Doc -> Doc -> Doc+(<+>) = (New.<+>)+(<$>) = \x y -> x <> New.line <> y+(</>) = \x y -> x <> softline <> y+(<$$>) = \x y -> x <> linebreak <> y+(<//>) = \x y -> x <> softbreak <> y++-- Text Style++black, red, green, yellow, blue, magenta, cyan, white, dullblack, dullred,+  dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite, onblack,+  onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite, ondullblack,+  ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan,+  ondullwhite, bold, debold, underline, deunderline :: Doc -> Doc+black         = New.annotate (NewT.color       NewT.Black)+red           = New.annotate (NewT.color       NewT.Red)+green         = New.annotate (NewT.color       NewT.Green)+yellow        = New.annotate (NewT.color       NewT.Yellow)+blue          = New.annotate (NewT.color       NewT.Blue)+magenta       = New.annotate (NewT.color       NewT.Magenta)+cyan          = New.annotate (NewT.color       NewT.Cyan)+white         = New.annotate (NewT.color       NewT.White)+dullblack     = New.annotate (NewT.colorDull   NewT.Black)+dullred       = New.annotate (NewT.colorDull   NewT.Red)+dullgreen     = New.annotate (NewT.colorDull   NewT.Green)+dullyellow    = New.annotate (NewT.colorDull   NewT.Yellow)+dullblue      = New.annotate (NewT.colorDull   NewT.Blue)+dullmagenta   = New.annotate (NewT.colorDull   NewT.Magenta)+dullcyan      = New.annotate (NewT.colorDull   NewT.Cyan)+dullwhite     = New.annotate (NewT.colorDull   NewT.White)+onblack       = New.annotate (NewT.bgColor     NewT.Black)+onred         = New.annotate (NewT.bgColor     NewT.Red)+ongreen       = New.annotate (NewT.bgColor     NewT.Green)+onyellow      = New.annotate (NewT.bgColor     NewT.Yellow)+onblue        = New.annotate (NewT.bgColor     NewT.Blue)+onmagenta     = New.annotate (NewT.bgColor     NewT.Magenta)+oncyan        = New.annotate (NewT.bgColor     NewT.Cyan)+onwhite       = New.annotate (NewT.bgColor     NewT.White)+ondullblack   = New.annotate (NewT.bgColorDull NewT.Black)+ondullred     = New.annotate (NewT.bgColorDull NewT.Red)+ondullgreen   = New.annotate (NewT.bgColorDull NewT.Green)+ondullyellow  = New.annotate (NewT.bgColorDull NewT.Yellow)+ondullblue    = New.annotate (NewT.bgColorDull NewT.Blue)+ondullmagenta = New.annotate (NewT.bgColorDull NewT.Magenta)+ondullcyan    = New.annotate (NewT.bgColorDull NewT.Cyan)+ondullwhite   = New.annotate (NewT.bgColorDull NewT.White)+bold = New.annotate NewT.bold+debold = id+{-# WARNING debold "Debold does not do anything" #-}+underline = New.annotate NewT.underlined+deunderline = id+{-# WARNING deunderline "Deunderline does not do anything" #-}++hyphen :: Doc+hyphen = New.pretty ("-" :: Text)++-- Groot specific functions++defaultIndent :: Int+defaultIndent = 3++plain :: Doc -> Doc+plain = New.unAnnotate++label :: Pretty a => a -> Doc+label = dullblue . New.pretty++field :: (a -> Doc) -> Text -> a -> Doc+field f lbl x = (label . toText $ lbl) <+> (f x)++field' :: Pretty a => Text -> a -> Doc+field' = field New.pretty++listField :: (a -> Doc) -> Text -> [a] -> Maybe Doc+listField _ _   [] = Nothing+listField f lbl xs = Just $ New.vsep [+    label lbl,+    New.indent defaultIndent (New.vsep $ fmap (\x -> hyphen <+> f x) xs)+  ]++listField' :: Pretty a => Text -> [a] -> Maybe Doc+listField' = listField New.pretty++time :: FormatTime t => TimeLocale -> String -> t -> Doc+time tl fmt t = New.pretty $ formatTime tl fmt t++defaultTime :: FormatTime t => t -> Doc+defaultTime = time defaultTimeLocale "%d/%m/%Y %T"++status :: Text -> Doc+status txt@"ACTIVE"   = bold . green . New.pretty $ txt+status txt@"DRAINING" = bold . yellow . New.pretty $ txt+status txt            = bold . red . New.pretty $ txt
+ src/Groot/Manifest.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module Groot.Manifest where++import           Control.Applicative+import           Control.Exception.Lens+import           Control.Lens+import           Control.Monad.Catch       hiding (Handler)+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe+import           Data.Aeson+import           Data.Hashable             (Hashable)+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as Map+import           Data.Semigroup            ((<>))+import           Data.String+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.These+import           Data.Typeable+import           Data.Yaml                 (decodeFileEither,+                                            prettyPrintParseException)+import           GHC.Generics+import qualified Network.AWS.ECS           as ECS++import           Groot.Console+import           Groot.Data.Text++toHashMap :: (Hashable k, Eq k) => (a -> k) -> [a] -> HashMap k a+toHashMap f xs = Map.fromList $ (\x -> (f x, x)) <$> xs++data PortELBLink =+    ELBNameLink Text+  | TargetGroupLink Text+  deriving (Eq, Show)++data PortMapping = PortMapping+  { _pmContainerPort :: Int+  , _pmHostPort      :: Maybe Int+  , _pmProtocol      :: Maybe ECS.TransportProtocol+  , _pmElbLink       :: Maybe PortELBLink+  } deriving (Eq, Show, Generic)++makeLenses ''PortMapping++instance FromJSON PortMapping where+  parseJSON = withObject "port mapping" $ \o -> do+    _pmContainerPort <- o .: "container-port"+    _pmHostPort      <- o .:? "host-port"+    _pmProtocol      <- o .:? "protocol"++    -- Load balancer link+    let nameLink        = ELBNameLink     <$> (MaybeT $ o .:? "lb-name")+    let targetGroupLink = TargetGroupLink <$> (MaybeT $ o .:? "target-group")+    _pmElbLink       <- runMaybeT $ nameLink <|> targetGroupLink++    return PortMapping{..}++data Volume = Volume+  { _vName       :: Text+  , _vSourcePath :: Text+  } deriving (Eq, Show, Generic)++makeLenses ''Volume++instance FromJSON Volume where+  parseJSON = withObject "cluster volume" $ \o -> do+    _vName       <- o .: "name"+    _vSourcePath <- o .: "source-path"+    return Volume{..}++data MountPoint = MountPoint+  { _mpVolume     :: Text+  , _mpTargetPath :: Text+  , _mpReadOnly   :: Maybe Bool+  } deriving (Eq, Show, Generic)++makeLenses ''MountPoint++instance FromJSON MountPoint where+  parseJSON = withObject "container mount point" $ \o -> do+    _mpVolume     <- o .: "volume"+    _mpTargetPath <- o .: "target-path"+    _mpReadOnly   <- o .:? "read-only"+    return MountPoint{..}++type AssignedMemory = Int+type ReservedMemory = Int+type Memory         = These AssignedMemory ReservedMemory++_AssignedMemory :: Prism' Memory AssignedMemory+_AssignedMemory = prism This $ \case+  This  a   -> Right a+  These a _ -> Right a+  x         -> Left x++_ReservedMemory :: Prism' Memory ReservedMemory+_ReservedMemory = prism That $ \case+  That  r   -> Right r+  These _ r -> Right r+  x         -> Left x++data Container = Container+  { _cName         :: Text+  , _cImage        :: Text+  , _cMemory       :: Memory+  , _cCpu          :: Maybe Int+  , _cHostname     :: Maybe Text+  , _cExtraHosts   :: HashMap Text Text+  , _cPortMappings :: [PortMapping]+  , _cEnvironment  :: HashMap Text Text+  , _cLinks        :: [Text]+  , _cLabels       :: HashMap Text Text+  , _cLogConfig    :: Maybe ECS.LogConfiguration+  , _cPriviledged  :: Maybe Bool+  , _cEssential    :: Maybe Bool+  , _cWorkDir      :: Maybe Text+  , _cUser         :: Maybe Text+  , _cMountPoints  :: [MountPoint]+  , _cDnsSearch    :: [Text]+  , _cEntryPoint   :: [Text]+  , _cCommand      :: [Text]+  } deriving (Eq, Show, Generic)++makeLenses ''Container++instance FromJSON Container where+  parseJSON = withObject "container" $ \o -> do+    _cName         <- T.pack <$> o .: "name"+    _cImage        <- T.pack <$> o .: "image"++    -- Parse container memory+    let memAssign = o .:? "memory"+        memReserv = o .:? "memory-reserved"++        memChoice ((Just a), (Just r)) = pure $ These a r+        memChoice ((Just a), _)        = pure $ This a+        memChoice (_,        (Just r)) = pure $ That r+        memChoice (_,        _)        =+          fail "One or both of 'memory' or 'memory-reserved' are needed per container"++    _cMemory       <- memChoice =<< ((,) <$> memAssign <*> memReserv)++    _cCpu          <- o .:? "cpu"+    _cHostname     <- o .:? "hostname"+    _cExtraHosts   <- maybe Map.empty id <$> o .:? "extra-hosts"+    _cPortMappings <- maybe [] id <$> o .:? "port-mappings"+    _cEnvironment  <- maybe Map.empty id <$> o .:? "environment"+    _cLinks        <- maybe [] id <$> o .:? "links"+    _cLabels       <- maybe Map.empty id <$> o .:? "labels"+    _cLogConfig    <- o .:? "logging"+    _cPriviledged  <- o .:? "priviledged"+    _cEssential    <- o .:? "essential"+    _cWorkDir      <- o .:? "workdir"+    _cUser         <- o .:? "user"+    _cMountPoints  <- maybe [] id <$> o .:? "mount-points"+    _cDnsSearch    <- maybe [] id <$> o .:? "dns-search"+    _cEntryPoint   <- maybe [] id <$> o .:? "entry-point"+    _cCommand      <- maybe [] id <$> o .:? "command"+    return Container{..}++data DeploymentStrategy =+    DSBlueGreen+  | DSRolling+  | DSTearDown+  deriving (Eq, Show, Ord, Enum, Bounded, Generic)++defaultDeploymentStrategy :: DeploymentStrategy+defaultDeploymentStrategy = DSBlueGreen++instance FromJSON DeploymentStrategy where+  parseJSON = withText "deployment strategy" $ \txt ->+    case (T.toLower txt) of+      "blue-green" -> pure DSBlueGreen+      "rolling"    -> pure DSRolling+      "tear-down"  -> pure DSTearDown+      _            -> fail $ "Invalid deployment strategy: " ++ (T.unpack txt)++data DeploymentConstraint =+  InstanceAttributesConstraint (HashMap Text Text)+  deriving (Eq, Show)++instance FromJSON DeploymentConstraint where+  parseJSON = withObject "deployment constaint" $ \o -> do+    attrs <- o .: "instance-attrs"+    return $ InstanceAttributesConstraint attrs++data ServiceDeployment = ServiceDeployment+  { _sdTaskRole              :: Maybe Text+  , _sdServiceRole           :: Maybe Text+  , _sdDesiredCount          :: Int+  , _sdDeploymentStrategy    :: DeploymentStrategy+  , _sdContainers            :: [Container]+  , _sdNetworkMode           :: Maybe ECS.NetworkMode+  , _sdDeploymentConstraints :: [DeploymentConstraint]+  , _sdPlacementStrategy     :: [ECS.PlacementStrategy]+  } deriving (Eq, Show, Generic)++makeLenses ''ServiceDeployment++type NamedServiceDeployment = (Text, ServiceDeployment)++instance FromJSON ServiceDeployment where+  parseJSON = withObject "service deployment" $ \o -> do+    _sdTaskRole              <- o .:? "task-role"+    _sdServiceRole           <- o .:? "service-role"+    _sdDesiredCount          <- maybe 1 id <$> o .:? "desired-count"+    _sdDeploymentStrategy    <- maybe defaultDeploymentStrategy id <$> o .:? "deployment-strategy"+    _sdContainers            <- o .: "containers"+    _sdNetworkMode           <- o .:? "network"+    _sdDeploymentConstraints <- maybe [] id <$> o .:? "deployment-constraints"+    _sdPlacementStrategy     <- maybe [] id <$> o .:? "placement-strategy"+    return ServiceDeployment{..}++data GrootManifest = GrootManifest+  { _gmServices :: HashMap Text ServiceDeployment+  , _gmVolumes  :: HashMap Text Volume+  } deriving (Eq, Show, Generic)++makeLenses ''GrootManifest++instance FromJSON GrootManifest where+  parseJSON = withObject "manifest" $ \o -> do+    _gmServices <- maybe Map.empty id <$> o .:? "services"+    _gmVolumes  <- maybe Map.empty (toHashMap $ view vName) <$> o .:? "volumes"+    return GrootManifest{..}++-- Exceptions++data ManifestException =+  ManifestParseError ManifestParseError+  deriving (Eq, Show, Typeable)++instance Exception ManifestException++data ManifestParseError = ManifestParseError' FilePath Text+  deriving (Eq, Show, Typeable)++instance Exception ManifestParseError++manifestParseError :: FilePath -> Text -> SomeException+manifestParseError file reason =+  toException . ManifestParseError $ ManifestParseError' file reason++class AsManifestException t where+  _ManifestException :: Prism' t ManifestException+  {-# MINIMAL _ManifestException #-}++  _ManifestParseError :: Prism' t ManifestParseError+  _ManifestParseError = _ManifestException . _ManifestParseError++instance AsManifestException SomeException where+  _ManifestException = exception++instance AsManifestException ManifestException where+  _ManifestException = id++  _ManifestParseError = prism ManifestParseError $ \case+    ManifestParseError x -> Right x++-- Defaults++defaultManifestFilePath :: FilePath+defaultManifestFilePath = "./groot-manifest.yml"++-- Operations++handleManifestParseError :: MonadConsole m => ManifestParseError -> m ()+handleManifestParseError (ManifestParseError' file reason) =+  putError $ "Could not parse manifest file: " <> (styled blueStyle $ T.pack file) <> "\n"+    <> (styled yellowStyle reason)++loadManifest :: (MonadIO m, MonadConsole m, MonadThrow m) => FilePath -> m GrootManifest+loadManifest file = do+  parsed <- liftIO $ decodeFileEither file+  case parsed of+    Left err       -> throwM $ manifestParseError file (fromString $ prettyPrintParseException err)+    Right manifest -> return manifest
+ src/Groot/Types.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-|+Module      : Groot.Types+Description : Type definitions for Groot+Copyright   : A. Alonso Dominguez (c) 2017, http://github.com/alonsodomin+License     : Apache 2.0+Maintainer  : A. Alonso Dominguez <alonso.domin (λ) google>+Stability   : experimental+Portability : portable++This is a module providing global type definitions needed in Groot+-}+module Groot.Types+     ( ServiceId (..)+     , AccountId (..)+     , Arn (..)+     , arnAccountId+     , arnRegion+     , arnResourcePath+     , arnServiceId+     , viewArn+     , Ami (..)+     -- Cluster+     , ClusterName (..)+     , ClusterArnPath (..)+     , ClusterArn+     , arnClusterName+     , ClusterRef(..)+     , ClusterStatus(..)+     , ClusterFilter+     , isActiveCluster+     , isInactiveCluster+     , clusterHasNameOrArn+     -- Container Instance+     , ContainerInstanceId (..)+     , ContainerInstanceArn+     , arnContainerInstanceId+     , ContainerInstanceRef(..)+     -- EC2 Instance+     , EC2InstanceId (..)+     -- Container Service+     , ServiceName (..)+     , ContainerServiceArn+     , arnContainerServiceName+     , ContainerServiceRef(..)+     , ContainerServiceCoords(..)+     , ContainerServiceStatus(..)+     , ContainerServiceFilter+     , isActiveContainerService+     , isInactiveContainerService+     , isContainerService+     -- Task+     , TaskId (..)+     , TaskArn+     , arnTaskId+     , TaskRef(..)+     , TaskStatus(..)+     -- Task Definition+     , TaskDefRef(..)+     , TaskFamily (..)+     , TaskDefId (..)+     , tdiTaskFamily+     , tdiTaskRevision+     , nextTaskDefId+     , TaskDefArn+     , arnTaskDefId+     , arnTaskDefFamily+     , arnTaskDefRevision+     , TaskDefStatus(..)+     , TaskDefFilter(..)+     ) where++import           Control.Lens+import           Control.Monad        (join)+import           Data.Attoparsec.Text+import           Data.Data+import           Data.Monoid+import           Data.String+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Data.UUID            (UUID)+import qualified Data.UUID            as UUID+import           GHC.Generics         hiding (to)+import           Network.AWS+import qualified Network.AWS.ECS      as ECS+import           Prelude              hiding (takeWhile)++import           Groot.Data.Filter+import           Groot.Data.Text++-- | An AWS service identifier, typically used in AWS ARNs+data ServiceId =+    AutoScaling+  | ECS+  | EC2+  deriving (Eq, Show, Generic, Enum, Bounded, Data)++instance FromText ServiceId where+  parser = takeLowerText >>= \case+    "autoscaling" -> pure AutoScaling+    "ecs"         -> pure ECS+    "ec2"         -> pure EC2+    e             ->+      fromTextError $ "Failure parsing service id from " <> e++instance ToText ServiceId where+  toText AutoScaling = "autoscaling"+  toText ECS         = "ecs"+  toText EC2         = "ec2"++-- | An AWS account identifier+newtype AccountId = AccountId Text+  deriving (Eq, Show, Data, Generic)++instance IsString AccountId where+  fromString = AccountId . T.pack++instance ToText AccountId where+  toText (AccountId s) = s++-- | An AWS Resource Name (ARN for short) used to uniquely identify+-- a given resource+data Arn a = Arn+  { _arnServiceId    :: ServiceId+  , _arnRegion       :: Region+  , _arnAccountId    :: AccountId+  , _arnResourcePath :: a+  } deriving (Eq, Show, Data, Generic)++-- |Obtain the 'ServiceId' from a given 'Arn'+arnServiceId :: forall a. Getter (Arn a) ServiceId+arnServiceId = to _arnServiceId++-- |Obtain the AWS region from a given 'Arn'+arnRegion :: forall a. Getter (Arn a) Region+arnRegion = to _arnRegion++-- |Obtain the 'AccountId' from a given 'Arn'+arnAccountId :: forall a. Getter (Arn a) AccountId+arnAccountId = to _arnAccountId++-- |Obtain the resource path from a given 'Arn'+arnResourcePath :: forall a. Getter (Arn a) a+arnResourcePath = to _arnResourcePath++instance FromText a => FromText (Arn a) where+  parser = do+    "arn:aws:"+    serviceId <- subparser =<< takeTill (== ':')+    char ':'+    region    <- subparser =<< takeTill (== ':')+    char ':'+    account   <- takeWhile (/= ':')+    char ':'+    path <- parser+    return $ Arn serviceId region (AccountId account) path++instance ToText a => ToText (Arn a) where+  toText (Arn service region account path) = T.concat [+      "arn:aws:"+    , toText service+    , ":"+    , toText region+    , ":"+    , toText account+    , ":"+    , toText path+    ]++-- |Parse an ARN given a getter an a resource from where to obtain the text form+viewArn :: forall a b. FromText b => Getting (First Text) a Text -> a -> Maybe (Arn b)+viewArn l item = join $ either (\_ -> Nothing) Just <$> fromText <$> item ^? l++-- | An AWS Machine Image, used to uniquely identify a given+-- image for an specific instance+newtype Ami = Ami Text+  deriving (Eq, Show, Data, Generic)++instance FromText Ami where+  parser = do+    "ami-"+    ident <- takeText+    return $ Ami ident++instance ToText Ami where+  toText (Ami ident) = T.append "ami-" ident++-- Cluster++-- |Type describing the cluster name+newtype ClusterName = ClusterName Text+  deriving (Eq, Show, Data, Generic)++instance IsString ClusterName where+  fromString = ClusterName . T.pack++instance FromText ClusterName where+  parser = ClusterName <$> takeText++instance ToText ClusterName where+  toText (ClusterName x) = x++-- |Type describing the ARN path for ECS clusters+newtype ClusterArnPath = ClusterArnPath ClusterName+  deriving (Eq, Show, Data, Generic)++-- |Obtains the cluster name from a given Cluster ARN path+capClusterName :: Getter ClusterArnPath ClusterName+capClusterName = to (\(ClusterArnPath name) -> name)++-- |Type describing cluster ARNs+type ClusterArn = Arn ClusterArnPath++-- |Obtains the cluster name from a cluster ARN+arnClusterName :: Getter ClusterArn ClusterName+arnClusterName = arnResourcePath . capClusterName++capPreffix :: Text+capPreffix = "cluster/"++instance FromText ClusterArnPath where+  parser = do+    string capPreffix+    clusterName <- parser+    return $ ClusterArnPath clusterName++instance ToText ClusterArnPath where+  toText (ClusterArnPath clusterName) =+    T.append capPreffix $ toText clusterName++-- |Type used across the code to make references to clusters+newtype ClusterRef = ClusterRef Text+  deriving (Eq, Show, Data, Generic)++instance IsString ClusterRef where+  fromString = ClusterRef . T.pack++instance ToText ClusterRef where+  toText (ClusterRef txt) = txt++-- |Different statuses available for clusters+data ClusterStatus =+    CSActive+  | CSInactive+  deriving (Eq, Show, Ord, Read, Enum, Bounded, Data, Generic)++instance ToText ClusterStatus where+  toText CSActive   = "ACTIVE"+  toText CSInactive = "INACTIVE"++-- |Filter definition for clusters+data ClusterFilter =+    CFRef ClusterRef+  | CFStatus ClusterStatus+  deriving (Eq, Show)++-- |Cluster filter predicates based on status+isActiveCluster, isInactiveCluster :: ClusterFilter+isActiveCluster   = CFStatus CSActive+isInactiveCluster = CFStatus CSInactive++-- |Cluster filter based on name or ARN+clusterHasNameOrArn :: Text -> ClusterFilter+clusterHasNameOrArn = CFRef . ClusterRef++instance Filter ClusterFilter where+  type FilterItem ClusterFilter = ECS.Cluster++  matches (CFRef (ClusterRef txt)) cluster =+       maybe False (== txt) (cluster ^. ECS.cClusterName)+    || maybe False (== txt) (cluster ^. ECS.cClusterARN)+  matches (CFStatus CSActive) cluster =+    maybe False (== (T.pack "ACTIVE")) $ cluster ^. ECS.cStatus+  matches (CFStatus CSInactive) cluster =+    maybe False (== (T.pack "INACTIVE")) $ cluster ^. ECS.cStatus++-- Container Instance++-- |Type describing a Container Instance Identifier+newtype ContainerInstanceId = ContainerInstanceId UUID+  deriving (Eq, Show)++instance FromText ContainerInstanceId where+  parser = ContainerInstanceId <$> uuid++instance ToText ContainerInstanceId where+  toText (ContainerInstanceId s) = UUID.toText s++-- |Type describing a Container Instance ARN path+newtype ContainerInstanceArnPath = ContainerInstanceArnPath ContainerInstanceId+  deriving (Eq, Show)++-- |Obtain a Container Instance Identifier from a Container Instance ARN+ciapContainerInstanceId :: Getter ContainerInstanceArnPath ContainerInstanceId+ciapContainerInstanceId = to (\(ContainerInstanceArnPath x) -> x)++-- |Type describing a Container Instance ARN+type ContainerInstanceArn = Arn ContainerInstanceArnPath++-- |Obtain a Container Instance Identifier from a Container Instance ARN+arnContainerInstanceId :: Getter ContainerInstanceArn ContainerInstanceId+arnContainerInstanceId = arnResourcePath . ciapContainerInstanceId++ciapPreffix :: Text+ciapPreffix = "container-instance/"++instance FromText ContainerInstanceArnPath where+  parser = do+    string ciapPreffix+    instanceId <- parser+    return $ ContainerInstanceArnPath instanceId++instance ToText ContainerInstanceArnPath where+  toText (ContainerInstanceArnPath instanceId) =+    T.append ciapPreffix $ toText instanceId++-- |Type used across the code to make references to container instances+newtype ContainerInstanceRef = ContainerInstanceRef Text+  deriving (Eq, Show, Data, Read, Generic)++instance ToText ContainerInstanceRef where+  toText (ContainerInstanceRef s) = s++instance IsString ContainerInstanceRef where+  fromString = ContainerInstanceRef . T.pack++-- EC2 Instance++newtype EC2InstanceId = EC2InstanceId Text+  deriving (Eq, Show)++instance ToText EC2InstanceId where+  toText (EC2InstanceId id) = id++-- Container Service++-- |Type describing a service name+newtype ServiceName = ServiceName Text+  deriving (Eq, Show)++instance FromText ServiceName where+  parser = ServiceName <$> takeText++instance ToText ServiceName where+  toText (ServiceName s) = s++-- |Type describing a service ARN path+newtype ContainerServiceArnPath = ContainerServiceArnPath ServiceName+  deriving (Eq, Show)++-- |Obtain a service name from a service ARN path+csapContainerServiceName :: Getter ContainerServiceArnPath ServiceName+csapContainerServiceName = to (\(ContainerServiceArnPath x) -> x)++-- |Type describing a service ARN+type ContainerServiceArn = Arn ContainerServiceArnPath++-- |Obtain a service name from a service ARN+arnContainerServiceName :: Getter ContainerServiceArn ServiceName+arnContainerServiceName = arnResourcePath . csapContainerServiceName++csapPreffix :: Text+csapPreffix = "service/"++instance FromText ContainerServiceArnPath where+  parser = do+    string csapPreffix+    serviceName <- parser+    return $ ContainerServiceArnPath serviceName++instance ToText ContainerServiceArnPath where+  toText (ContainerServiceArnPath serviceName) =+    T.append csapPreffix $ toText serviceName++-- |Type used across the code to make references to services+newtype ContainerServiceRef = ContainerServiceRef Text+  deriving (Eq, Show, Generic, Data, Read)++instance IsString ContainerServiceRef where+  fromString = ContainerServiceRef . T.pack++instance ToText ContainerServiceRef where+  toText (ContainerServiceRef s) = s++-- |Service coordinates are compoound of a service reference and a cluster reference.+-- They uniquely identify a service+data ContainerServiceCoords = ContainerServiceCoords ContainerServiceRef ClusterRef+  deriving (Eq, Show, Generic, Data)++-- |Service statuses+data ContainerServiceStatus =+    CSSActive+  | CSSInactive+  deriving (Eq, Show, Ord, Enum, Bounded, Data, Generic)++-- |Service filters+data ContainerServiceFilter =+    CSFRef ContainerServiceRef+  | CSFStatus ContainerServiceStatus+  deriving (Eq, Show)++-- |Service filter predicate based on service status+isActiveContainerService, isInactiveContainerService :: ContainerServiceFilter+isActiveContainerService   = CSFStatus CSSActive+isInactiveContainerService = CSFStatus CSSInactive++-- |Service filter preficate based on service name or ARN+isContainerService :: ContainerServiceRef -> ContainerServiceFilter+isContainerService = CSFRef++instance Filter ContainerServiceFilter where+  type FilterItem ContainerServiceFilter = ECS.ContainerService++  matches (CSFStatus CSSActive) serv =+    maybe False (== (T.pack "ACTIVE")) (serv ^. ECS.csStatus)+  matches (CSFStatus CSSInactive) serv =+    maybe False (== (T.pack "INACTIVE")) (serv ^. ECS.csStatus)++  matches (CSFRef (ContainerServiceRef ref)) serv =+       maybe False (== ref) (serv ^. ECS.csServiceName)+    || maybe False (== ref) (serv ^. ECS.csServiceARN)++-- Task++-- |Type describing a task identifier+newtype TaskId = TaskId UUID+  deriving (Eq, Show)++instance FromText TaskId where+  parser = TaskId <$> uuid++instance ToText TaskId where+  toText (TaskId s) = UUID.toText s++-- |Type describing a task ARN path+newtype TaskArnPath = TaskArnPath TaskId+  deriving (Eq, Show)++-- |Obtain a task identifier from a task ARN+tapTaskId :: Getter TaskArnPath TaskId+tapTaskId = to (\(TaskArnPath x) -> x)++-- |Type describing a task ARN+type TaskArn = Arn TaskArnPath++-- |Obtain a task identifier from a task ARN+arnTaskId :: Getter TaskArn TaskId+arnTaskId = arnResourcePath . tapTaskId++tapPreffix :: Text+tapPreffix = "task/"++instance FromText TaskArnPath where+  parser = do+    string tapPreffix+    taskId <- parser+    return $ TaskArnPath taskId++instance ToText TaskArnPath where+  toText (TaskArnPath taskId) =+    T.append tapPreffix $ toText taskId++-- |Type used across the code to make references to tasks+newtype TaskRef = TaskRef Text+  deriving (Eq, Show, Generic, Data, Read)++instance IsString TaskRef where+  fromString = TaskRef . T.pack++instance ToText TaskRef where+  toText (TaskRef t) = t++-- |Task statuses+data TaskStatus =+    TSRunning+  | TSStopped+  | TSPending+  deriving (Eq, Show, Ord, Enum, Bounded, Data, Generic, Read)++-- Task Definition++-- |Type used across the code to make references to task definitions+newtype TaskDefRef = TaskDefRef Text+  deriving (Eq, Generic, Data, Show, Read)++instance IsString TaskDefRef where+  fromString = TaskDefRef . T.pack++instance ToText TaskDefRef where+  toText (TaskDefRef t) = t++-- |Type describing a task definition family+newtype TaskFamily = TaskFamily Text+  deriving (Eq, Show, Data, Generic)++instance IsString TaskFamily where+  fromString = TaskFamily . T.pack++instance FromText TaskFamily where+  parser = TaskFamily <$> takeText++instance ToText TaskFamily where+  toText (TaskFamily s) = s++-- |A Task Definition Identifier, compound of a task family and a revision number+data TaskDefId = TaskDefId+  { _tdiTaskFamily   :: TaskFamily+  , _tdiTaskRevision :: Int+  } deriving (Eq, Show, Data, Generic)++makeLenses ''TaskDefId++-- |Increments the revision number of a given task definition+nextTaskDefId :: TaskDefId -> TaskDefId+nextTaskDefId (TaskDefId family revision) = TaskDefId family (revision + 1)++instance FromText TaskDefId where+  parser = do+    family   <- subparser =<< takeTill (== ':')+    char ':'+    revision <- parser+    return $ TaskDefId family revision++instance ToText TaskDefId where+  toText (TaskDefId family revision) =+    T.concat [toText family, ":", toText revision]++-- |Type describing the task definition ARN path+newtype TaskDefArnPath = TaskDefArnPath TaskDefId+  deriving (Eq, Show, Data, Generic)++-- |Obtain a task definition identifier from a task definition ARN path+tdapTaskDefId :: Getter TaskDefArnPath TaskDefId+tdapTaskDefId = to (\(TaskDefArnPath x) -> x)++-- |Type describing a task definition ARN+type TaskDefArn = Arn TaskDefArnPath++-- |Obtain a task definition identifier from a task definition ARN+arnTaskDefId :: Getter TaskDefArn TaskDefId+arnTaskDefId = arnResourcePath . tdapTaskDefId++-- |Obtain a task definition family from a task definition ARN+arnTaskDefFamily :: Getter TaskDefArn TaskFamily+arnTaskDefFamily = arnTaskDefId . tdiTaskFamily++-- |Obtain a task definition revision number from a task definition ARN+arnTaskDefRevision :: Getter TaskDefArn Int+arnTaskDefRevision = arnTaskDefId . tdiTaskRevision++tdapPreffix :: Text+tdapPreffix = "task-definition/"++instance FromText TaskDefArnPath where+  parser = do+    string tdapPreffix+    taskDefId <- parser+    return $ TaskDefArnPath taskDefId++instance ToText TaskDefArnPath where+  toText (TaskDefArnPath taskDefId) =+    T.append tdapPreffix $ toText taskDefId++-- |Task definition statuses+data TaskDefStatus =+    TDSActive+  | TDSInactive+  deriving (Eq, Show, Ord, Enum, Bounded, Read, Generic, Data)++-- |Task definition filters+data TaskDefFilter =+    TDFFamily TaskFamily+  | TDFStatus TaskDefStatus+  deriving (Eq, Show)++instance Filter TaskDefFilter where+  type FilterItem TaskDefFilter = ECS.TaskDefinition++  matches (TDFFamily (TaskFamily family)) taskDef =+    maybe False (== family) $ taskDef ^. ECS.tdFamily+  matches (TDFStatus TDSActive) taskDef =+    maybe False (== ECS.TDSActive) $ taskDef ^. ECS.tdStatus+  matches (TDFStatus TDSInactive) taskDef =+    maybe False (== ECS.TDSInactive) $ taskDef ^. ECS.tdStatus
+ test/Spec.hs view
@@ -0,0 +1,5 @@+import           Test.Groot.Console+import           Test.Groot.Types++main :: IO ()+main = describeTypes >> describeConsole
+ test/Test/Groot/Console.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Test.Groot.Console+     ( describeConsole+     ) where++import           Control.Monad.Free+import           Control.Monad.Identity+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.Semigroup         ((<>))+import           Data.Text              (Text)+import           Test.Hspec++import           Groot.Console+import           Groot.Data.Text++data ConsoleOp a =+    PutMessage Severity Text a+  | AskUser Text (Maybe Text -> a)+  deriving Functor++type ConsoleM = Free ConsoleOp++instance {-# OVERLAPS #-} MonadConsole ConsoleM where+  putMessage sev txt = liftF (PutMessage sev (toText txt) ())+  askUser txt        = liftF (AskUser (toText txt) id)++data ConsoleEvent =+    MessagePut Severity Text+  | UserAnswered Text (Maybe Text)+  deriving (Eq, Show)++type ConsoleState = ReaderT (Maybe Text) (State [ConsoleEvent])++runConsoleM :: Maybe Text -> ConsoleM a -> (a, [ConsoleEvent])+runConsoleM input console =+  runReader (accumEvents console) input+  where accumEvents :: ConsoleM a -> Reader (Maybe Text) (a, [ConsoleEvent])+        accumEvents console =+          mapReaderT (\st -> Identity $ runState st []) (interpretConsole console)++        interpretConsole :: ConsoleM a -> ConsoleState a+        interpretConsole = foldFree $ \msg -> do+          prev <- get+          case msg of+            PutMessage severity text next -> do+              let event = MessagePut severity text+              put (event:prev)+              return next+            AskUser txt fn -> do+              answer <- ask+              let event = UserAnswered txt answer+              put (event:prev)+              return (fn answer)++eventsAfterAnswer :: Text -> ConsoleM a -> [ConsoleEvent]+eventsAfterAnswer answer console = snd $ runConsoleM (Just answer) console++events :: ConsoleM a -> [ConsoleEvent]+events console = snd $ runConsoleM Nothing console++describeConsole :: IO ()+describeConsole = hspec $ do+  describe "putXXX" $ do+    it "is equivalent to a putMessage with the severity enum" $ do+      let txt = toText ("hello" :: String)+      events (putSuccess txt) `shouldBe` [MessagePut Success txt]+      events (putInfo    txt) `shouldBe` [MessagePut Info    txt]+      events (putWarn    txt) `shouldBe` [MessagePut Warn    txt]+      events (putError   txt) `shouldBe` [MessagePut Error   txt]+      events (putDebug   txt) `shouldBe` [MessagePut Debug   txt]+  describe "askUser" $ do+    it "should yield an AskUser event" $ do+      let txt = toText ("hello" :: String)+      eventsAfterAnswer "bye" (askUser txt) `shouldBe` [UserAnswered txt (Just "bye")]+  describe "askUserYN" $ do+    it "should interpret no answer as the default" $ do+      let prompt = toText ("say something" :: String)+      let falseExpectedPrompt = prompt <> " [yN] "+      let trueExpectedPrompt = prompt <> " [Yn] "+      runConsoleM Nothing (askUserYN False prompt) `shouldBe` (False, [UserAnswered falseExpectedPrompt Nothing])+      runConsoleM Nothing (askUserYN True  prompt) `shouldBe` (True,  [UserAnswered trueExpectedPrompt  Nothing])+    it "should translate a y answer to a true" $ do+      let prompt = toText ("foo" :: String)+      let expectedPrompt = prompt <> " [yN] "+      runConsoleM (Just "Y") (askUserYN False prompt) `shouldBe` (True, [UserAnswered expectedPrompt (Just "Y")])+    it "should translate a n answer to a false" $ do+      let prompt = toText ("foo" :: String)+      let expectedPrompt = prompt <> " [Yn] "+      runConsoleM (Just "N") (askUserYN True prompt) `shouldBe` (False, [UserAnswered expectedPrompt (Just "N")])+
+ test/Test/Groot/Types.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Groot.Types+     ( describeTypes+     ) where++import           Data.Attoparsec.Text+import           Data.Either+import qualified Data.Text            as T+import           Data.Text.Arbitrary+import           Groot.Data.Text+import           Groot.Types+import           Network.AWS.Types+import           Test.Hspec+import           Test.QuickCheck++-- Arbitrary instances++instance Arbitrary ServiceId where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary AccountId where+  arbitrary = AccountId . T.pack <$> listOf1 (elements ['0'..'9'])++instance Arbitrary Region where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary a => Arbitrary (Arn a) where+  arbitrary = Arn <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++arnParsePreservation :: (FromText a, ToText a, Eq a) => Arn a -> Bool+arnParsePreservation arn = parseOnly parser (toText arn) == Right arn++-- DummyArnPath to verify basic ARN parsing++newtype DummyArnPath = DummyArnPath Text+  deriving (Eq, Show)++instance FromText DummyArnPath where+  parser = DummyArnPath <$> takeText++instance ToText DummyArnPath where+  toText (DummyArnPath path) = path++type DummyArn = Arn DummyArnPath++instance Arbitrary DummyArnPath where+  arbitrary = DummyArnPath <$> arbitrary++quickCheckDummyArn =+  quickCheck $ \x -> arnParsePreservation (x :: DummyArn)++describeARN :: IO ()+describeARN = hspec $ do+  describe "ARN" $ do+    it "parses a valid ARN" $ do+      let validArn = "arn:aws:ecs:eu-west-1:340721489904:container-instance/b7e184d6-5b5a-4fa8-8fd3-27bd2c4b0988"+      let expectedARN = Arn ECS Ireland (AccountId "340721489904") (DummyArnPath "container-instance/b7e184d6-5b5a-4fa8-8fd3-27bd2c4b0988")+      parseOnly parser validArn `shouldBe` (Right expectedARN)+    it "fails to parse non-ARNs" $ do+      let invalidArn = "this is not an ARN"+      parseOnly (parser :: Parser DummyArn) invalidArn `shouldSatisfy` isLeft+    it "renders as an URN" $ do+      let arn = Arn EC2 Oregon (AccountId "340721489904") (DummyArnPath "instance/b7e184d6-5b5a-4fa8-8fd3-27bd2c4b0988")+      let expected = "arn:aws:ec2:us-west-2:340721489904:instance/b7e184d6-5b5a-4fa8-8fd3-27bd2c4b0988"+      showText arn `shouldBe` expected++describeAmi :: IO ()+describeAmi = hspec $ do+  describe "AMI" $ do+    it "parses an AMI string" $ do+      let validAMI = "ami-78328334"+      let expectedAMI = Ami "78328334"+      parseOnly parser validAMI `shouldBe` (Right expectedAMI)+    it "fails to parse non-AMIs" $ do+      let invalidAmi = "this is not an AMI"+      parseOnly (parser :: Parser Ami) invalidAmi `shouldSatisfy` isLeft+    it "renders AMI as a string" $ do+      let ami = Ami "0dj9393rj"+      let expected = "ami-0dj9393rj"+      showText ami `shouldBe` expected++describeBaseTypes :: IO ()+describeBaseTypes = describeARN *> describeAmi *> quickCheckDummyArn++instance Arbitrary ClusterName where+  arbitrary = ClusterName <$> arbitrary++instance Arbitrary ClusterArnPath where+  arbitrary = ClusterArnPath <$> arbitrary++quickCheckClusterArn :: IO ()+quickCheckClusterArn = quickCheck $ \x -> arnParsePreservation (x :: ClusterArn)++describeClusterTypes :: IO ()+describeClusterTypes = quickCheckClusterArn++describeTypes :: IO ()+describeTypes = describeARN *> describeAmi *> quickCheckDummyArn *> describeClusterTypes