{-# LANGUAGE OverloadedStrings #-}
module HaskellCI.GitConfig (
    GitConfig (..),
    emptyGitConfig,
    readGitConfig,
) where

import HaskellCI.Prelude

import Data.Ini

import qualified Data.Attoparsec.Text as Atto
import qualified Data.Map.Strict      as Map

newtype GitConfig = GitConfig
    { GitConfig -> Map Text Text
gitCfgRemotes :: Map.Map Text Text
    }
  deriving Int -> GitConfig -> ShowS
[GitConfig] -> ShowS
GitConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitConfig] -> ShowS
$cshowList :: [GitConfig] -> ShowS
show :: GitConfig -> String
$cshow :: GitConfig -> String
showsPrec :: Int -> GitConfig -> ShowS
$cshowsPrec :: Int -> GitConfig -> ShowS
Show

emptyGitConfig :: GitConfig
emptyGitConfig :: GitConfig
emptyGitConfig = GitConfig
    { gitCfgRemotes :: Map Text Text
gitCfgRemotes = forall a. Monoid a => a
mempty
    }

-- | Read 'GitConfig'. On error, return 'emptyGitConfg'.
readGitConfig :: IO GitConfig
readGitConfig :: IO GitConfig
readGitConfig = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO GitConfig
fallback forall a b. (a -> b) -> a -> b
$ do
    Either String Ini
e <- String -> IO (Either String Ini)
readIniFile String
".git/config"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either String Ini
e of
        Left String
_    -> GitConfig
emptyGitConfig
        Right Ini
ini -> Ini -> GitConfig
elaborateGitConfig Ini
ini
  where
    fallback :: IOException -> IO GitConfig
    fallback :: IOException -> IO GitConfig
fallback IOException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return GitConfig
emptyGitConfig

elaborateGitConfig :: Ini -> GitConfig
elaborateGitConfig :: Ini -> GitConfig
elaborateGitConfig Ini
ini = forall i (f :: * -> *) a b.
FoldableWithIndex i f =>
(i -> a -> b -> b) -> b -> f a -> b
ifoldr Text -> [(Text, Text)] -> GitConfig -> GitConfig
go GitConfig
emptyGitConfig (Ini -> HashMap Text [(Text, Text)]
iniSections Ini
ini) where
    go :: Text -> [(Text, Text)] -> GitConfig -> GitConfig
    go :: Text -> [(Text, Text)] -> GitConfig -> GitConfig
go Text
secname [(Text, Text)]
secfields GitConfig
cfg
        | Right Text
name <- forall a. Parser a -> Text -> Either String a
Atto.parseOnly (Parser Text Text
sectionP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Atto.endOfInput) Text
secname
        , Just Text
url   <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"url" [(Text, Text)]
secfields
        = GitConfig
cfg
            { gitCfgRemotes :: Map Text Text
gitCfgRemotes = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Text
url (GitConfig -> Map Text Text
gitCfgRemotes GitConfig
cfg)
            }

    go Text
_ [(Text, Text)]
_ GitConfig
cfg = GitConfig
cfg

-- We use attoparsec here, because it backtracks
sectionP :: Atto.Parser Text
sectionP :: Parser Text Text
sectionP = do
    Text
_ <- Text -> Parser Text Text
Atto.string Text
"remote"
    Parser ()
Atto.skipSpace
    Char
_ <- Char -> Parser Char
Atto.char Char
'"'
    Text
remote <- (Char -> Bool) -> Parser Text Text
Atto.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'"')
    Char
_ <- Char -> Parser Char
Atto.char Char
'"'
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
remote