module Distribution.Nixpkgs.Haskell.PackageSourceSpec
  ( HpackUse(..), Package(..), getPackage, getPackage', loadHackageDB, sourceFromHackage
  ) where

import qualified Control.Exception as Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.Bifunctor
import qualified Data.ByteString.Char8 as BS
import Data.Foldable ( toList )
import Data.List ( isSuffixOf, isPrefixOf )
import qualified Data.Map as DB
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import Distribution.Nixpkgs.Fetch
import Distribution.Nixpkgs.Hashes
import qualified Distribution.Nixpkgs.Haskell.Hackage as DB
import Distribution.Nixpkgs.Haskell.OrphanInstances ( )
import qualified Distribution.Package as Cabal
import Distribution.PackageDescription
import qualified Distribution.PackageDescription as Cabal
import Distribution.PackageDescription.Parsec as Cabal
import Distribution.Parsec
import Distribution.Version
import qualified Hpack.Config as Hpack
import qualified Hpack.Render as Hpack
import OpenSSL.Digest ( digest, digestByName )
import System.Directory ( doesDirectoryExist, doesFileExist, createDirectoryIfMissing, getHomeDirectory, getDirectoryContents )
import System.Exit ( exitFailure )
import System.FilePath ( (</>), (<.>) )
import System.IO
import Text.PrettyPrint.HughesPJClass hiding ( first )

data HpackUse
  = ForceHpack
  | PackageYamlHpack
  | NoHpack

data Package = Package
  { Package -> DerivationSource
pkgSource   :: DerivationSource
  , Package -> Bool
pkgRanHpack :: Bool -- ^ If hpack generated a new cabal file
  , Package -> GenericPackageDescription
pkgCabal    :: Cabal.GenericPackageDescription
  }
  deriving (Int -> Package -> ShowS
[Package] -> ShowS
Package -> String
(Int -> Package -> ShowS)
-> (Package -> String) -> ([Package] -> ShowS) -> Show Package
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Package] -> ShowS
$cshowList :: [Package] -> ShowS
show :: Package -> String
$cshow :: Package -> String
showsPrec :: Int -> Package -> ShowS
$cshowsPrec :: Int -> Package -> ShowS
Show)

getPackage :: HpackUse
           -- ^ the way hpack should be used.
           -> Bool
           -- ^ Whether to fetch submodules if fetching from git
           -> Maybe FilePath
           -- ^ The path to the Hackage database.
           -> Maybe UTCTime
           -- ^ If we have hackage-snapshot time.
           -> Source
           -> IO Package
getPackage :: HpackUse
-> Bool -> Maybe String -> Maybe UTCTime -> Source -> IO Package
getPackage HpackUse
optHpack Bool
optSubmodules Maybe String
optHackageDB Maybe UTCTime
optHackageSnapshot =
  HpackUse -> Bool -> IO HackageDB -> Source -> IO Package
getPackage' HpackUse
optHpack Bool
optSubmodules (Maybe String -> Maybe UTCTime -> IO HackageDB
loadHackageDB Maybe String
optHackageDB Maybe UTCTime
optHackageSnapshot)

getPackage' :: HpackUse
            -- ^ the way hpack should be used.
            -> Bool
            -- ^ Whether to fetch submodules if fetching from git
            -> IO DB.HackageDB
            -> Source
            -> IO Package
getPackage' :: HpackUse -> Bool -> IO HackageDB -> Source -> IO Package
getPackage' HpackUse
optHpack Bool
optSubmodules IO HackageDB
hackageDB Source
source = do
  (Maybe DerivationSource
derivSource, Bool
ranHpack, GenericPackageDescription
pkgDesc) <- HpackUse
-> Bool
-> IO HackageDB
-> Source
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
fetchOrFromDB HpackUse
optHpack Bool
optSubmodules IO HackageDB
hackageDB Source
source
  (\DerivationSource
s -> DerivationSource -> Bool -> GenericPackageDescription -> Package
Package DerivationSource
s Bool
ranHpack GenericPackageDescription
pkgDesc) (DerivationSource -> Package) -> IO DerivationSource -> IO Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO DerivationSource
-> (DerivationSource -> IO DerivationSource)
-> Maybe DerivationSource
-> IO DerivationSource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Hash -> String -> String -> IO DerivationSource
sourceFromHackage (Source -> Hash
sourceHash Source
source) (GenericPackageDescription -> String
showPackageIdentifier GenericPackageDescription
pkgDesc) (String -> IO DerivationSource) -> String -> IO DerivationSource
forall a b. (a -> b) -> a -> b
$ Source -> String
sourceCabalDir Source
source) DerivationSource -> IO DerivationSource
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DerivationSource
derivSource

fetchOrFromDB :: HpackUse
              -- ^ the way hpack should be used
              -> Bool
              -- ^ Whether to fetch submodules if fetching from git
              -> IO DB.HackageDB
              -> Source
              -> IO (Maybe DerivationSource, Bool, Cabal.GenericPackageDescription)
fetchOrFromDB :: HpackUse
-> Bool
-> IO HackageDB
-> Source
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
fetchOrFromDB HpackUse
optHpack Bool
optSubmodules IO HackageDB
hackageDB Source
src
  | String
"cabal://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Source -> String
sourceUrl Source
src = do
      (Maybe DerivationSource
msrc, GenericPackageDescription
pkgDesc) <- IO HackageDB
-> String -> IO (Maybe DerivationSource, GenericPackageDescription)
fromDB IO HackageDB
hackageDB (String -> IO (Maybe DerivationSource, GenericPackageDescription))
-> ShowS
-> String
-> IO (Maybe DerivationSource, GenericPackageDescription)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"cabal://") (String -> IO (Maybe DerivationSource, GenericPackageDescription))
-> String -> IO (Maybe DerivationSource, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ Source -> String
sourceUrl Source
src
      (Maybe DerivationSource, Bool, GenericPackageDescription)
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivationSource
msrc, Bool
False, GenericPackageDescription
pkgDesc)
  | Bool
otherwise                             = do
    Maybe (DerivationSource, (Bool, Bool, GenericPackageDescription))
r <- Bool
-> (String -> MaybeT IO (Bool, Bool, GenericPackageDescription))
-> Source
-> IO
     (Maybe (DerivationSource, (Bool, Bool, GenericPackageDescription)))
forall a.
Bool
-> (String -> MaybeT IO a)
-> Source
-> IO (Maybe (DerivationSource, a))
fetch Bool
optSubmodules (\String
dir -> HpackUse
-> String -> MaybeT IO (Bool, Bool, GenericPackageDescription)
cabalFromPath HpackUse
optHpack (String
dir String -> ShowS
</> Source -> String
sourceCabalDir Source
src)) Source
src
    case Maybe (DerivationSource, (Bool, Bool, GenericPackageDescription))
r of
      Maybe (DerivationSource, (Bool, Bool, GenericPackageDescription))
Nothing -> String
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> IO (Maybe DerivationSource, Bool, GenericPackageDescription))
-> String
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ String
"Failed to fetch source. Does this source exist? " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Source -> String
forall a. Show a => a -> String
show Source
src
      Just (DerivationSource
derivSource, (Bool
externalSource, Bool
ranHpack, GenericPackageDescription
pkgDesc)) ->
        (Maybe DerivationSource, Bool, GenericPackageDescription)
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivationSource
derivSource DerivationSource -> Maybe () -> Maybe DerivationSource
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
externalSource, Bool
ranHpack, GenericPackageDescription
pkgDesc)

loadHackageDB :: Maybe FilePath
              -- ^ The path to the Hackage database.
              -> Maybe UTCTime
              -- ^ If we have hackage-snapshot time.
              -> IO DB.HackageDB
loadHackageDB :: Maybe String -> Maybe UTCTime -> IO HackageDB
loadHackageDB Maybe String
optHackageDB Maybe UTCTime
optHackageSnapshot = do
  String
dbPath <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
DB.hackageTarball String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
optHackageDB
  Maybe UTCTime -> String -> IO HackageDB
DB.readTarball Maybe UTCTime
optHackageSnapshot String
dbPath

fromDB :: IO DB.HackageDB
       -> String
       -> IO (Maybe DerivationSource, Cabal.GenericPackageDescription)
fromDB :: IO HackageDB
-> String -> IO (Maybe DerivationSource, GenericPackageDescription)
fromDB IO HackageDB
hackageDBIO String
pkg = do
  HackageDB
hackageDB <- IO HackageDB
hackageDBIO
  VersionData
vd <- IO VersionData
-> (VersionData -> IO VersionData)
-> Maybe VersionData
-> IO VersionData
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO VersionData
forall a. IO a
unknownPackageError VersionData -> IO VersionData
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> HackageDB -> Maybe PackageData
forall k a. Ord k => k -> Map k a -> Maybe a
DB.lookup PackageName
name HackageDB
hackageDB Maybe PackageData
-> (PackageData -> Maybe VersionData) -> Maybe VersionData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageData -> Maybe VersionData
lookupVersion)
  let ds :: Maybe DerivationSource
ds = case VersionData -> Maybe String
DB.tarballSha256 VersionData
vd of
             Maybe String
Nothing -> Maybe DerivationSource
forall a. Maybe a
Nothing
             Just String
hash -> DerivationSource -> Maybe DerivationSource
forall a. a -> Maybe a
Just (String -> String -> DerivationSource
urlDerivationSource String
url String
hash)
  (Maybe DerivationSource, GenericPackageDescription)
-> IO (Maybe DerivationSource, GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivationSource
ds, String -> GenericPackageDescription -> GenericPackageDescription
setCabalFileHash (VersionData -> String
DB.cabalFileSha256 VersionData
vd) (VersionData -> GenericPackageDescription
DB.cabalFile VersionData
vd))
 where
  pkgId :: Cabal.PackageIdentifier
  pkgId :: PackageIdentifier
pkgId = PackageIdentifier -> Maybe PackageIdentifier -> PackageIdentifier
forall a. a -> Maybe a -> a
fromMaybe (String -> PackageIdentifier
forall a. HasCallStack => String -> a
error (String
"invalid Haskell package id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
pkg)) (String -> Maybe PackageIdentifier
forall a. Parsec a => String -> Maybe a
simpleParsec String
pkg)
  name :: PackageName
name = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName PackageIdentifier
pkgId

  unknownPackageError :: IO a
unknownPackageError = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"No such package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in the cabal database. Did you run cabal update?"

  url :: String
url = String
"mirror://hackage/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tar.gz"

  version :: Version
  version :: Version
version = PackageIdentifier -> Version
forall pkg. Package pkg => pkg -> Version
Cabal.packageVersion PackageIdentifier
pkgId

  lookupVersion :: DB.Map Version DB.VersionData -> Maybe DB.VersionData
  -- No version is specified, pick latest one
  lookupVersion :: PackageData -> Maybe VersionData
lookupVersion PackageData
m | Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
nullVersion  = ((Version, VersionData) -> VersionData)
-> Maybe (Version, VersionData) -> Maybe VersionData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version, VersionData) -> VersionData
forall a b. (a, b) -> b
snd ([(Version, VersionData)] -> Maybe (Version, VersionData)
forall a. [a] -> Maybe a
listToMaybe (PackageData -> [(Version, VersionData)]
forall k a. Map k a -> [(k, a)]
DB.toDescList PackageData
m))
  lookupVersion PackageData
m                           = Version -> PackageData -> Maybe VersionData
forall k a. Ord k => k -> Map k a -> Maybe a
DB.lookup Version
version PackageData
m

readFileMay :: FilePath -> IO (Maybe String)
readFileMay :: String -> IO (Maybe String)
readFileMay String
file = do
  Bool
e <- String -> IO Bool
doesFileExist String
file
  if Bool
e
    then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
file
    else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

hashCachePath :: String -> IO String
hashCachePath :: String -> IO String
hashCachePath String
pid = do
  String
home <- IO String
getHomeDirectory
  let cacheDir :: String
cacheDir = String
home String -> ShowS
</> String
".cache/cabal2nix"
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
cacheDir String -> ShowS
</> String
pid String -> ShowS
<.> String
"sha256"

sourceFromHackage :: Hash -> String -> FilePath -> IO DerivationSource
sourceFromHackage :: Hash -> String -> String -> IO DerivationSource
sourceFromHackage Hash
optHash String
pkgId String
cabalDir = do
  String
cacheFile <- String -> IO String
hashCachePath String
pkgId
  Hash
cachedHash <-
    case Hash
optHash of
      Certain String
h -> Hash -> IO Hash
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash -> IO Hash) -> (String -> Hash) -> String -> IO Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hash
Certain (String -> IO Hash) -> String -> IO Hash
forall a b. (a -> b) -> a -> b
$ String
h
      Guess   String
h -> Hash -> IO Hash
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash -> IO Hash) -> (String -> Hash) -> String -> IO Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hash
Guess (String -> IO Hash) -> String -> IO Hash
forall a b. (a -> b) -> a -> b
$ String
h
      Hash
_         -> (Maybe String -> Hash) -> IO (Maybe String) -> IO Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Hash -> (String -> Hash) -> Maybe String -> Hash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hash
UnknownHash String -> Hash
Certain) (IO (Maybe String) -> IO Hash)
-> (String -> IO (Maybe String)) -> String -> IO Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
readFileMay (String -> IO Hash) -> String -> IO Hash
forall a b. (a -> b) -> a -> b
$ String
cacheFile
  let url :: String
url = String
"mirror://hackage/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tar.gz"

  -- Use the cached hash (either from cache file or given on cmdline via sha256 opt)
  -- if available, otherwise download from hackage to compute hash.
  case Hash
cachedHash of
    Guess String
hash -> DerivationSource -> IO DerivationSource
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivationSource -> IO DerivationSource)
-> DerivationSource -> IO DerivationSource
forall a b. (a -> b) -> a -> b
$ String -> String -> DerivationSource
urlDerivationSource String
url String
hash
    Certain String
hash ->
      -- We need to force the hash here. If we didn't do this, then when reading the
      -- hash from the cache file, the cache file will still be open for reading
      -- (because lazy io) when writeFile opens the file again for writing. By forcing
      -- the hash here, we ensure that the file is closed before opening it again.
      Int -> IO DerivationSource -> IO DerivationSource
seq (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hash) (IO DerivationSource -> IO DerivationSource)
-> IO DerivationSource -> IO DerivationSource
forall a b. (a -> b) -> a -> b
$
      String -> String -> DerivationSource
urlDerivationSource String
url String
hash DerivationSource -> IO () -> IO DerivationSource
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> String -> IO ()
writeFile String
cacheFile String
hash
    Hash
UnknownHash -> do
      Maybe String
maybeHash <- MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (DerivationSource -> String
derivHash (DerivationSource -> String)
-> ((DerivationSource, String) -> DerivationSource)
-> (DerivationSource, String)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DerivationSource, String) -> DerivationSource
forall a b. (a, b) -> a
fst ((DerivationSource, String) -> String)
-> MaybeT IO (DerivationSource, String) -> MaybeT IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool, String, [String])
-> Source -> MaybeT IO (DerivationSource, String)
fetchWith (Bool
False, String
"url", []) (String -> String -> Hash -> String -> Source
Source String
url String
"" Hash
UnknownHash String
cabalDir))
      case Maybe String
maybeHash of
        Just String
hash ->
          Int -> IO DerivationSource -> IO DerivationSource
seq (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hash) (IO DerivationSource -> IO DerivationSource)
-> IO DerivationSource -> IO DerivationSource
forall a b. (a -> b) -> a -> b
$
          String -> String -> DerivationSource
urlDerivationSource String
url String
hash DerivationSource -> IO () -> IO DerivationSource
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> String -> IO ()
writeFile String
cacheFile String
hash
        Maybe String
Nothing -> do
          Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"*** cannot compute hash. (Not a hackage project?)"
            , String
" If your project is not on hackage, please supply the path to the root directory of"
            , String
" the project, not to the cabal file."
            , String
""
            , String
" If your project is on hackage but you still want to specify the hash manually, you"
            , String
" can use the --sha256 option."
            ]
          IO DerivationSource
forall a. IO a
exitFailure

showPackageIdentifier :: Cabal.GenericPackageDescription -> String
showPackageIdentifier :: GenericPackageDescription -> String
showPackageIdentifier GenericPackageDescription
pkgDesc = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
version where
  pkgId :: PackageIdentifier
pkgId = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
Cabal.packageDescription (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
pkgDesc
  name :: String
name = PackageName -> String
Cabal.unPackageName (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName PackageIdentifier
pkgId)
  version :: Version
version = PackageIdentifier -> Version
forall pkg. Package pkg => pkg -> Version
Cabal.packageVersion PackageIdentifier
pkgId

cabalFromPath :: HpackUse -- ^ the way hpack should be used
              -> FilePath -> MaybeT IO (Bool, Bool, Cabal.GenericPackageDescription)
cabalFromPath :: HpackUse
-> String -> MaybeT IO (Bool, Bool, GenericPackageDescription)
cabalFromPath HpackUse
optHpack String
path = do
  Bool
d <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
path
  if Bool
d
  then do
    (Bool
ranHpack, GenericPackageDescription
pkg) <- HpackUse -> String -> MaybeT IO (Bool, GenericPackageDescription)
cabalFromDirectory HpackUse
optHpack String
path
    (Bool, Bool, GenericPackageDescription)
-> MaybeT IO (Bool, Bool, GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
d, Bool
ranHpack, GenericPackageDescription
pkg)
  else (,,) Bool
d Bool
False (GenericPackageDescription
 -> (Bool, Bool, GenericPackageDescription))
-> MaybeT IO GenericPackageDescription
-> MaybeT IO (Bool, Bool, GenericPackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> MaybeT IO GenericPackageDescription
cabalFromFile Bool
False String
path

cabalFromDirectory :: HpackUse -- ^ the way hpack should be used
                   -> FilePath -> MaybeT IO (Bool, Cabal.GenericPackageDescription)
cabalFromDirectory :: HpackUse -> String -> MaybeT IO (Bool, GenericPackageDescription)
cabalFromDirectory HpackUse
ForceHpack String
dir = String -> MaybeT IO (Bool, GenericPackageDescription)
hpackDirectory String
dir
cabalFromDirectory HpackUse
NoHpack String
dir = String -> String -> MaybeT IO (Bool, GenericPackageDescription)
onlyCabalFromDirectory String
dir String
"*** No .cabal file was found. Exiting."
cabalFromDirectory HpackUse
PackageYamlHpack String
dir = do
  Bool
useHpack <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
"package.yaml")
  if Bool
useHpack
    then do
      IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"*** found package.yaml. Using hpack..."
      String -> MaybeT IO (Bool, GenericPackageDescription)
hpackDirectory String
dir
    else String -> String -> MaybeT IO (Bool, GenericPackageDescription)
onlyCabalFromDirectory String
dir String
"*** Found neither a .cabal file nor package.yaml. Exiting."

onlyCabalFromDirectory :: FilePath -> String -> MaybeT IO (Bool, Cabal.GenericPackageDescription)
onlyCabalFromDirectory :: String -> String -> MaybeT IO (Bool, GenericPackageDescription)
onlyCabalFromDirectory String
dir String
errMsg = do
  [String]
cabals <- IO [String] -> MaybeT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> MaybeT IO [String])
-> IO [String] -> MaybeT IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
dir IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String])
-> ([String] -> [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> ShowS
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
".cabal" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`)
  case [String]
cabals of
    [] -> String -> MaybeT IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errMsg
    [String
cabalFile] -> (,) Bool
False (GenericPackageDescription -> (Bool, GenericPackageDescription))
-> MaybeT IO GenericPackageDescription
-> MaybeT IO (Bool, GenericPackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> MaybeT IO GenericPackageDescription
cabalFromFile Bool
True String
cabalFile
    [String]
_ -> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, GenericPackageDescription)
 -> MaybeT IO (Bool, GenericPackageDescription))
-> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ String -> IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"*** found more than one cabal file (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
cabals String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"). Exiting.")

handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a
handleIO :: (IOException -> IO a) -> IO a -> IO a
handleIO = (IOException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle

encodeUtf8 :: String -> BS.ByteString
encodeUtf8 :: String -> ByteString
encodeUtf8 = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

hpackDirectory :: FilePath -> MaybeT IO (Bool, Cabal.GenericPackageDescription)
hpackDirectory :: String -> MaybeT IO (Bool, GenericPackageDescription)
hpackDirectory String
dir = do
  Either String DecodeResult
mPackage <- IO (Either String DecodeResult)
-> MaybeT IO (Either String DecodeResult)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String DecodeResult)
 -> MaybeT IO (Either String DecodeResult))
-> IO (Either String DecodeResult)
-> MaybeT IO (Either String DecodeResult)
forall a b. (a -> b) -> a -> b
$ DecodeOptions -> IO (Either String DecodeResult)
Hpack.readPackageConfig DecodeOptions
Hpack.defaultDecodeOptions {
      decodeOptionsProgramName :: ProgramName
Hpack.decodeOptionsProgramName = String -> ProgramName
Hpack.ProgramName String
"cabal2nix"
    , decodeOptionsTarget :: String
Hpack.decodeOptionsTarget = String
dir String -> ShowS
</> String
Hpack.packageConfig
    }
  case Either String DecodeResult
mPackage of
    Left String
err -> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, GenericPackageDescription)
 -> MaybeT IO (Bool, GenericPackageDescription))
-> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"*** hpack error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Exiting.") IO ()
-> IO (Bool, GenericPackageDescription)
-> IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Bool, GenericPackageDescription)
forall a. IO a
exitFailure
    Right DecodeResult
r -> do
      let hpackOutput :: ByteString
hpackOutput =
            let body :: String
body = [String] -> Package -> String
Hpack.renderPackage [] (DecodeResult -> Package
Hpack.decodeResultPackage DecodeResult
r)
                cabalVersion :: String
cabalVersion = DecodeResult -> String
Hpack.decodeResultCabalVersion DecodeResult
r
            in String -> ByteString
encodeUtf8 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
cabalVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
body
          hash :: String
hash = ByteString -> String
printSHA256 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Algorithm -> ByteString -> ByteString
forall a. Digestable a => Algorithm -> a -> ByteString
digest (String -> Algorithm
digestByName String
"sha256") ByteString
hpackOutput
      case String -> ByteString -> Either String GenericPackageDescription
runParseGenericPackageDescription String
"<hpack output>" ByteString
hpackOutput of
        Left String
msg -> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, GenericPackageDescription)
 -> MaybeT IO (Bool, GenericPackageDescription))
-> IO (Bool, GenericPackageDescription)
-> MaybeT IO (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"*** hpack output:"
          Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
stderr ByteString
hpackOutput
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"*** cannot parse hpack output:"
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
          String -> IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"*** Exiting."
        Right GenericPackageDescription
pkg -> IO (Maybe (Bool, GenericPackageDescription))
-> MaybeT IO (Bool, GenericPackageDescription)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Bool, GenericPackageDescription))
 -> MaybeT IO (Bool, GenericPackageDescription))
-> IO (Maybe (Bool, GenericPackageDescription))
-> MaybeT IO (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, GenericPackageDescription)
-> IO (Maybe (Bool, GenericPackageDescription))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Bool, GenericPackageDescription)
 -> IO (Maybe (Bool, GenericPackageDescription)))
-> Maybe (Bool, GenericPackageDescription)
-> IO (Maybe (Bool, GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (Bool, GenericPackageDescription)
-> Maybe (Bool, GenericPackageDescription)
forall a. a -> Maybe a
Just ((Bool, GenericPackageDescription)
 -> Maybe (Bool, GenericPackageDescription))
-> (Bool, GenericPackageDescription)
-> Maybe (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ (,) Bool
True (GenericPackageDescription -> (Bool, GenericPackageDescription))
-> GenericPackageDescription -> (Bool, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ String -> GenericPackageDescription -> GenericPackageDescription
setCabalFileHash String
hash GenericPackageDescription
pkg

cabalFromFile :: Bool -> FilePath -> MaybeT IO Cabal.GenericPackageDescription
cabalFromFile :: Bool -> String -> MaybeT IO GenericPackageDescription
cabalFromFile Bool
failHard String
file =
  -- hGetContents throws an error if it's used on files which contain sequences
  -- that do not represent valid characters. To catch that exception, we need to
  -- wrap the whole block in `catchIO`.
  IO (Maybe GenericPackageDescription)
-> MaybeT IO GenericPackageDescription
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe GenericPackageDescription)
 -> MaybeT IO GenericPackageDescription)
-> IO (Maybe GenericPackageDescription)
-> MaybeT IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Maybe GenericPackageDescription))
-> IO (Maybe GenericPackageDescription)
-> IO (Maybe GenericPackageDescription)
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO (\IOException
err -> Maybe GenericPackageDescription
forall a. Maybe a
Nothing Maybe GenericPackageDescription
-> IO () -> IO (Maybe GenericPackageDescription)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"*** parsing cabal file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
err)) (IO (Maybe GenericPackageDescription)
 -> IO (Maybe GenericPackageDescription))
-> IO (Maybe GenericPackageDescription)
-> IO (Maybe GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
buf <- String -> IO ByteString
BS.readFile String
file
    let hash :: String
hash = ByteString -> String
printSHA256 (Algorithm -> ByteString -> ByteString
forall a. Digestable a => Algorithm -> a -> ByteString
digest (String -> Algorithm
digestByName String
"sha256") ByteString
buf)
    case String -> ByteString -> Either String GenericPackageDescription
runParseGenericPackageDescription String
file ByteString
buf of
      Left String
msg | Bool
failHard -> IO (Maybe GenericPackageDescription)
-> IO (Maybe GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe GenericPackageDescription)
 -> IO (Maybe GenericPackageDescription))
-> IO (Maybe GenericPackageDescription)
-> IO (Maybe GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"*** cannot parse " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
          String -> IO (Maybe GenericPackageDescription)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"*** Exiting."
      Left String
_ -> Maybe GenericPackageDescription
-> IO (Maybe GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe GenericPackageDescription
forall a. Maybe a
Nothing
      Right GenericPackageDescription
pkg -> Maybe GenericPackageDescription
-> IO (Maybe GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GenericPackageDescription
 -> IO (Maybe GenericPackageDescription))
-> Maybe GenericPackageDescription
-> IO (Maybe GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> Maybe GenericPackageDescription
forall a. a -> Maybe a
Just (GenericPackageDescription -> Maybe GenericPackageDescription)
-> GenericPackageDescription -> Maybe GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ String -> GenericPackageDescription -> GenericPackageDescription
setCabalFileHash String
hash GenericPackageDescription
pkg

runParseGenericPackageDescription
  :: FilePath
  -> BS.ByteString
  -> Either String Cabal.GenericPackageDescription
runParseGenericPackageDescription :: String -> ByteString -> Either String GenericPackageDescription
runParseGenericPackageDescription String
fpath
  = ((Maybe Version, NonEmpty PError) -> String)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
-> Either String GenericPackageDescription
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([String] -> String
unlines ([String] -> String)
-> ((Maybe Version, NonEmpty PError) -> [String])
-> (Maybe Version, NonEmpty PError)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
showPError String
fpath) ([PError] -> [String])
-> ((Maybe Version, NonEmpty PError) -> [PError])
-> (Maybe Version, NonEmpty PError)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PError -> [PError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty PError -> [PError])
-> ((Maybe Version, NonEmpty PError) -> NonEmpty PError)
-> (Maybe Version, NonEmpty PError)
-> [PError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Version, NonEmpty PError) -> NonEmpty PError
forall a b. (a, b) -> b
snd)
  (Either (Maybe Version, NonEmpty PError) GenericPackageDescription
 -> Either String GenericPackageDescription)
-> (ByteString
    -> Either
         (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> ByteString
-> Either String GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PWarning],
 Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall a b. (a, b) -> b
snd (([PWarning],
  Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
 -> Either
      (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> (ByteString
    -> ([PWarning],
        Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ByteString
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult
  (ParseResult GenericPackageDescription
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> (ByteString -> ParseResult GenericPackageDescription)
-> ByteString
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription

setCabalFileHash :: String -> GenericPackageDescription -> GenericPackageDescription
setCabalFileHash :: String -> GenericPackageDescription -> GenericPackageDescription
setCabalFileHash String
sha256 GenericPackageDescription
gpd = GenericPackageDescription
gpd { packageDescription :: PackageDescription
packageDescription = (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd) {
                                      customFieldsPD :: [(String, String)]
customFieldsPD = (String
"X-Cabal-File-Hash", String
sha256) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: PackageDescription -> [(String, String)]
customFieldsPD (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd)
                                    }
                                  }