From 0df1e745f6f3b481afe372a2773bf3dd9c5c0449 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Wed, 4 Jan 2017 19:43:30 -0500 Subject: [PATCH] Implement dmc "set" subcommand --- app/Dmc.hs | 122 ++++++++++++++++++++++++--------- dockmaster.cabal | 5 +- src/Dockmaster/Config/Types.hs | 5 +- src/Dockmaster/Types.hs | 11 ++- src/Options/Utils.hs | 5 +- 5 files changed, 104 insertions(+), 44 deletions(-) diff --git a/app/Dmc.hs b/app/Dmc.hs index 91f5195..d07cdc8 100644 --- a/app/Dmc.hs +++ b/app/Dmc.hs @@ -3,12 +3,16 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where -import Options.Utils (text, execParser') import Options.Applicative import Shelly hiding (command) +import Options.Utils (text, execParser') import Dockmaster ((>=)) import qualified Dockmaster as D +import qualified Data.Aeson as J +import Data.Yaml ((.=)) +import qualified Data.Yaml as Y +import qualified Data.HashMap.Lazy as HM import Data.Either.Combinators (fromLeft) import Data.Maybe (isJust) import Data.Monoid ((<>)) @@ -55,14 +59,18 @@ main = do runInit :: Sh () runInit = do mPath <- D.resolvePath - cPath <- D.getDmHomeDirectory >= "config.yml" - when (isJust mPath) $ do - let (Just p) = mPath - when (p /= cPath) $ return undefined + cPath <- configFP + -- Dont overwrite existing config file + unlessM (test_e cPath) $ + case mPath of + -- Put empty config file in dm home + Nothing -> save D.baseConfig + -- Copy default config file to dm home + Just p -> unless (p == cPath) $ cp p cPath -- | Runtime dmc execution runDmc :: Dmc -> Sh () -runDmc (Set (SetOptions n v)) = runSave n v +runDmc (Set (SetOptions n v)) = runSet n v runDmc (Get (GetOptions n)) = runGet n runDmc (Unshift (SetOptions n v)) = runUnshift n v runDmc (Shift (GetOptions n)) = runShift n @@ -70,14 +78,65 @@ runDmc (Push (SetOptions n v)) = runPush n v runDmc (Pop (GetOptions n)) = runPop n runDmc Cat = runCat -runSave = undefined -runGet = undefined +-- | Set value +runSet :: T.Text -> T.Text -> Sh () +runSet n v = do + cfgO <- configO + let newCfg = HM.fromList [(n, parse n v)] <> cfgO + case J.fromJSON (Y.Object newCfg) of + J.Error err -> do + echo_err "Could not convert to valid configuration" + D.errorExit' (T.pack err) + J.Success cfg -> do + save cfg + echo "Saved successfully" + exit 0 + +-- | Get value +runGet n = do + cfgO <- configO + undefined +-- maybe (lookup + runUnshift = undefined runShift = undefined runPush = undefined runPop = undefined runCat = undefined +-- | Save a 'Config' instance to user config file +save :: D.Config -> Sh () +save cfg = do + cPath <- configFP + writeBinary cPath $ Y.encode cfg + +-- | Get path to dockmaster home config file +configFP :: Sh FilePath +configFP = D.getDmHomeDirectory >= "config.yml" + +-- | Get config from dockmaster home +config :: Sh D.Config +config = do + contents <- configFP >>= readBinary + case Y.decodeEither contents :: Either String D.Config of + Left err -> do + echo_err $ T.unlines [decodeErrorMsg, T.pack err] + quietExit 1 + Right cfg -> return cfg + +-- | Get config as aeson object from dockmaster home +configO :: Sh Y.Object +configO = do + val <- fmap Y.toJSON config + case val of + Y.Object obj -> return obj + _ -> echo_err decodeErrorMsg >> exit 1 +-- TODO +parse :: T.Text -> T.Text -> Y.Value +parse n v + | n `elem` D.arrayFields = Y.toJSON $ filter (/= T.empty) $ T.splitOn ":" v + | otherwise = Y.toJSON v + -- | Parser for /set/ commands setOptions :: ReadM T.Text -> Parser SetOptions setOptions optType = SetOptions @@ -85,39 +144,29 @@ setOptions optType = SetOptions <*> argument text (metavar "VALUE" <> help "Value to add/set") -- | Parser for /get/ commands -getOptions :: Parser GetOptions -getOptions = GetOptions - <$> argument anyfield (metavar "NAME" <> help "Name of the setting to retrieve") +getOptions :: ReadM T.Text -> Parser GetOptions +getOptions optType = GetOptions + <$> argument optType (metavar "NAME" <> help "Name of the setting to retrieve") -- | Reader for any config fields anyfield :: ReadM T.Text -anyfield = eitherReader inConfig +anyfield = text >>= inConfig -- | Reader for array config fields arrfield :: ReadM T.Text -arrfield = eitherReader inConfigArr +arrfield = text >>= inConfig >>= inConfigArr -- | Parse argument for any value type -inConfig :: String -> Either String T.Text +inConfig :: T.Text -> ReadM T.Text inConfig field - | field `elem` validFields = Right $ T.pack field - | otherwise = Left $ field ++ " is not a valid config field." + | field `elem` D.configFields = return field + | otherwise = readerError $ (T.unpack field) ++ " is not a valid config field." -- | Parse argument for array value type -inConfigArr :: String -> Either String T.Text -inConfigArr = inConfig >=> (isArr . T.unpack) - where - isArr field - | field `elem` validArrFields = Right $ T.pack field - | otherwise = Left $ field ++ " is not an array type." - --- | Valid fields -validFields :: [String] -validFields = map T.unpack D.configFields - --- | Valid array fields -validArrFields :: [String] -validArrFields = map T.unpack D.arrayFields +inConfigArr :: T.Text -> ReadM T.Text +inConfigArr field + | field `elem` D.arrayFields = return field + | otherwise = readerError $ (T.unpack field) ++ " is not an array type." -- | Parser for 'Dmc'. parser :: Parser Dmc @@ -127,24 +176,24 @@ parser = subparser (Set <$> setOptions anyfield) "Set value") <> (command "get" $ commandInfo - (Get <$> getOptions) + (Get <$> getOptions anyfield) "Get value") <> (command "unshift" $ commandInfo (Unshift <$> setOptions arrfield) "Unshift value (for arrays)") <> (command "shift" $ commandInfo - (Shift <$> getOptions) + (Shift <$> getOptions arrfield) "Shift value (for arrays)") <> (command "push" $ commandInfo (Push <$> setOptions arrfield) "Push value (for arrays)") <> (command "pop" $ commandInfo - (Pop <$> getOptions) + (Pop <$> getOptions arrfield) "Pop value (for arrays)") <> (command "cat" $ commandInfo (pure Cat) ("Cat full configuration")) - ) + ) -- | Generate 'ParserInfo' for 'Dmc'. opts :: ParserInfo Dmc @@ -158,3 +207,8 @@ commandInfo :: Parser Dmc -> String -> ParserInfo Dmc commandInfo opts desc = info (helper <*> opts) (fullDesc <> progDesc desc) + +decodeErrorMsg :: T.Text +decodeErrorMsg = "Current configuration is invalid. Please delete the config file " + `T.append` "and try again." + diff --git a/dockmaster.cabal b/dockmaster.cabal index 3a64772..40de0fb 100644 --- a/dockmaster.cabal +++ b/dockmaster.cabal @@ -56,12 +56,15 @@ executable dmc hs-source-dirs: app main-is: Dmc.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base >= 4.7 && < 5 + build-depends: aeson + , base >= 4.7 && < 5 , dockmaster , either >= 4.4.1.1 , optparse-applicative >= 0.13.0.0 , shelly >= 1.6.8 , text + , unordered-containers >= 0.2.7 + , yaml >= 0.8 default-language: Haskell2010 test-suite dockmaster-test diff --git a/src/Dockmaster/Config/Types.hs b/src/Dockmaster/Config/Types.hs index c675699..bcfa2c7 100644 --- a/src/Dockmaster/Config/Types.hs +++ b/src/Dockmaster/Config/Types.hs @@ -18,6 +18,7 @@ import qualified Filesystem.Path.CurrentOS as FP -- | Dockmaster configuration data Config = Config { dmcPaths :: [FilePath] } + deriving (Eq,Show) pathsField :: T.Text pathsField = "PATHS" @@ -34,8 +35,8 @@ instance FromJSON FilePath where -- | Instance to parse dockmaster configuration file instance FromJSON Config where - parseJSON (Object v) = Config - <$> (v .:? pathsField.!= []) + parseJSON (Object v) = Config <$> (v .:? pathsField .!= []) + parseJSON _ = fail "Top level configuration should be a hashmap." -- | Custom instance to parse 'FilePath' directly into 'Text' instance ToJSON FilePath where diff --git a/src/Dockmaster/Types.hs b/src/Dockmaster/Types.hs index cd89297..04d5e1c 100644 --- a/src/Dockmaster/Types.hs +++ b/src/Dockmaster/Types.hs @@ -9,14 +9,13 @@ Portability : POSIX {-# LANGUAGE OverloadedStrings #-} module Dockmaster.Types where +import Data.Yaml import Dockmaster.Config.Types -import Data.Yaml -import Control.Applicative -import Data.HashMap.Lazy (HashMap, lookup, member) -import Data.Monoid -import Shelly -import Prelude hiding (lookup, FilePath) +import Data.HashMap.Lazy (HashMap, member) +import Data.Monoid ((<>)) +import Shelly (FilePath) +import Prelude hiding (FilePath) import qualified Data.Text as T -- | Dockmaster configuration (specified by dockmaster.yml) diff --git a/src/Options/Utils.hs b/src/Options/Utils.hs index 71026fa..b357049 100644 --- a/src/Options/Utils.hs +++ b/src/Options/Utils.hs @@ -30,7 +30,10 @@ textOption = fmap T.pack . strOption -- | 'Text' argument type text :: ReadM T.Text -text = str >>= return . T.pack +text = fmap T.pack str + +filepath :: ReadM FilePath +filepath = fmap fromText text -- | 'FilePath' option filePathOption :: Mod OptionFields String -> Parser FilePath