{-# 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
(Int -> GitConfig -> ShowS)
-> (GitConfig -> String)
-> ([GitConfig] -> ShowS)
-> Show GitConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitConfig -> ShowS
showsPrec :: Int -> GitConfig -> ShowS
$cshow :: GitConfig -> String
show :: GitConfig -> String
$cshowList :: [GitConfig] -> ShowS
showList :: [GitConfig] -> ShowS
Show

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

-- | Read 'GitConfig'. On error, return 'emptyGitConfg'.
readGitConfig :: IO GitConfig
readGitConfig :: IO GitConfig
readGitConfig = (IOException -> IO GitConfig) -> IO GitConfig -> IO GitConfig
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO GitConfig
fallback (IO GitConfig -> IO GitConfig) -> IO GitConfig -> IO GitConfig
forall a b. (a -> b) -> a -> b
$ do
    Either String Ini
e <- String -> IO (Either String Ini)
readIniFile String
".git/config"
    GitConfig -> IO GitConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GitConfig -> IO GitConfig) -> GitConfig -> IO GitConfig
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
_ = GitConfig -> IO GitConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GitConfig
emptyGitConfig

elaborateGitConfig :: Ini -> GitConfig
elaborateGitConfig :: Ini -> GitConfig
elaborateGitConfig Ini
ini = (Text -> [(Text, Text)] -> GitConfig -> GitConfig)
-> GitConfig -> HashMap Text [(Text, Text)] -> GitConfig
forall a b. (Text -> a -> b -> b) -> b -> HashMap Text a -> b
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 <- Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
Atto.parseOnly (Parser Text
sectionP Parser Text -> Parser Text () -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput) Text
secname
        , Just Text
url   <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"url" [(Text, Text)]
secfields
        = GitConfig
cfg
            { gitCfgRemotes = Map.insert name url (gitCfgRemotes cfg)
            }

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

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