{-# LANGUAGE NamedFieldPuns #-}
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
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.
           -> FetchSubmodules
           -- ^ 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
-> FetchSubmodules
-> Maybe String
-> Maybe UTCTime
-> Source
-> IO Package
getPackage HpackUse
optHpack FetchSubmodules
optSubmodules Maybe String
optHackageDB Maybe UTCTime
optHackageSnapshot =
  HpackUse -> FetchSubmodules -> IO HackageDB -> Source -> IO Package
getPackage' HpackUse
optHpack FetchSubmodules
optSubmodules (Maybe String -> Maybe UTCTime -> IO HackageDB
loadHackageDB Maybe String
optHackageDB Maybe UTCTime
optHackageSnapshot)

getPackage' :: HpackUse
            -- ^ the way hpack should be used.
            -> FetchSubmodules
            -- ^ Whether to fetch submodules if fetching from git
            -> IO DB.HackageDB
            -> Source
            -> IO Package
getPackage' :: HpackUse -> FetchSubmodules -> IO HackageDB -> Source -> IO Package
getPackage' HpackUse
optHpack FetchSubmodules
optSubmodules IO HackageDB
hackageDB Source
source = do
  (Maybe DerivationSource
derivSource, Bool
pkgRanHpack, GenericPackageDescription
pkgCabal) <- HpackUse
-> FetchSubmodules
-> IO HackageDB
-> Source
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
fetchOrFromDB HpackUse
optHpack FetchSubmodules
optSubmodules IO HackageDB
hackageDB Source
source
  DerivationSource
pkgSource <-
    case Maybe DerivationSource
derivSource of
      Maybe DerivationSource
Nothing ->
        Hash -> String -> String -> IO DerivationSource
sourceFromHackage
          (Source -> Hash
sourceHash Source
source)
          (GenericPackageDescription -> String
showPackageIdentifier GenericPackageDescription
pkgCabal)
          (Source -> String
sourceCabalDir Source
source)
      Just DerivationSource
derivSource' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivationSource
derivSource'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Package {
    DerivationSource
pkgSource :: DerivationSource
pkgSource :: DerivationSource
pkgSource,
    Bool
pkgRanHpack :: Bool
pkgRanHpack :: Bool
pkgRanHpack,
    GenericPackageDescription
pkgCabal :: GenericPackageDescription
pkgCabal :: GenericPackageDescription
pkgCabal
  }

fetchOrFromDB :: HpackUse
              -- ^ the way hpack should be used
              -> FetchSubmodules
              -- ^ Whether to fetch submodules if fetching from git
              -> IO DB.HackageDB
              -> Source
              -> IO (Maybe DerivationSource, Bool, Cabal.GenericPackageDescription)
fetchOrFromDB :: HpackUse
-> FetchSubmodules
-> IO HackageDB
-> Source
-> IO (Maybe DerivationSource, Bool, GenericPackageDescription)
fetchOrFromDB HpackUse
optHpack FetchSubmodules
optSubmodules IO HackageDB
hackageDB Source
src
  | String
"cabal://" 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"cabal://") forall a b. (a -> b) -> a -> b
$ Source -> String
sourceUrl Source
src
      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 <- forall a.
FetchSubmodules
-> (String -> MaybeT IO a)
-> Source
-> IO (Maybe (DerivationSource, a))
fetch FetchSubmodules
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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to fetch source. Does this source exist? " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Source
src
      Just (DerivationSource
derivSource, (Bool
externalSource, Bool
ranHpack, GenericPackageDescription
pkgDesc)) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (DerivationSource
derivSource forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 <- case Maybe String
optHackageDB of
    Maybe String
Nothing -> IO String
DB.hackageTarball
    Just String
hackageDb -> forall (m :: * -> *) a. Monad m => a -> m a
return String
hackageDb
  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 <- case forall k a. Ord k => k -> Map k a -> Maybe a
DB.lookup PackageName
name HackageDB
hackageDB forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map Version VersionData -> Maybe VersionData
lookupVersion of
    Maybe VersionData
Nothing -> forall {a}. IO a
unknownPackageError
    Just VersionData
versionData -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VersionData
versionData
  let ds :: Maybe DerivationSource
ds = case VersionData -> Maybe String
DB.tarballSha256 VersionData
vd of
             Maybe String
Nothing -> forall a. Maybe a
Nothing
             Just String
hash -> forall a. a -> Maybe a
Just (String -> String -> DerivationSource
urlDerivationSource String
url String
hash)
  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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error (String
"invalid Haskell package id " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
pkg)) (forall a. Parsec a => String -> Maybe a
simpleParsec String
pkg)
  name :: PackageName
name = forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName PackageIdentifier
pkgId

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

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

  version :: Version
  version :: Version
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 :: Map Version VersionData -> Maybe VersionData
lookupVersion Map Version VersionData
m | Version
version forall a. Eq a => a -> a -> Bool
== Version
nullVersion  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall a. [a] -> Maybe a
listToMaybe (forall k a. Map k a -> [(k, a)]
DB.toDescList Map Version VersionData
m))
  lookupVersion Map Version VersionData
m                           = forall k a. Ord k => k -> Map k a -> Maybe a
DB.lookup Version
version Map Version VersionData
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 forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
file
    else forall (m :: * -> *) a. Monad m => a -> m a
return 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hash
Certain forall a b. (a -> b) -> a -> b
$ String
h
      Guess   String
h -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hash
Guess forall a b. (a -> b) -> a -> b
$ String
h
      Hash
_         -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hash
UnknownHash String -> Hash
Certain) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
readFileMay forall a b. (a -> b) -> a -> b
$ String
cacheFile
  let url :: String
url = String
"mirror://hackage/" forall a. [a] -> [a] -> [a]
++ String
pkgId 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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.
      seq :: forall a b. a -> b -> b
seq (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hash) forall a b. (a -> b) -> a -> b
$
      String -> String -> DerivationSource
urlDerivationSource String
url String
hash 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 <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
        forall a b. (a -> b) -> a -> b
$ DerivationSource -> String
derivHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool, DerivKind) -> Source -> MaybeT IO (DerivationSource, String)
fetchWith
              (Bool
False, UnpackArchive -> DerivKind
DerivKindUrl UnpackArchive
DontUnpackArchive)
              (Source {
                sourceUrl :: String
sourceUrl = String
url,
                sourceRevision :: String
sourceRevision = String
"",
                sourceHash :: Hash
sourceHash = Hash
UnknownHash,
                sourceCabalDir :: String
sourceCabalDir = String
cabalDir
              })
      case Maybe String
maybeHash of
        Just String
hash ->
          seq :: forall a b. a -> b -> b
seq (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hash) forall a b. (a -> b) -> a -> b
$
          String -> String -> DerivationSource
urlDerivationSource String
url String
hash 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 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."
            ]
          forall {a}. IO a
exitFailure

showPackageIdentifier :: Cabal.GenericPackageDescription -> String
showPackageIdentifier :: GenericPackageDescription -> String
showPackageIdentifier GenericPackageDescription
pkgDesc = String
name forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow Version
version where
  pkgId :: PackageIdentifier
pkgId = PackageDescription -> PackageIdentifier
Cabal.package forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
Cabal.packageDescription forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
pkgDesc
  name :: String
name = PackageName -> String
Cabal.unPackageName (forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName PackageIdentifier
pkgId)
  version :: Version
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
d, Bool
ranHpack, GenericPackageDescription
pkg)
  else (,,) Bool
d Bool
False 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
shouldUseHpack String
dir
  if Bool
useHpack
    then do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
findCabalFiles String
dir
  case [String]
cabals of
    [] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errMsg
    [String
cabalFile] -> (,) Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> MaybeT IO GenericPackageDescription
cabalFromFile Bool
True String
cabalFile
    [String]
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"*** found more than one cabal file (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
cabals forall a. [a] -> [a] -> [a]
++ String
"). Exiting.")

-- | Returns a list of files ending with the @.cabal@ suffix.
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles :: String -> IO [String]
findCabalFiles String
dir = do
  [String]
contents <- String -> IO [String]
getDirectoryContents String
dir
  forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> ShowS
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall a b. (a -> b) -> a -> b
$ [String]
contents

-- | This function returns 'True' if a @package.yaml@ is present and there
-- are no @.cabal@ files in the directory.
shouldUseHpack :: FilePath -> IO Bool
shouldUseHpack :: String -> IO Bool
shouldUseHpack String
dir = do
  Bool
hpackExists <- String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
"package.yaml")
  if Bool
hpackExists
    then do
      [String]
cabalFiles <- String -> IO [String]
findCabalFiles String
dir
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cabalFiles
    else
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a
handleIO :: forall a. (IOException -> IO a) -> IO a -> IO a
handleIO = 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 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"*** hpack error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err forall a. [a] -> [a] -> [a]
++ String
". Exiting.") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall a b. (a -> b) -> a -> b
$ String
cabalVersion forall a. [a] -> [a] -> [a]
++ String
body
          hash :: String
hash = ByteString -> String
printSHA256 forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"*** Exiting."
        Right GenericPackageDescription
pkg -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (,) Bool
True 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`.
  forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. (IOException -> IO a) -> IO a -> IO a
handleIO (\IOException
err -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"*** parsing cabal file: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
err)) forall a b. (a -> b) -> a -> b
$ do
    ByteString
buf <- String -> IO ByteString
BS.readFile String
file
    let hash :: String
hash = ByteString -> String
printSHA256 (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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"*** cannot parse " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
file forall a. [a] -> [a] -> [a]
++ String
":"
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"*** Exiting."
      Left String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Right GenericPackageDescription
pkg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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
  = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
showPError String
fpath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult
  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) forall a. a -> [a] -> [a]
: PackageDescription -> [(String, String)]
customFieldsPD (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd)
                                    }
                                  }