diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Groot.CLI + +main :: IO () +main = grootCli diff --git a/groot.cabal b/groot.cabal new file mode 100644 --- /dev/null +++ b/groot.cabal @@ -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 diff --git a/src/Groot/AWS.hs b/src/Groot/AWS.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS.hs @@ -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) diff --git a/src/Groot/AWS/Cluster.hs b/src/Groot/AWS/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS/Cluster.hs @@ -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 diff --git a/src/Groot/AWS/Instance.hs b/src/Groot/AWS/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS/Instance.hs @@ -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) diff --git a/src/Groot/AWS/Service.hs b/src/Groot/AWS/Service.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS/Service.hs @@ -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 diff --git a/src/Groot/AWS/Task.hs b/src/Groot/AWS/Task.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS/Task.hs @@ -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)) diff --git a/src/Groot/AWS/TaskDef.hs b/src/Groot/AWS/TaskDef.hs new file mode 100644 --- /dev/null +++ b/src/Groot/AWS/TaskDef.hs @@ -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)) diff --git a/src/Groot/CLI.hs b/src/Groot/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI.hs @@ -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 +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) diff --git a/src/Groot/CLI/Cluster.hs b/src/Groot/CLI/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Cluster.hs @@ -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 diff --git a/src/Groot/CLI/Cluster/Events.hs b/src/Groot/CLI/Cluster/Events.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Cluster/Events.hs @@ -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 diff --git a/src/Groot/CLI/Cluster/Inspect.hs b/src/Groot/CLI/Cluster/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Cluster/Inspect.hs @@ -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 diff --git a/src/Groot/CLI/Common.hs b/src/Groot/CLI/Common.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Common.hs @@ -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 ++ ")" )) diff --git a/src/Groot/CLI/List.hs b/src/Groot/CLI/List.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List.hs @@ -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 diff --git a/src/Groot/CLI/List/Cluster.hs b/src/Groot/CLI/List/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/Cluster.hs @@ -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 diff --git a/src/Groot/CLI/List/Common.hs b/src/Groot/CLI/List/Common.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/Common.hs @@ -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 diff --git a/src/Groot/CLI/List/ContainerInstance.hs b/src/Groot/CLI/List/ContainerInstance.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/ContainerInstance.hs @@ -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 diff --git a/src/Groot/CLI/List/ContainerService.hs b/src/Groot/CLI/List/ContainerService.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/ContainerService.hs @@ -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 diff --git a/src/Groot/CLI/List/Task.hs b/src/Groot/CLI/List/Task.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/Task.hs @@ -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 diff --git a/src/Groot/CLI/List/TaskDef.hs b/src/Groot/CLI/List/TaskDef.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/List/TaskDef.hs @@ -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 diff --git a/src/Groot/CLI/Service.hs b/src/Groot/CLI/Service.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Service.hs @@ -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 diff --git a/src/Groot/CLI/Service/Compose.hs b/src/Groot/CLI/Service/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Service/Compose.hs @@ -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 diff --git a/src/Groot/CLI/Service/Events.hs b/src/Groot/CLI/Service/Events.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Service/Events.hs @@ -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 diff --git a/src/Groot/CLI/Service/Inspect.hs b/src/Groot/CLI/Service/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/Groot/CLI/Service/Inspect.hs @@ -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 diff --git a/src/Groot/Compose.hs b/src/Groot/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Compose.hs @@ -0,0 +1,5 @@ +module Groot.Compose + ( module Groot.Compose.Service + ) where + +import Groot.Compose.Service diff --git a/src/Groot/Compose/Service.hs b/src/Groot/Compose/Service.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Compose/Service.hs @@ -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) diff --git a/src/Groot/Compose/Service/AWS.hs b/src/Groot/Compose/Service/AWS.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Compose/Service/AWS.hs @@ -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 diff --git a/src/Groot/Compose/Service/DryRun.hs b/src/Groot/Compose/Service/DryRun.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Compose/Service/DryRun.hs @@ -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 diff --git a/src/Groot/Compose/Service/Free.hs b/src/Groot/Compose/Service/Free.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Compose/Service/Free.hs @@ -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 #-} diff --git a/src/Groot/Config.hs b/src/Groot/Config.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Config.hs @@ -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 diff --git a/src/Groot/Console.hs b/src/Groot/Console.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Console.hs @@ -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 +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 diff --git a/src/Groot/Core.hs b/src/Groot/Core.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Core.hs @@ -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 diff --git a/src/Groot/Core/Common.hs b/src/Groot/Core/Common.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Core/Common.hs @@ -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 diff --git a/src/Groot/Core/Events.hs b/src/Groot/Core/Events.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Core/Events.hs @@ -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 () diff --git a/src/Groot/Data/Conduit/STM.hs b/src/Groot/Data/Conduit/STM.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Data/Conduit/STM.hs @@ -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 diff --git a/src/Groot/Data/Filter.hs b/src/Groot/Data/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Data/Filter.hs @@ -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) diff --git a/src/Groot/Data/Text.hs b/src/Groot/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Data/Text.hs @@ -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 +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 diff --git a/src/Groot/Data/Text/Display.hs b/src/Groot/Data/Text/Display.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Data/Text/Display.hs @@ -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 #-} diff --git a/src/Groot/Data/Text/Styled.hs b/src/Groot/Data/Text/Styled.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Data/Text/Styled.hs @@ -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 diff --git a/src/Groot/Exception.hs b/src/Groot/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception.hs @@ -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 diff --git a/src/Groot/Exception/Cluster.hs b/src/Groot/Exception/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception/Cluster.hs @@ -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 diff --git a/src/Groot/Exception/Instance.hs b/src/Groot/Exception/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception/Instance.hs @@ -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 diff --git a/src/Groot/Exception/Service.hs b/src/Groot/Exception/Service.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception/Service.hs @@ -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 diff --git a/src/Groot/Exception/Task.hs b/src/Groot/Exception/Task.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception/Task.hs @@ -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 diff --git a/src/Groot/Exception/TaskDef.hs b/src/Groot/Exception/TaskDef.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Exception/TaskDef.hs @@ -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 diff --git a/src/Groot/Internal/PrettyPrint.hs b/src/Groot/Internal/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Internal/PrettyPrint.hs @@ -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 diff --git a/src/Groot/Manifest.hs b/src/Groot/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Manifest.hs @@ -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 diff --git a/src/Groot/Types.hs b/src/Groot/Types.hs new file mode 100644 --- /dev/null +++ b/src/Groot/Types.hs @@ -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 +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,5 @@ +import Test.Groot.Console +import Test.Groot.Types + +main :: IO () +main = describeTypes >> describeConsole diff --git a/test/Test/Groot/Console.hs b/test/Test/Groot/Console.hs new file mode 100644 --- /dev/null +++ b/test/Test/Groot/Console.hs @@ -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")]) + diff --git a/test/Test/Groot/Types.hs b/test/Test/Groot/Types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Groot/Types.hs @@ -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