packages feed

envstatus (empty) → 1.0.0

raw patch · 14 files changed

+595/−0 lines, 14 filesdep +ConfigFiledep +PyFdep +basesetup-changed

Dependencies added: ConfigFile, PyF, base, envstatus, mtl, parsec, process, tasty, tasty-hspec, unix

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for Envstatus++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2018 Grégory Bataille++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,46 @@+module Main where++import Control.Monad (unless)+import Data.Maybe (fromMaybe)+import System.Environment (getArgs)+import System.Exit (exitSuccess)++import EnvStatus.Config (getAppConfig, getConfigValue)+import EnvStatus.Output.Parse+import EnvStatus.Output.Render (renderTokenString)++main :: IO ()+main = do+  -- Args+  args <- getArgs+  validateArgs args+  -- Config+  cp <- getAppConfig+  let tokens = parseOutputFormat $ fromMaybe "" $ getConfigValue cp "output_template"+  -- Output result+  result <- renderTokenString cp tokens+  putStrLn result++validateArgs :: [String] -> IO ()+validateArgs args =+  unless (areArgsValid args) $ do+    printHelp+    exitSuccess++areArgsValid :: [String] -> Bool+areArgsValid args+  | null args = True+  | length args > 1 = False+  | head args == "--help" = False+  | otherwise = True++printHelp :: IO ()+printHelp = putStrLn $+  unlines [ ""+          , "envstatus [OPTIONS]"+          , ""+          , "envstatus extracts numerous information from the current execution environment and outputs it"+          , ""+          , "OPTIONS:"+          , "  --help            Displays this help"+          ]
+ envstatus.cabal view
@@ -0,0 +1,56 @@+name:                envstatus+version:             1.0.0+synopsis:            Display efficiently the state of the local environment+description:         Meant to gather in a fast manner all the information you want from your local+                     environment (like git status, python venv, terraform workspace, ...).+license:             MIT+license-file:        LICENSE+author:              Grégory Bataille+maintainer:          gregory.bataille@gmail.com+-- copyright:+category:            Development+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     EnvStatus.Config+                     , EnvStatus.Output.Parse+                     , EnvStatus.Output.Render+                     , EnvStatus.Output.Types+                     , EnvStatus.Process+  -- other-extensions:+  build-depends:       base >=4.11 && <4.12+                     , ConfigFile >= 1.1 && <1.2+                     , mtl >= 2.2 && <2.3+                     , parsec >= 3.1 && < 3.2+                     , process+                     , unix >= 2.7 && < 3+  default-language:   Haskell2010+  ghc-options:        -Wall++executable envstatus+  hs-source-dirs:     app+  main-is:            Main.hs+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind+  build-depends:      base+                    , envstatus+  default-language:   Haskell2010++test-suite envstatus-test+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Spec.hs+  build-depends:      base+                    , parsec >= 3.1 && < 3.2+                    , tasty >= 1.1 && < 1.2+                    , tasty-hspec >= 1.1 && < 1.2+                    , ConfigFile >= 1.1 && <1.2+                    , PyF >= 0.6 && <0.7+                    , envstatus+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -Wall+  default-language:   Haskell2010+  Other-modules:      Test.EnvStatus.Config+                    , Test.EnvStatus.Output.Parse+                    , Test.EnvStatus.Output.Render
+ src/EnvStatus/Config.hs view
@@ -0,0 +1,50 @@+module EnvStatus.Config where++import System.Posix.Files (fileExist)+import System.Posix.User (getRealUserID, getUserEntryForID, UserEntry(..))++import Data.ConfigFile (ConfigParser, readstring, emptyCP, get, set, merge, to_string)++readConfig :: String -> IO ConfigParser+readConfig configString =+  case parsed of+    Right configParser -> return configParser+    Left cperror -> do+      print cperror+      return emptyCP+    where+      parsed = readstring emptyCP configString++getConfigValue :: ConfigParser -> String -> Maybe String+getConfigValue cp key =+  case value of+      Right v -> Just v+      Left _error -> Nothing+      where value = get cp "DEFAULT" key++defaultConfig :: ConfigParser+defaultConfig =+  case defaultC of+      Right config -> config+      Left _error -> emptyCP+      where+        -- TODO: gbataille - change the default to something reasonable+        defaultC = do+          cp <- set emptyCP "DEFAULT" "output_template" "\nenvstatus: {{foo}}"+          set cp "DEFAULT" "foo" "date +%Y-%m-%d"++getAppConfig :: IO ConfigParser+getAppConfig = do+  userEntry <- getRealUserID >>= getUserEntryForID+  let configFilePath = homeDirectory userEntry ++ "/.envstatusrc"+  configFilePresent <- fileExist configFilePath+  if configFilePresent+    then do+      configText <- readFile configFilePath+      cp <- readConfig configText+      return $ merge defaultConfig cp+    else return defaultConfig++-- | For debug purpose+showConfig :: ConfigParser -> String+showConfig = to_string
+ src/EnvStatus/Output/Parse.hs view
@@ -0,0 +1,77 @@+module EnvStatus.Output.Parse where++import Data.Functor (($>))+import Data.List (delete)+import Text.Parsec (many, parse, try)+import Text.Parsec.Char (anyChar, char, noneOf, oneOf, string)+import Text.Parsec.Combinator (choice, eof, manyTill, notFollowedBy)+import Text.Parsec.Prim ((<|>), (<?>))+import Text.Parsec.String (Parser)++import EnvStatus.Output.Types (Token(..))++parseOutputFormat :: String -> [Token]+parseOutputFormat outputFormat =+  case parsed of+      Right matches -> matches+      Left _ -> []+      where+        parsed = parse (manyTill tokenParser eof) "" outputFormat++tokenParser :: Parser Token+tokenParser = choice [+  commandParser+  , rawParser+  ] <?> "token"++singleOpenCurly :: Parser Char+singleOpenCurly = do+  c <- char '{'+  _ <- notFollowedBy $ char '{'+  return c++rawParser :: Parser Token+rawParser = do+  parsed <- many (try singleOpenCurly <|> noneOf ['{'])+  return $ Raw parsed++commandParser :: Parser Token+commandParser = do+  _ <- char '{'+  _ <- char '{'+  parsed <- manyTill anyChar (try $ string "}}")+  return $ SubCommand parsed++outputFormatParser :: Parser [Token]+outputFormatParser =+  manyTill tokenParser eof++-- Parser of commands ~ words but keeping the quoted parts together+quotedOption :: Parser String+quotedOption = do+  _ <- char '"'+  manyTill anyChar (char '"')+++separator :: Parser Char+separator = oneOf [' ', '\t', '\n', '\r']++skipSeparator :: Parser ()+skipSeparator = separator $> ()++word :: Parser String+word = do+  _ <- many separator+  manyTill anyChar (try skipSeparator <|> eof)++commandPart :: Parser String+commandPart = try quotedOption <|> word++parseCommand :: String -> [String]+parseCommand cmd =+  case parsed of+      -- Removes the potential last match "" if the command ended with separators+      Right matches -> delete "" matches+      Left _ -> [""]+      where+        parsed = parse (manyTill commandPart eof) "" cmd
+ src/EnvStatus/Output/Render.hs view
@@ -0,0 +1,30 @@+module EnvStatus.Output.Render where++import Control.Applicative ((<$>))+import Data.ConfigFile (ConfigParser)+import Data.Maybe (fromMaybe, isJust)++import EnvStatus.Config+import EnvStatus.Output.Types+import EnvStatus.Process++strip :: String -> String+strip s = reverse $ removeSpace $ reverse $ removeSpace s+  where+    removeSpace :: String -> String+    removeSpace (' ':rest) = removeSpace rest+    removeSpace ('\n':rest) = removeSpace rest+    removeSpace noSpaces = noSpaces++renderTokenString :: ConfigParser -> [Token] -> IO String+renderTokenString cp tokens = do+  results <- sequence $ renderToken cp <$> tokens+  return $ unwords results++renderToken :: ConfigParser -> Token -> IO String+renderToken _ (Raw s) = pure s+renderToken cp (SubCommand c) = do+  let cmd = getConfigValue cp $ strip c+  if isJust cmd+    then strip <$> runCommandAsync (fromMaybe "" cmd)+    else return ("### Command not found for config key " ++ c ++ " ###")
+ src/EnvStatus/Output/Types.hs view
@@ -0,0 +1,13 @@+module EnvStatus.Output.Types where++data OutputFormat = ZSH | BASH | TMUX | NONE | Other deriving (Show)+instance Read OutputFormat where+  readsPrec _ input =+    case input of+        "zsh" -> return (ZSH, "")+        "bash" -> return (BASH, "")+        "tmux" -> return (TMUX, "")+        "none" -> return (NONE, "")+        _ -> return (Other, "")++data Token = Raw String | SubCommand String deriving (Show, Eq)
+ src/EnvStatus/Process.hs view
@@ -0,0 +1,26 @@+module EnvStatus.Process (+  readProcessWithIgnoreExitCode+  , runCommandAsync+) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import System.Process (readProcessWithExitCode)+import System.Exit (ExitCode(ExitSuccess))++import EnvStatus.Output.Parse (parseCommand)++readProcessWithIgnoreExitCode :: FilePath -> [String] -> String -> IO String+readProcessWithIgnoreExitCode command options stdin = do+  (exCode, stdout, _) <- readProcessWithExitCode command options stdin+  if exCode == ExitSuccess+    then return stdout+    else return ""++runCommandAsync :: String -> IO String+runCommandAsync cmd = do+  let components = parseCommand cmd+  mvCmd <- newEmptyMVar+  result <- readProcessWithIgnoreExitCode (head components) (tail components) ""+  _ <- forkIO $ putMVar mvCmd result+  takeMVar mvCmd
+ test/Spec.hs view
@@ -0,0 +1,18 @@+import Test.Tasty++import Control.Applicative ((<$>))+import Control.Monad (sequence)++import Test.EnvStatus.Config (configTests)+import Test.EnvStatus.Output.Parse (parseTests)+import Test.EnvStatus.Output.Render (renderTests)++main :: IO ()+main = tests >>= defaultMain++tests :: IO TestTree+tests = testGroup "Tests" <$> sequence+  [ configTests+  , parseTests+  , renderTests+  ]
+ test/Test/EnvStatus/Config.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Test.EnvStatus.Config (configTests) where++import Data.ConfigFile (emptyCP, get, to_string, ConfigParser)+import Data.Either+import Data.Maybe+import PyF++import Test.Tasty+import Test.Tasty.Hspec++import EnvStatus.Config++-- HLint config have to be put after the imports+{-# ANN module "HLint: ignore Redundant do" #-}++defaultKey = "k1"+defaultValue = "v1"+sectionName = "Section"+sectionKey = "k2"+sectionValue = "v2"++dummyConfigString = [fString|{defaultKey}: {defaultValue}\n[{sectionName}]\n{sectionKey}: {sectionValue}|]++dummyConfig :: IO ConfigParser+dummyConfig = readConfig dummyConfigString++configTests :: IO TestTree+configTests =+  testSpec "Config Tests" $ do++    describe "#readConfig" $ do+      it "returns an empty config when there is a parser error" $ do+        cp <- readConfig "[Section]text"+        to_string cp `shouldBe` to_string emptyCP++      it "returns a proper config object" $ do+        cp <- readConfig dummyConfigString+        to_string emptyCP `shouldSatisfy` (to_string cp /=)+        fromRight "" (get cp "DEFAULT" defaultKey) `shouldBe` defaultValue+        fromRight "" (get cp sectionName sectionKey) `shouldBe` sectionValue+++    describe "#getConfigValue" $ do+      before dummyConfig $ do++        it "returns Nothing if the config does not define the value" $ \cp -> do+          getConfigValue cp "some_bad_key" `shouldBe` Nothing++        it "returns the value in the default section" $ \cp -> do+          getConfigValue cp defaultKey `shouldBe` Just defaultValue++        it "returns nothing for keys inside sections" $ \cp -> do+          getConfigValue cp sectionKey `shouldBe` Nothing++    describe "#defaultConfig" $ do+      it "contains an output_template field" $ do+          getConfigValue defaultConfig "output_template" `shouldSatisfy` isJust
+ test/Test/EnvStatus/Output/Parse.hs view
@@ -0,0 +1,158 @@+module Test.EnvStatus.Output.Parse (parseTests) where++import Control.Applicative ((<*))+import Data.Either (isLeft)+import Test.Tasty+import Test.Tasty.Hspec+import Text.Parsec (parse, try)+import Text.Parsec.Char (anyChar)++import EnvStatus.Output.Parse+import EnvStatus.Output.Types++-- HLint config have to be put after the imports+{-# ANN module "HLint: ignore Redundant do" #-}++parseTests :: IO TestTree+parseTests =+  testSpec "EnvStatus.Output.Parse Tests" $ do++    describe "#rawParser" $ do+      it "parses standard string with any non-special char" $ do+        let someString = "foo bar %#!()[] nhutoe"+        parse rawParser "" someString `shouldBe` Right (Raw someString)++      it "parses string with a single open curly brace" $ do+        let someString = "foo bar %#!()[] {nhutoe"+        parse rawParser "" someString `shouldBe` Right (Raw someString)++      it "parses string with a single curly brace set" $ do+        let someString = "foo bar %#!()[] {nhutoe} dd"+        parse rawParser "" someString `shouldBe` Right (Raw someString)++      xit "parses string with a double opening curly brace with no closing" $ do+        let someString = "foo bar %#!()[] {{nhutoe dd"+        parse rawParser "" someString `shouldBe` Right (Raw someString)++    describe "#commandParser" $ do+      it "parses commands surrounded by curly braces" $ do+        let someString = "{{foo bar}}"+        parse commandParser "" someString `shouldBe` Right (SubCommand "foo bar")++      it "does not parse things with a single opening curly brace" $ do+        let someString = "{foo bar}}"+        parse commandParser "" someString `shouldSatisfy` isLeft++      it "does not parse things with a single closing curly brace" $ do+        let someString = "{{foo bar}"+        parse commandParser "" someString `shouldSatisfy` isLeft++      it "does not parse things with a no closing curly brace" $ do+        let someString = "{{foo bar"+        parse commandParser "" someString `shouldSatisfy` isLeft++    describe "#singleOpenCurly" $ do+      before (pure $ singleOpenCurly <* try anyChar) $ do++        it "parses a single opening curly brace" $ \parser -> do+          let someString = "{x"+          parse parser "" someString `shouldBe` Right '{'++        it "does not parse 2 consecutive opening curly braces" $ \parser -> do+          let someString = "{{"+          parse parser "" someString `shouldSatisfy` isLeft++    describe "#outputFormatParser" $ do+      it "parses a proper templated string" $ do+        let someString = "raw string {{foo bar}} and more"+        parse outputFormatParser "" someString `shouldBe`+          Right [Raw "raw string ", SubCommand "foo bar", Raw " and more"]++    describe "#parseOutputFormat" $ do+      it "parses a proper templated string" $ do+        let someString = "raw string {{foo bar}} and more"+        parseOutputFormat someString `shouldBe`+          [Raw "raw string ", SubCommand "foo bar", Raw " and more"]++      it "handles newline" $ do+        let someString = "raw string {{foo bar}}\n and more"+        parseOutputFormat someString `shouldBe`+          [Raw "raw string ", SubCommand "foo bar", Raw "\n and more"]++      it "handles empty strings and returns an empty Token list" $ do+        parseOutputFormat "" `shouldBe` []++    describe "#quotedOption" $ do+      it "parses a double quoted string" $ do+        let someString = "a double quoted string"+        let quotedString = "\"" ++ someString ++ "\""+        parse quotedOption "" quotedString `shouldBe` Right someString++      it "does not parse a double quoted string preceded by text" $ do+        let someString = "a double quoted string"+        let quotedString = "foo bar \"" ++ someString ++ "\""+        parse quotedOption "" quotedString `shouldSatisfy` isLeft++      it "parses a double quoted string followed by text and stops at the closing quote" $ do+        let someString = "a double quoted string"+        let quotedString = "\"" ++ someString ++ "\" foo bar"+        parse quotedOption "" quotedString `shouldBe` Right someString++      it "does not parse a non close double quote chain" $ do+        let someString = "a double quoted string"+        let quotedString = "\"" ++ someString+        parse quotedOption "" quotedString `shouldSatisfy` isLeft++    describe "#separator" $ do+      it "parses space" $ do+        let char = ' '+        parse separator "" [char] `shouldBe` Right char++      it "parses tab" $ do+        let char = '\t'+        parse separator "" [char] `shouldBe` Right char++      it "parses cr" $ do+        let char = '\n'+        parse separator "" [char] `shouldBe` Right char++      it "parses lf" $ do+        let char = '\r'+        parse separator "" [char] `shouldBe` Right char++      it "does not parse standard string" $ do+        parse separator "" "a" `shouldSatisfy` isLeft++    describe "#word" $ do+      it "parses any non-separator based string" $ do+        let someString = "foobar"+        parse word "" someString `shouldBe` Right someString++      it "parses string until first separator" $ do+        let someString = "foobar"+        parse word "" someString `shouldBe` Right someString++        parse word "" (someString ++ " toto") `shouldBe` Right someString++        parse word "" (someString ++ "\tfoobar") `shouldBe` Right someString++        parse word "" (someString ++ "\n") `shouldBe` Right someString++    describe "#commandPart" $ do+      it "parses simple strings" $ do+        let someString = "foobar"+        parse commandPart "" someString `shouldBe` Right someString++      it "parses words individually" $ do+        let someString = "foobar"+        parse commandPart "" (someString ++ " barbaz") `shouldBe` Right someString++      it "parses double quoted section as a whole" $ do+        let someString = "foobar barbaz"+        parse commandPart "" ("\"" ++ someString ++ "\" something else") `shouldBe` Right someString++    describe "#parseCommand" $ do+      it "parses blocks properly" $ do+        let someString = " echo -n \"hello world\"  \n"++        parseCommand someString `shouldBe` ["echo", "-n", "hello world"]
+ test/Test/EnvStatus/Output/Render.hs view
@@ -0,0 +1,35 @@+module Test.EnvStatus.Output.Render (renderTests) where++import Test.Tasty+import Test.Tasty.Hspec++import EnvStatus.Output.Render++-- HLint config have to be put after the imports+{-# ANN module "HLint: ignore Redundant do" #-}++renderTests :: IO TestTree+renderTests =+  testSpec "EnvStatus.Output.Render Tests" $ do++    describe "#strip" $ do+      it "returns the untouched string if no spaces" $ do+        strip "foobar" `shouldBe` "foobar"++      it "returns the string without leading spaces" $ do+        strip "  foobar" `shouldBe` "foobar"++      it "returns the string without trailing spaces" $ do+        strip "foobar  " `shouldBe` "foobar"++      it "returns the string without surrounding spaces" $ do+        strip "    foobar  " `shouldBe` "foobar"++      it "returns the string without leading newlines" $ do+        strip "\nfoobar" `shouldBe` "foobar"++      it "returns the string without trailing newlines" $ do+        strip "foobar\n\n" `shouldBe` "foobar"++      it "returns the string without surrounding newlines" $ do+        strip "\n\nfoobar\n" `shouldBe` "foobar"