{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Cabal.Config (
Config (..),
Repo (..),
RepoName,
readConfig,
findConfig,
parseConfig,
resolveConfig,
cfgRepoIndex,
hackageHaskellOrg,
) where
import Control.DeepSeq (NFData (..))
import Control.Exception (throwIO)
import Data.ByteString (ByteString)
import Data.Function ((&))
import Data.Functor.Identity (Identity (..))
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Distribution.Compat.Lens (LensLike', over)
import GHC.Generics (Generic)
import Network.URI (URI)
import System.Directory (getAppUserDataDirectory)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as M
import qualified Distribution.CabalSpecVersion as C
import qualified Distribution.FieldGrammar as C
import qualified Distribution.Fields as C
import qualified Distribution.Parsec as C
import qualified Distribution.Utils.Generic as C
import Cabal.Internal.Newtypes
import Cabal.Parse
infixl 1 <&>
(<&>) :: Functor f => f a -> (a -> b) -> f b
<&> :: forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
(<&>) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
readConfig :: IO (Config Identity)
readConfig :: IO (Config Identity)
readConfig = do
FilePath
fp <- IO FilePath
findConfig
FieldName
bs <- FilePath -> IO FieldName
BS.readFile FilePath
fp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO Config Maybe -> IO (Config Identity)
resolveConfig (FilePath
-> FieldName -> Either (ParseError NonEmpty) (Config Maybe)
parseConfig FilePath
fp FieldName
bs)
findConfig :: IO FilePath
findConfig :: IO FilePath
findConfig = do
Maybe FilePath
env <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_CONFIG"
case Maybe FilePath
env of
Just FilePath
p -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p
Maybe FilePath
Nothing -> do
FilePath
cabalDir <- IO FilePath
findCabalDir
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cabalDir FilePath -> FilePath -> FilePath
</> FilePath
"config")
findCabalDir :: IO FilePath
findCabalDir :: IO FilePath
findCabalDir = do
Maybe FilePath
cabalDirVar <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_DIR"
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"cabal") forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
cabalDirVar
data Config f = Config
{ forall (f :: * -> *). Config f -> Map FilePath Repo
cfgRepositories :: Map RepoName Repo
, forall (f :: * -> *). Config f -> f FilePath
cfgRemoteRepoCache :: f FilePath
, forall (f :: * -> *). Config f -> f FilePath
cfgInstallDir :: f FilePath
, forall (f :: * -> *). Config f -> f FilePath
cfgStoreDir :: f FilePath
}
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (Config f) x -> Config f
forall (f :: * -> *) x. Config f -> Rep (Config f) x
$cto :: forall (f :: * -> *) x. Rep (Config f) x -> Config f
$cfrom :: forall (f :: * -> *) x. Config f -> Rep (Config f) x
Generic)
deriving instance Show (f FilePath) => Show (Config f)
instance NFData (f FilePath) => NFData (Config f)
data Repo = Repo
{ Repo -> URI
repoURL :: URI
, Repo -> Bool
repoSecure :: Bool
}
deriving (Int -> Repo -> FilePath -> FilePath
[Repo] -> FilePath -> FilePath
Repo -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Repo] -> FilePath -> FilePath
$cshowList :: [Repo] -> FilePath -> FilePath
show :: Repo -> FilePath
$cshow :: Repo -> FilePath
showsPrec :: Int -> Repo -> FilePath -> FilePath
$cshowsPrec :: Int -> Repo -> FilePath -> FilePath
Show, forall x. Rep Repo x -> Repo
forall x. Repo -> Rep Repo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Repo x -> Repo
$cfrom :: forall x. Repo -> Rep Repo x
Generic)
type RepoName = String
instance NFData Repo
cfgRepoIndex
:: Config Identity
-> RepoName
-> Maybe FilePath
cfgRepoIndex :: Config Identity -> FilePath -> Maybe FilePath
cfgRepoIndex Config Identity
cfg FilePath
repo
| FilePath
repo forall k a. Ord k => k -> Map k a -> Bool
`M.member` forall (f :: * -> *). Config f -> Map FilePath Repo
cfgRepositories Config Identity
cfg =
forall a. a -> Maybe a
Just (forall a. Identity a -> a
runIdentity (forall (f :: * -> *). Config f -> f FilePath
cfgRemoteRepoCache Config Identity
cfg) FilePath -> FilePath -> FilePath
</> FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
"01-index.tar")
| Bool
otherwise = forall a. Maybe a
Nothing
hackageHaskellOrg :: RepoName
hackageHaskellOrg :: FilePath
hackageHaskellOrg = FilePath
"hackage.haskell.org"
parseConfig :: FilePath -> ByteString -> Either (ParseError NonEmpty) (Config Maybe)
parseConfig :: FilePath
-> FieldName -> Either (ParseError NonEmpty) (Config Maybe)
parseConfig = forall a.
([Field Position] -> ParseResult a)
-> FilePath -> FieldName -> Either (ParseError NonEmpty) a
parseWith forall a b. (a -> b) -> a -> b
$ \[Field Position]
fields0 -> do
let (Fields Position
fields1, [[Section Position]]
sections) = forall ann. [Field ann] -> (Fields ann, [[Section ann]])
C.partitionFields [Field Position]
fields0
let fields2 :: Fields Position
fields2 = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\FieldName
k [NamelessField Position]
_ -> FieldName
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldName]
knownFields) Fields Position
fields1
forall {t :: * -> *}.
Foldable t =>
Fields Position
-> t [Section Position] -> ParseResult (Config Maybe)
parse Fields Position
fields2 [[Section Position]]
sections
where
knownFields :: [FieldName]
knownFields = forall s a. ParsecFieldGrammar s a -> [FieldName]
C.fieldGrammarKnownFieldList ParsecFieldGrammar (Config Maybe) (Config Maybe)
grammar
parse :: Fields Position
-> t [Section Position] -> ParseResult (Config Maybe)
parse Fields Position
fields t [Section Position]
sections = do
Config Maybe
cfg <- forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
C.parseFieldGrammar CabalSpecVersion
C.cabalSpecLatest Fields Position
fields ParsecFieldGrammar (Config Maybe) (Config Maybe)
grammar
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. a -> (a -> b) -> b
(&) Config Maybe
cfg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: * -> *).
Section Position -> ParseResult (Config f -> Config f)
parseSec (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [Section Position]
sections)
parseSec :: C.Section C.Position -> C.ParseResult (Config f -> Config f)
parseSec :: forall (f :: * -> *).
Section Position -> ParseResult (Config f -> Config f)
parseSec (C.MkSection (C.Name Position
_pos FieldName
name) [C.SecArgName Position
_pos' FieldName
secName] [Field Position]
fields) | FieldName
name forall a. Eq a => a -> a -> Bool
== FieldName
"repository" = do
let repoName :: FilePath
repoName = FieldName -> FilePath
C.fromUTF8BS FieldName
secName
let fields' :: Fields Position
fields' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall ann. [Field ann] -> (Fields ann, [[Section ann]])
C.partitionFields [Field Position]
fields
Repo
repo <- forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
C.parseFieldGrammar CabalSpecVersion
C.cabalSpecLatest Fields Position
fields' ParsecFieldGrammar Repo Repo
repoGrammar
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (Map FilePath Repo)
cfgRepositoriesL forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
repoName Repo
repo
parseSec Section Position
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
grammar :: C.ParsecFieldGrammar (Config Maybe) (Config Maybe)
grammar :: ParsecFieldGrammar (Config Maybe) (Config Maybe)
grammar = forall (f :: * -> *).
Map FilePath Repo
-> f FilePath -> f FilePath -> f FilePath -> Config f
Config forall a. Monoid a => a
mempty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s (Maybe a) -> g s (Maybe a)
C.optionalFieldAla FieldName
"remote-repo-cache" FilePath -> FilePathNT
C.FilePathNT forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgRemoteRepoCacheL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s (Maybe a) -> g s (Maybe a)
C.optionalFieldAla FieldName
"installdir" FilePath -> FilePathNT
C.FilePathNT forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgInstallDirL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s (Maybe a) -> g s (Maybe a)
C.optionalFieldAla FieldName
"store-dir" FilePath -> FilePathNT
C.FilePathNT forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgStoreDirL
repoGrammar :: C.ParsecFieldGrammar Repo Repo
repoGrammar :: ParsecFieldGrammar Repo Repo
repoGrammar = URI -> Bool -> Repo
Repo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> g s a
C.uniqueFieldAla FieldName
"url" URI -> WrappedURI
WrapURI forall (f :: * -> *). Functor f => LensLike' f Repo URI
repoURLL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (c :: * -> Constraint) (g :: * -> * -> *) s.
FieldGrammar c g =>
FieldName -> ALens' s Bool -> Bool -> g s Bool
C.booleanFieldDef FieldName
"secure" forall (f :: * -> *). Functor f => LensLike' f Repo Bool
repoSecureL Bool
False
resolveConfig :: Config Maybe -> IO (Config Identity)
resolveConfig :: Config Maybe -> IO (Config Identity)
resolveConfig Config Maybe
cfg = do
FilePath
c <- IO FilePath
findCabalDir
forall (m :: * -> *) a. Monad m => a -> m a
return Config Maybe
cfg
{ cfgRemoteRepoCache :: Identity FilePath
cfgRemoteRepoCache = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (FilePath
c FilePath -> FilePath -> FilePath
</> FilePath
"packages") (forall (f :: * -> *). Config f -> f FilePath
cfgRemoteRepoCache Config Maybe
cfg)
, cfgInstallDir :: Identity FilePath
cfgInstallDir = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (FilePath
c FilePath -> FilePath -> FilePath
</> FilePath
"bin") (forall (f :: * -> *). Config f -> f FilePath
cfgInstallDir Config Maybe
cfg)
, cfgStoreDir :: Identity FilePath
cfgStoreDir = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (FilePath
c FilePath -> FilePath -> FilePath
</> FilePath
"store") (forall (f :: * -> *). Config f -> f FilePath
cfgStoreDir Config Maybe
cfg)
}
cfgRepositoriesL :: Functor f => LensLike' f (Config g) (Map String Repo)
cfgRepositoriesL :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (Map FilePath Repo)
cfgRepositoriesL Map FilePath Repo -> f (Map FilePath Repo)
f Config g
cfg = Map FilePath Repo -> f (Map FilePath Repo)
f (forall (f :: * -> *). Config f -> Map FilePath Repo
cfgRepositories Config g
cfg) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map FilePath Repo
x -> Config g
cfg { cfgRepositories :: Map FilePath Repo
cfgRepositories = Map FilePath Repo
x }
cfgRemoteRepoCacheL :: Functor f => LensLike' f (Config g) (g FilePath)
cfgRemoteRepoCacheL :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgRemoteRepoCacheL g FilePath -> f (g FilePath)
f Config g
cfg = g FilePath -> f (g FilePath)
f (forall (f :: * -> *). Config f -> f FilePath
cfgRemoteRepoCache Config g
cfg) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \g FilePath
x -> Config g
cfg { cfgRemoteRepoCache :: g FilePath
cfgRemoteRepoCache = g FilePath
x }
cfgInstallDirL :: Functor f => LensLike' f (Config g) (g FilePath)
cfgInstallDirL :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgInstallDirL g FilePath -> f (g FilePath)
f Config g
cfg = g FilePath -> f (g FilePath)
f (forall (f :: * -> *). Config f -> f FilePath
cfgInstallDir Config g
cfg) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \g FilePath
x -> Config g
cfg { cfgInstallDir :: g FilePath
cfgInstallDir = g FilePath
x }
cfgStoreDirL :: Functor f => LensLike' f (Config g) (g FilePath)
cfgStoreDirL :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
LensLike' f (Config g) (g FilePath)
cfgStoreDirL g FilePath -> f (g FilePath)
f Config g
cfg = g FilePath -> f (g FilePath)
f (forall (f :: * -> *). Config f -> f FilePath
cfgStoreDir Config g
cfg) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \g FilePath
x -> Config g
cfg { cfgStoreDir :: g FilePath
cfgStoreDir = g FilePath
x }
repoURLL :: Functor f => LensLike' f Repo URI
repoURLL :: forall (f :: * -> *). Functor f => LensLike' f Repo URI
repoURLL URI -> f URI
f Repo
s = URI -> f URI
f (Repo -> URI
repoURL Repo
s) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \URI
x -> Repo
s { repoURL :: URI
repoURL = URI
x }
repoSecureL :: Functor f => LensLike' f Repo Bool
repoSecureL :: forall (f :: * -> *). Functor f => LensLike' f Repo Bool
repoSecureL Bool -> f Bool
f Repo
s = Bool -> f Bool
f (Repo -> Bool
repoSecure Repo
s) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
x -> Repo
s { repoSecure :: Bool
repoSecure = Bool
x }