matterhorn-90000.1.0: src/Matterhorn/Config.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.Config
( Config(..)
, PasswordSource(..)
, findConfig
, configConnectionType
)
where
import Prelude ()
import Matterhorn.Prelude
import qualified Paths_matterhorn as Paths
import Brick.Keybindings
import qualified Control.Exception as E
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class ( lift )
import Data.Char ( isDigit, isAlpha )
import Data.List ( isPrefixOf )
import Data.List.Split ( splitOn )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Graphics.Vty as Vty
import System.Directory ( makeAbsolute, getHomeDirectory )
import System.Environment ( getExecutablePath )
import System.FilePath ( (</>), takeDirectory, splitPath, joinPath )
import System.Process ( readProcess )
import Network.Mattermost.Types (ConnectionType(..))
import Network.URI ( isIPv4address, isIPv6address )
import Matterhorn.Config.Schema
import Matterhorn.FilePaths
import Matterhorn.IOUtil
import Matterhorn.Types
defaultPort :: Int
defaultPort = 443
bundledSyntaxPlaceholderName :: String
bundledSyntaxPlaceholderName = "BUNDLED_SYNTAX"
userSyntaxPlaceholderName :: String
userSyntaxPlaceholderName = "USER_SYNTAX"
defaultSkylightingPaths :: IO [FilePath]
defaultSkylightingPaths = do
xdg <- xdgSyntaxDir
dataDirs <- xdgDataDirs
adjacent <- getBundledSyntaxPath
cabalDataFiles <- Paths.getDataFileName syntaxDirName
return $ [xdg, adjacent, cabalDataFiles] <> dataDirs
getBundledSyntaxPath :: IO FilePath
getBundledSyntaxPath = do
selfPath <- getExecutablePath
let distDir = "dist-newstyle/"
pathBits = splitPath selfPath
return $ if distDir `elem` pathBits
then
-- We're in development, so use the development
-- executable path to locate the XML path in the
-- development tree.
(joinPath $ takeWhile (/= distDir) pathBits) </> syntaxDirName
else
-- In this case we assume the binary is being run from
-- a release, in which case the syntax directory is a
-- sibling of the executable path.
takeDirectory selfPath </> syntaxDirName
fromIni :: IniParser Config
fromIni = do
section "mattermost" $ do
configUser <- fieldMbOf "user" stringField
configHost <- fieldMbOf "host" hostField
configTeam <- fieldMbOf "team" stringField
configPort <- fieldDefOf "port" number (configPort defaultConfig)
configUrlPath <- fieldMbOf "urlPath" stringField
configChannelListWidth <- fieldDefOf "channelListWidth" channelListWidthField
(configChannelListWidth defaultConfig)
configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy
(configCpuUsagePolicy defaultConfig)
configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number
(configLogMaxBufferSize defaultConfig)
configTimeFormat <- fieldMbOf "timeFormat" stringField
configDateFormat <- fieldMbOf "dateFormat" stringField
configTheme <- fieldMbOf "theme" stringField
configThemeCustomizationFile <- fieldMbOf "themeCustomizationFile" stringField
configAspellDictionary <- fieldMbOf "aspellDictionary" stringField
configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField
configURLOpenCommandInteractive <- fieldFlagDef "urlOpenCommandIsInteractive" False
configSmartBacktick <- fieldFlagDef "smartbacktick"
(configSmartBacktick defaultConfig)
configSmartEditing <- fieldFlagDef "smartediting"
(configSmartEditing defaultConfig)
configShowOlderEdits <- fieldFlagDef "showOlderEdits"
(configShowOlderEdits defaultConfig)
configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField
(configShowBackground defaultConfig)
configShowMessagePreview <- fieldFlagDef "showMessagePreview"
(configShowMessagePreview defaultConfig)
configShowChannelList <- fieldFlagDef "showChannelList"
(configShowChannelList defaultConfig)
configShowExpandedChannelTopics <- fieldFlagDef "showExpandedChannelTopics"
(configShowExpandedChannelTopics defaultConfig)
configShowTypingIndicator <- fieldFlagDef "showTypingIndicator"
(configShowTypingIndicator defaultConfig)
configSendTypingNotifications <- fieldFlagDef "sendTypingNotifications"
(configSendTypingNotifications defaultConfig)
configEnableAspell <- fieldFlagDef "enableAspell"
(configEnableAspell defaultConfig)
configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField []
configActivityNotifyCommand <- fieldMb "activityNotifyCommand"
configActivityNotifyVersion <- fieldDefOf "activityNotifyVersion"
notifyVersion (configActivityNotifyVersion defaultConfig)
configShowMessageTimestamps <- fieldFlagDef "showMessageTimestamps"
(configShowMessageTimestamps defaultConfig)
configActivityBell <- fieldFlagDef "activityBell"
(configActivityBell defaultConfig)
configTruncateVerbatimBlocksInt <- fieldDefOf "truncateVerbatimBlockHeight" number
(maybe 0 id $ configTruncateVerbatimBlocks defaultConfig)
configChannelListSorting <- fieldDefOf "channelListSorting"
parseChannelListSorting (configChannelListSorting defaultConfig)
configTeamListSorting <- fieldDefOf "teamListSorting"
parseTeamListSorting (configTeamListSorting defaultConfig)
let configTruncateVerbatimBlocks = case configTruncateVerbatimBlocksInt of
i | i <= 0 -> Nothing
| otherwise -> Just i
configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs"
(configHyperlinkingMode defaultConfig)
configShowLastOpenThread <- fieldFlagDef "showLastOpenThread"
(configShowLastOpenThread defaultConfig)
configPass <- (Just . PasswordCommand <$> field "passcmd") <!>
(Just . PasswordString <$> field "pass") <!>
pure Nothing
configChannelListOrientation <- fieldDefOf "channelListOrientation"
channelListOrientationField
(configChannelListOrientation defaultConfig)
configThreadOrientation <- fieldDefOf "threadOrientation"
threadOrientationField
(configThreadOrientation defaultConfig)
configToken <- (Just . TokenCommand <$> field "tokencmd") <!>
pure Nothing
configOTPToken <- (Just . OTPTokenCommand <$> field "otptokencmd") <!>
pure Nothing
configUnsafeUseHTTP <-
fieldFlagDef "unsafeUseUnauthenticatedConnection" False
configValidateServerCertificate <-
fieldFlagDef "validateServerCertificate" True
configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number
(configDirectChannelExpirationDays defaultConfig)
configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField
configMouseMode <- fieldFlagDef "enableMouseMode"
(configMouseMode defaultConfig)
configChannelSelectCaseInsensitive <- fieldFlagDef "channelSelectCaseInsensitive"
(configChannelSelectCaseInsensitive defaultConfig)
let configAbsPath = Nothing
configUserKeys = newKeyConfig allEvents [] []
configCharacterWidths = Nothing
return Config { .. }
defaultBindings :: [(KeyEvent, [Binding])]
defaultBindings =
[ (VtyRefreshEvent , [ ctrl 'l' ])
, (ShowHelpEvent , [ fn 1 ])
, (EnterSelectModeEvent , [ ctrl 's' ])
, (ReplyRecentEvent , [ ctrl 'r' ])
, (ToggleMessagePreviewEvent , [ meta 'p' ])
, (InvokeEditorEvent , [ meta 'k' ])
, (EnterFastSelectModeEvent , [ ctrl 'g' ])
, (QuitEvent , [ ctrl 'q' ])
, (NextChannelEvent , [ ctrl 'n' ])
, (PrevChannelEvent , [ ctrl 'p' ])
, (NextChannelEventAlternate , [ bind Vty.KDown ])
, (PrevChannelEventAlternate , [ bind Vty.KUp ])
, (NextUnreadChannelEvent , [ meta 'a' ])
, (ShowAttachmentListEvent , [ ctrl 'x' ])
, (ChangeMessageEditorFocus , [ meta 'o' ])
, (NextUnreadUserOrChannelEvent , [ ])
, (LastChannelEvent , [ meta 's' ])
, (EnterOpenURLModeEvent , [ ctrl 'o' ])
, (ClearUnreadEvent , [ meta 'l' ])
, (ToggleMultiLineEvent , [ meta 'e' ])
, (EnterFlaggedPostsEvent , [ meta '8' ])
, (ToggleChannelListVisibleEvent , [ fn 2 ])
, (ToggleExpandedChannelTopicsEvent , [ fn 3 ])
, (CycleChannelListSorting , [ fn 4 ])
, (SelectNextTabEvent , [ bind '\t' ])
, (SelectPreviousTabEvent , [ bind Vty.KBackTab ])
, (SaveAttachmentEvent , [ bind 's' ])
, (LoadMoreEvent , [ ctrl 'b' ])
, (ScrollUpEvent , [ bind Vty.KUp ])
, (ScrollDownEvent , [ bind Vty.KDown ])
, (ScrollLeftEvent , [ bind Vty.KLeft ])
, (ScrollRightEvent , [ bind Vty.KRight ])
, (ChannelListScrollUpEvent , [ ctrl Vty.KUp ])
, (ChannelListScrollDownEvent , [ ctrl Vty.KDown ])
, (PageUpEvent , [ bind Vty.KPageUp ])
, (PageDownEvent , [ bind Vty.KPageDown ])
, (PageLeftEvent , [ shift Vty.KLeft ])
, (PageRightEvent , [ shift Vty.KRight ])
, (ScrollTopEvent , [ bind Vty.KHome, meta '<' ])
, (ScrollBottomEvent , [ bind Vty.KEnd, meta '>' ])
, (SelectOldestMessageEvent , [ shift Vty.KHome ])
, (SelectUpEvent , [ bind 'k', bind Vty.KUp ])
, (SelectDownEvent , [ bind 'j', bind Vty.KDown ])
, (ActivateListItemEvent , [ bind Vty.KEnter ])
, (SearchSelectUpEvent , [ ctrl 'p', bind Vty.KUp ])
, (SearchSelectDownEvent , [ ctrl 'n', bind Vty.KDown ])
, (ViewMessageEvent , [ bind 'v' ])
, (FillGapEvent , [ bind Vty.KEnter ])
, (CopyPostLinkEvent , [ bind 'l' ])
, (FlagMessageEvent , [ bind 'f' ])
, (OpenThreadEvent , [ bind 't' ])
, (PinMessageEvent , [ bind 'p' ])
, (OpenMessageInExternalEditorEvent , [ bind 'O' ])
, (YankMessageEvent , [ bind 'y' ])
, (YankWholeMessageEvent , [ bind 'Y' ])
, (DeleteMessageEvent , [ bind 'd' ])
, (EditMessageEvent , [ bind 'e' ])
, (ReplyMessageEvent , [ bind 'r' ])
, (ReactToMessageEvent , [ bind 'a' ])
, (OpenMessageURLEvent , [ bind 'o' ])
, (AttachmentListAddEvent , [ bind 'a' ])
, (AttachmentListDeleteEvent , [ bind 'd' ])
, (AttachmentOpenEvent , [ bind 'o' ])
, (CancelEvent , [ bind Vty.KEsc, ctrl 'c' ])
, (EditorBolEvent , [ ctrl 'a' ])
, (EditorEolEvent , [ ctrl 'e' ])
, (EditorTransposeCharsEvent , [ ctrl 't' ])
, (EditorDeleteCharacter , [ ctrl 'd' ])
, (EditorKillToBolEvent , [ ctrl 'u' ])
, (EditorKillToEolEvent , [ ctrl 'k' ])
, (EditorPrevCharEvent , [ ctrl 'b' ])
, (EditorNextCharEvent , [ ctrl 'f' ])
, (EditorPrevWordEvent , [ meta 'b' ])
, (EditorNextWordEvent , [ meta 'f' ])
, (EditorDeleteNextWordEvent , [ meta 'd' ])
, (EditorDeletePrevWordEvent , [ ctrl 'w', meta Vty.KBS ])
, (EditorHomeEvent , [ bind Vty.KHome ])
, (EditorEndEvent , [ bind Vty.KEnd ])
, (EditorYankEvent , [ ctrl 'y' ])
, (FileBrowserBeginSearchEvent , [ bind '/' ])
, (FileBrowserSelectEnterEvent , [ bind Vty.KEnter ])
, (FileBrowserSelectCurrentEvent , [ bind ' ' ])
, (FileBrowserListPageUpEvent , [ ctrl 'b', bind Vty.KPageUp ])
, (FileBrowserListPageDownEvent , [ ctrl 'f', bind Vty.KPageDown ])
, (FileBrowserListHalfPageUpEvent , [ ctrl 'u' ])
, (FileBrowserListHalfPageDownEvent , [ ctrl 'd' ])
, (FileBrowserListTopEvent , [ bind 'g', bind Vty.KHome, meta '<' ])
, (FileBrowserListBottomEvent , [ bind 'G', bind Vty.KEnd, meta '>' ])
, (FileBrowserListNextEvent , [ bind 'j', ctrl 'n', bind Vty.KDown ])
, (FileBrowserListPrevEvent , [ bind 'k', ctrl 'p', bind Vty.KUp ])
, (FormSubmitEvent , [ bind Vty.KEnter ])
, (NextTeamEvent , [ ctrl Vty.KRight ])
, (PrevTeamEvent , [ ctrl Vty.KLeft ])
, (MoveCurrentTeamLeftEvent , [ ])
, (MoveCurrentTeamRightEvent , [ ])
]
channelListWidthField :: Text -> Either String ChannelListWidth
channelListWidthField t =
case T.toLower t of
"auto" -> return ChannelListWidthAuto
_ -> case readMaybe (T.unpack t) of
Nothing -> Left "Invalid value for channelListWidth"
Just w -> Right $ ChannelListWidthFixed w
channelListOrientationField :: Text -> Either String ChannelListOrientation
channelListOrientationField t =
case T.toLower t of
"left" -> return ChannelListLeft
"right" -> return ChannelListRight
_ -> Left $ "Invalid value for channelListOrientation: " <> show t
threadOrientationField :: Text -> Either String ThreadOrientation
threadOrientationField t =
case T.toLower t of
"left" -> return ThreadLeft
"right" -> return ThreadRight
"above" -> return ThreadAbove
"below" -> return ThreadBelow
_ -> Left $ "Invalid value for threadOrientation: " <> show t
syntaxDirsField :: Text -> Either String [FilePath]
syntaxDirsField = listWithSeparator ":" string
validHostnameFragmentChar :: Char -> Bool
validHostnameFragmentChar c = isAlpha c || isDigit c || c == '-'
isHostnameFragment :: String -> Bool
isHostnameFragment "" = False
isHostnameFragment s = all validHostnameFragmentChar s
isHostname :: String -> Bool
isHostname "" = False
isHostname s =
let parts = splitOn "." s
h = case parts of
(p:_) -> p
[] -> error $ "BUG: isHostname: should always get at least one component: " <> show parts
in all isHostnameFragment parts && not ("-" `isPrefixOf` h)
hostField :: Text -> Either String Text
hostField t =
let s = T.unpack t
valid = or [ isIPv4address s
, isIPv6address s
, isHostname s
]
in if valid
then Right t
else Left "Invalid 'host' value, must be a hostname or IPv4/IPv6 address"
expandTilde :: FilePath -> FilePath -> FilePath
expandTilde homeDir p =
let parts = splitPath p
f part | part == "~/" = homeDir <> "/"
| otherwise = part
in joinPath $ f <$> parts
backgroundField :: Text -> Either String BackgroundInfo
backgroundField t =
case t of
"Disabled" -> Right Disabled
"Active" -> Right Active
"ActiveCount" -> Right ActiveCount
_ -> Left ("Invalid value " <> show t
<> "; must be one of: Disabled, Active, ActiveCount")
notifyVersion :: Text -> Either String NotificationVersion
notifyVersion t =
case t of
"1" -> Right NotifyV1
"2" -> Right NotifyV2
_ -> Left ("Invalid value " <> show t
<> "; must be one of NotifyV1, NotifyV2")
parseChannelListSorting :: Text -> Either String ChannelListSorting
parseChannelListSorting t =
let validValues = [ ("default", ChannelListSortDefault)
, ("unread-first", ChannelListSortUnreadFirst)
]
in case lookup (T.unpack $ T.toLower t) validValues of
Just s -> Right s
Nothing ->
Left ("Invalid value " <> show t <> "; must be one of " <> intercalate ", " (fst <$> validValues))
parseTeamListSorting :: Text -> Either String TeamListSorting
parseTeamListSorting t =
let validValues = [ ("default", TeamListSortDefault)
, ("unread-first", TeamListSortUnreadFirst)
]
in case lookup (T.unpack $ T.toLower t) validValues of
Just s -> Right s
Nothing ->
Left ("Invalid value " <> show t <> "; must be one of " <> intercalate ", " (fst <$> validValues))
cpuUsagePolicy :: Text -> Either String CPUUsagePolicy
cpuUsagePolicy t =
case T.toLower t of
"single" -> return SingleCPU
"multiple" -> return MultipleCPUs
_ -> Left $ "Invalid CPU usage policy value: " <> show t
stringField :: Text -> Either e Text
stringField t =
case isQuoted t of
True -> Right $ parseQuotedString t
False -> Right t
filePathField :: Text -> Either e FilePath
filePathField t = let path = T.unpack t in Right path
parseQuotedString :: Text -> Text
parseQuotedString t =
let body = T.drop 1 $ T.init t
unescapeQuotes s | T.null s = s
| "\\\"" `T.isPrefixOf` s = "\"" <> unescapeQuotes (T.drop 2 s)
| otherwise = (T.singleton $ T.head s) <> unescapeQuotes (T.drop 1 s)
in unescapeQuotes body
isQuoted :: Text -> Bool
isQuoted t =
let quote = "\""
in (quote `T.isPrefixOf` t) &&
(quote `T.isSuffixOf` t)
addDefaultKeys :: Config -> Config
addDefaultKeys config =
config { configUserKeys = newKeyConfig allEvents defaultBindings mempty }
defaultConfig :: Config
defaultConfig = addDefaultKeys $
Config { configAbsPath = Nothing
, configUser = Nothing
, configHost = Nothing
, configTeam = Nothing
, configPort = defaultPort
, configUrlPath = Nothing
, configPass = Nothing
, configToken = Nothing
, configOTPToken = Nothing
, configTimeFormat = Nothing
, configDateFormat = Nothing
, configTheme = Nothing
, configThemeCustomizationFile = Nothing
, configSmartBacktick = True
, configSmartEditing = True
, configURLOpenCommand = Nothing
, configURLOpenCommandInteractive = False
, configActivityNotifyCommand = Nothing
, configActivityNotifyVersion = NotifyV1
, configActivityBell = False
, configTruncateVerbatimBlocks = Nothing
, configShowMessageTimestamps = True
, configShowBackground = Disabled
, configShowMessagePreview = False
, configShowChannelList = True
, configShowExpandedChannelTopics = True
, configEnableAspell = False
, configAspellDictionary = Nothing
, configUnsafeUseHTTP = False
, configValidateServerCertificate = True
, configChannelListWidth = ChannelListWidthFixed 22
, configLogMaxBufferSize = 200
, configShowOlderEdits = True
, configUserKeys = newKeyConfig allEvents [] []
, configShowTypingIndicator = False
, configSendTypingNotifications = False
, configHyperlinkingMode = True
, configShowLastOpenThread = False
, configSyntaxDirs = []
, configDirectChannelExpirationDays = 7
, configCpuUsagePolicy = MultipleCPUs
, configDefaultAttachmentPath = Nothing
, configChannelListOrientation = ChannelListLeft
, configThreadOrientation = ThreadBelow
, configMouseMode = False
, configChannelListSorting = ChannelListSortDefault
, configTeamListSorting = TeamListSortDefault
, configChannelSelectCaseInsensitive = False
, configCharacterWidths = Nothing
}
findConfig :: Maybe FilePath -> IO (Either String ([String], Config))
findConfig mPath = runExceptT $ do
-- Load the main configuration
locatedConfig <- lift $ locateConfig configFileName
(warns, config) <- case mPath <|> locatedConfig of
Nothing -> return ([], defaultConfig)
Just path -> loadConfig path
config' <- fixupPaths config
-- If there is a char widths file, load that and add it to the
-- configuration
widthsResult <- liftIO loadCharWidths
case widthsResult of
Nothing ->
return (warns, config')
Just (Left e) ->
return (warns <> [e], config')
Just (Right widths) ->
return (warns, config' { configCharacterWidths = Just widths })
loadCharWidths :: IO (Maybe (Either String CharWidths))
loadCharWidths = do
locatedPath <- locateConfig charWidthsFileName
case locatedPath of
Nothing -> return Nothing
Just p -> Just <$> parseCharWidthsFile p
parseCharWidthsFile :: FilePath -> IO (Either String CharWidths)
parseCharWidthsFile path = runExceptT $ do
contents <- ExceptT $ (Right <$> T.readFile path) `E.catch`
(\(e::E.SomeException) -> return $ Left $ show e)
let pairs = catMaybes (parseCharWidth <$> T.lines contents)
case pairs of
[] -> throwE $ path <> ": could not read any valid character width entries"
_ -> return $ newCharWidths pairs
parseCharWidth :: T.Text -> Maybe (Char, Int)
parseCharWidth s =
case T.words s of
[ch, widthS] | T.length ch == 1 -> (T.head ch,) <$> readMaybe (T.unpack widthS)
_ -> Nothing
-- | Fix path references in the configuration:
--
-- * Rewrite the syntax directory path list with 'fixupSyntaxDirs'
-- * Expand "~" encountered in any setting that contains a path value
fixupPaths :: Config -> ExceptT String IO Config
fixupPaths initial = do
new <- fixupSyntaxDirs initial
homeDir <- liftIO getHomeDirectory
let fixP = expandTilde homeDir
fixPText = T.pack . expandTilde homeDir . T.unpack
return $ new { configThemeCustomizationFile = fixPText <$> configThemeCustomizationFile new
, configSyntaxDirs = fixP <$> configSyntaxDirs new
, configURLOpenCommand = fixPText <$> configURLOpenCommand new
, configActivityNotifyCommand = fixPText <$> configActivityNotifyCommand new
, configDefaultAttachmentPath = fixP <$> configDefaultAttachmentPath new
}
-- | If the configuration has no syntax directories specified (the
-- default if the user did not provide the setting), fill in the
-- list with the defaults. Otherwise replace any bundled directory
-- placeholders in the config's syntax path list.
fixupSyntaxDirs :: Config -> ExceptT String IO Config
fixupSyntaxDirs c =
if configSyntaxDirs c == []
then do
dirs <- liftIO defaultSkylightingPaths
return $ c { configSyntaxDirs = dirs }
else do
newDirs <- forM (configSyntaxDirs c) $ \dir ->
if | dir == bundledSyntaxPlaceholderName -> liftIO getBundledSyntaxPath
| dir == userSyntaxPlaceholderName -> liftIO xdgSyntaxDir
| otherwise -> return dir
return $ c { configSyntaxDirs = newDirs }
keybindingsSectionName :: Text
keybindingsSectionName = "keybindings"
-- | Given a file path, load a Matterhorn configuration from the
-- specified path, loading any ancillary information such as passwords
-- or tokens from external sources as specified in the configuration.
--
-- Fails with a string error message; otherwise returns a list of
-- warnings generated during the loading process as well as the loaded
-- configuration itself.
loadConfig :: FilePath -> ExceptT String IO ([String], Config)
loadConfig fp = do
absPath <- convertIOException $ makeAbsolute fp
t <- (convertIOException $ T.readFile absPath) `catchE`
(\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)
-- HACK ALERT FIXME:
--
-- The config parser library we use, config-ini (as of 0.2.4.0)
-- cannot handle configuration files without trailing newlines.
-- Since that's not a really good reason for this function to raise
-- an exception (and is fixable on the fly), we have the following
-- check. This check is admittedly not a great thing to have to do,
-- and we should definitely get rid of it when config-ini fixes this
-- issue.
let t' = if "\n" `T.isSuffixOf` t then t else t <> "\n"
case parseIniFile t' fromIni of
Left err -> do
throwE $ "Unable to parse " ++ absPath ++ ":" ++ fatalString err
Right (warns, confNoKeys) -> do
let mKeys = either (const Nothing) id $ keybindingsFromIni allEvents keybindingsSectionName t'
kc = newKeyConfig allEvents defaultBindings (fromMaybe mempty mKeys)
conf = confNoKeys { configUserKeys = kc }
actualPass <- case configPass conf of
Just (PasswordCommand cmdString) -> do
let (cmd, rest) = case T.unpack <$> T.words cmdString of
(a:as) -> (a, as)
[] -> error $ "BUG: loadConfig: got empty command string"
output <- convertIOException (readProcess cmd rest "") `catchE`
(\e -> throwE $ "Could not execute password command: " <> e)
return $ Just $ T.pack (takeWhile (/= '\n') output)
Just (PasswordString pass) -> return $ Just pass
Nothing -> return Nothing
actualToken <- case configToken conf of
Just (TokenCommand cmdString) -> do
let (cmd, rest) = case T.unpack <$> T.words cmdString of
(a:as) -> (a, as)
[] -> error $ "BUG: loadConfig: got empty command string"
output <- convertIOException (readProcess cmd rest "") `catchE`
(\e -> throwE $ "Could not execute token command: " <> e)
return $ Just $ T.pack (takeWhile (/= '\n') output)
Just (TokenString _) -> error $ "BUG: loadConfig: token in the Config was already a TokenString"
Nothing -> return Nothing
actualOTPToken <- case configOTPToken conf of
Just (OTPTokenCommand cmdString) -> do
let (cmd, rest) = case T.unpack <$> T.words cmdString of
(a:as) -> (a, as)
[] -> error $ "BUG: loadConfig: got empty command string"
output <- convertIOException (readProcess cmd rest "") `catchE`
(\e -> throwE $ "Could not execute OTP token command: " <> e)
return $ Just $ T.pack (takeWhile (/= '\n') output)
Just (OTPTokenString _) -> error $ "BUG: loadConfig: otptoken in the Config was already a OTPTokenString"
Nothing -> return Nothing
let conf' = conf
{ configPass = PasswordString <$> actualPass
, configToken = TokenString <$> actualToken
, configOTPToken = OTPTokenString <$> actualOTPToken
, configAbsPath = Just absPath
}
return (map warningString warns, conf')
configConnectionType :: Config -> ConnectionType
configConnectionType config
| configUnsafeUseHTTP config = ConnectHTTP
| otherwise = ConnectHTTPS (configValidateServerCertificate config)