{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE UndecidableInstances #-}
module Cabal.Config (
    -- * Types
    Config (..),
    Repo (..),
    RepoName,
    -- * Parsing
    readConfig,
    findConfig,
    parseConfig,
    resolveConfig,
    -- * Hackage
    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

-------------------------------------------------------------------------------
-- Read config
-------------------------------------------------------------------------------

-- | High level convenience function to find and read @~\/.cabal\/config@ file
--
-- May throw 'IOException' when file doesn't exist, and 'ParseError'
-- on parse error.
--
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)

-------------------------------------------------------------------------------
-- Find config
-------------------------------------------------------------------------------

-- | Find the @~\/.cabal\/config@ file.
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")

-- | Find the @~\/.cabal@ dir.
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

-------------------------------------------------------------------------------
-- Config
-------------------------------------------------------------------------------

-- | Very minimal representation of @~\/.cabal\/config@ file.
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)

-- | @since 0.2.1
instance NFData (f FilePath) => NFData (Config f)

-- | Repository.
--
-- missing @root-keys@, @key-threshold@ which we don't need now.
--
data Repo = Repo
    { Repo -> URI
repoURL    :: URI
    , Repo -> Bool
repoSecure :: Bool -- ^ @since 0.2
    }
  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)

-- | Repository name, bare 'String'.
type RepoName = String

-- | @since 0.2.1
instance NFData Repo

-------------------------------------------------------------------------------
-- Finding index
-------------------------------------------------------------------------------

-- | Find a @01-index.tar@ for particular repository
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

-- | The default repository of haskell packages, <https://hackage.haskell.org/>.
hackageHaskellOrg :: RepoName
hackageHaskellOrg :: FilePath
hackageHaskellOrg = FilePath
"hackage.haskell.org"

-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------

-- | Parse @~\/.cabal\/config@ file.
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

-------------------------------------------------------------------------------
-- Resolving
-------------------------------------------------------------------------------

-- | Fill the default in @~\/.cabal\/config@  file.
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)
        }

-------------------------------------------------------------------------------
-- Lenses
-------------------------------------------------------------------------------

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 }