imagepaste-0.2.0.0: src/Configuration.hs

module Configuration (
  readConfigFiles,
  getEngineAuth,
  configFilePaths,
  dummyConf,
  
  Configuration(..),
  EngineAuth(..),
  HttpProxy(..),
  FileTypeMapping(..)
  
  ) where

import qualified Data.Maybe as May
import qualified Data.Map as Map
import qualified Text.JSON as J
import qualified Control.Exception as C

import System.Environment (getEnvironment)
import System.IO (withFile)
import System.IO.Error (isDoesNotExistError)
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))
import Data.List (find, intercalate)
import Data.Maybe (fromMaybe, catMaybes)

import qualified Tools
import Log (msgDebug, msgInfo)

data HttpProxy = HttpProxy {
  hpUrl      :: String,
  hpUsername :: Maybe String,
  hpPassword :: Maybe String
  } deriving (Eq, Ord, Show)

data EngineAuth = EngineAuth {
  eaEngine   :: EngineName,
  eaName     :: String,
  eaPassword :: String
  } deriving (Eq, Ord, Show)

data FileTypeMapping = FileTypeMapping {
  ftmEngine   :: EngineName,
  ftmTypes    :: [String]
  } deriving (Eq, Ord, Show)

type FileType        = String
type EngineName      = String

data Configuration = Configuration {
  cfgNetworkTimeout       :: Int,
  cfgHttpProxy            :: Maybe HttpProxy,
  cfgEngineAuths          :: [EngineAuth],
  cfgEnginePriority       :: [String],
  cfgFileTypeMapping      :: [FileTypeMapping],
  cfgTryNextEngineOnError :: Bool
  } deriving (Eq, Ord, Show)

--
-- | Returns list of config files to read
--
configFilePaths :: IO [String]
configFilePaths = do
  env <- getEnvironment
  let base = "imp.conf"
      pathPairs = [("USERPROFILE", ""),
                   ("XDG_CONFIG_HOME", ""),
                   ("HOME", ".config")]
      xdgConfigDirs = Tools.splitOn ':' $ fromMaybe "" $ lookup "XDG_CONFIG_DIRS" env
      join = intercalate "/"
      expandPair p = case lookup (fst p) env of
        Nothing -> ""
        Just x -> if null $ snd p
                  then x
                  else join [x, snd p]
      nonEmpty = filter (not . null)
      vars = nonEmpty $ map expandPair pathPairs ++ xdgConfigDirs
      varPaths = map (\x -> join [x, "imp", base]) vars
  
  return varPaths

--
-- | Helper functions
--
mLookup a as = maybe (fail $ "No such element: " ++ a) return (lookup a as)
lookRead as id = mLookup id as  >>= J.readJSON

--
-- | HttpProxy JSON reader
--
instance J.JSON HttpProxy where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f = lookRead as
        m id = maybe (J.Ok Nothing) (liftM Just . J.readJSON) (lookup id as)
    in HttpProxy <$> f "url" <*> m "username" <*> m "password"

  readJSON _ = return $ HttpProxy "<url>" Nothing Nothing

--
-- | EngineAuth JSON reader
--
instance J.JSON EngineAuth where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f = lookRead as
    in EngineAuth <$> f "engine" <*> f "username" <*> f "password"
  
  readJSON _ = return $ EngineAuth "" "" ""

--
-- | FileTypeMapping JSON reader
--
instance J.JSON FileTypeMapping where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f id = lookRead as id
    in FileTypeMapping <$> f "engine" <*> f "types"
  
  readJSON _ = return $ FileTypeMapping "" []

dummyHttpProxy = HttpProxy "<dummy url>" (Just "noname") (Just "nopass")
dummyNetworkTimeout = 10 * 10 ^ 6 -- 10s by default

--
-- | Configuration JSON reader
--
instance J.JSON Configuration where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as                  = J.fromJSObject obj
        mMaybe              = mDefFun Just Nothing
        mDef def            = mDefFun id def
        mDefFun fun def idx = maybe (J.Ok def) (liftM fun . J.readJSON) (lookup idx as)
    in Configuration
         <$> mDefFun (1000 *) dummyNetworkTimeout "network_timeout"
         <*> mMaybe         "http_proxy"
         <*> mDef    []     "engine_auth"
         <*> mDef    []     "engine_priority"
         <*> mDef    []     "file_type_mapping"
         <*> mDef    False  "try_next_engine_on_error"
    
  readJSON _ = return dummyConf

dummyConf = Configuration {
  cfgNetworkTimeout       = dummyNetworkTimeout,
  cfgHttpProxy            = Nothing,
  cfgEngineAuths          = [],
  cfgEnginePriority       = [],
  cfgFileTypeMapping      = [],
  cfgTryNextEngineOnError = True
  }

-- | Parse configuration or return dummy config if empty content is given
processConfig :: Maybe String -> Maybe Configuration
processConfig Nothing = Nothing
processConfig (Just "") = Just dummyConf
processConfig (Just contents) =
  case (J.decode contents :: J.Result Configuration) of
    J.Ok conf -> Just conf
    J.Error string -> Nothing

-- | Read given path and maybe return a string with file content
-- Empty path is a special backup case -- return empty string
readConfigFile :: FilePath -> IO (Maybe String)
readConfigFile "" = return $ Just ""
readConfigFile filename = do
  msgDebug $ "Reading config: " ++ show filename
  C.catch (liftM Just $ readFile filename) (\e -> let _ = e :: C.IOException
                                                  in return Nothing)

-- | Read files by given paths until valid config is read
-- Empty filepath will cause to return default dummy valid config
readConfigFiles :: [FilePath] -> IO Configuration
readConfigFiles xs = do
  configContents <- mapM readConfigFile xs
  return $ head $ May.mapMaybe processConfig configContents

getEngineAuth :: Configuration -> String -> Maybe EngineAuth
getEngineAuth config engineName = find (\auth -> eaEngine auth == engineName) $ cfgEngineAuths config