diff --git a/dockmaster.cabal b/dockmaster.cabal index 97c6c44..6ac5630 100644 --- a/dockmaster.cabal +++ b/dockmaster.cabal @@ -21,8 +21,11 @@ library hs-source-dirs: src exposed-modules: Dockmaster , Dockmaster.Types + , Dockmaster.Config.Types other-modules: Dockmaster.Locator , Dockmaster.Parser + , Dockmaster.Config.Parser + , Dockmaster.Utils build-depends: base >= 4.7 && < 5 , yaml , text diff --git a/src/Dockmaster/Config/Parser.hs b/src/Dockmaster/Config/Parser.hs new file mode 100644 index 0000000..a5f7229 --- /dev/null +++ b/src/Dockmaster/Config/Parser.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Dockmaster.Config.Parser + ( config + , baseConfig + ) where + +-- Local modules +import Dockmaster.Config.Types +import Dockmaster.Utils (eitherWrap, testM) + +-- External modules +import Data.Yaml +import qualified Data.ByteString as BS +import Shelly +import Prelude hiding (FilePath) +import qualified Data.Text as T +import Data.Monoid ((<>), First(..)) +import Control.Monad (liftM) +default (T.Text) + +-- | Get global dockmaster config +-- If config.yml fails to parse, returns Left error +-- If config.yml is not found, returns Right baseConfig (default configuration) +config :: Sh (Either T.Text Config) +config = do + mPath <- resolvePath + case mPath of + Nothing -> return $ Right baseConfig + (Just path) -> do + contents <- readBinary path + return $ + eitherWrap T.pack id (decodeEither contents :: Either String Config) + +-- | Resolves path to dockmaster config.yml in the following order of precedence: +-- - DOCKMASTER_CONFIG environment variable +-- - $HOME/.dockmaster/config.yml +-- - /etc/dockmaster/config.yml +resolvePath :: Sh (Maybe FilePath) +resolvePath = do + envPathT <- get_env "DOCKMASTER_CONFIG" + homePath <- testM test_e id $ "$HOME" ".dockmaster" "config.yml" + etcPath <- testM test_e id $ "/etc" "dockmaster" "config.yml" + return $ + getFirst . mconcat $ map First [envPathT >>= (return . fromText), homePath, etcPath] + +-- | Get base config options +baseConfig :: Config +baseConfig = Config { dmcPaths = [] } diff --git a/src/Dockmaster/Config/Types.hs b/src/Dockmaster/Config/Types.hs new file mode 100644 index 0000000..04a0bb4 --- /dev/null +++ b/src/Dockmaster/Config/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module Dockmaster.Config.Types where + +import Shelly +import Prelude hiding (FilePath) +import Data.Yaml +import Control.Applicative + +-- | Dockmaster configuration +data Config = Config { dmcPaths :: [FilePath] } + +-- | Custom instance to parse strings directly into FilePath +-- TODO ensure this isn't bad. FFP warned me against "orphan instances"... +instance FromJSON FilePath where + parseJSON v = fromText <$> parseJSON v + +-- | Instance to parse dockmaster configuration file +instance FromJSON Config where + parseJSON (Object v) = Config + <$> (v .:? "PATHS" .!= []) + diff --git a/src/Dockmaster/Parser.hs b/src/Dockmaster/Parser.hs index 7f749e7..0d55373 100644 --- a/src/Dockmaster/Parser.hs +++ b/src/Dockmaster/Parser.hs @@ -6,6 +6,9 @@ module Dockmaster.Parser dockmasterYml ) where +-- Local modules +import Dockmaster.Utils (eitherWrap) + -- External modules import Data.Yaml import Dockmaster.Types @@ -21,7 +24,3 @@ dockmasterYml = do contents <- readBinary "dockmaster.yml" return $ eitherWrap T.pack id (decodeEither contents :: Either String Dockmaster) - -eitherWrap :: (a -> b) -> (c -> d) -> Either a c -> Either b d -eitherWrap f _ (Left a) = Left $ f a -eitherWrap _ g (Right c) = Right $ g c diff --git a/src/Dockmaster/Utils.hs b/src/Dockmaster/Utils.hs new file mode 100644 index 0000000..e208804 --- /dev/null +++ b/src/Dockmaster/Utils.hs @@ -0,0 +1,13 @@ +module Dockmaster.Utils + ( eitherWrap + , testM + ) where + +eitherWrap :: (a -> b) -> (c -> d) -> Either a c -> Either b d +eitherWrap f _ (Left a) = Left $ f a +eitherWrap _ g (Right c) = Right $ g c + +testM :: (Monad m) => (a -> m Bool) -> (a -> b) -> a -> m (Maybe b) +testM predM f x = do + test <- predM x + return $ if test then Just (f x) else Nothing