{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Pantry.Tree
  ( unpackTree
  , rawParseGPD
  ) where

import RIO
import qualified RIO.Map as Map
import qualified RIO.Text as T
import qualified RIO.ByteString as B
import Pantry.Storage hiding (Tree, TreeEntry)
import Pantry.Types
import RIO.FilePath ((</>), takeDirectory)
import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable)
import Path (Path, Abs, Dir, toFilePath)
import Distribution.Parsec (PWarning (..))
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.PackageDescription.Parsec
import Path (File)

unpackTree
  :: (HasPantryConfig env, HasLogFunc env)
  => RawPackageLocationImmutable -- for exceptions
  -> Path Abs Dir -- ^ dest dir, will be created if necessary
  -> Tree
  -> RIO env ()
unpackTree :: RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree RawPackageLocationImmutable
rpli (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath -> FilePath
dir) (TreeMap Map SafeFilePath TreeEntry
m) = do
  ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [(SafeFilePath, TreeEntry)]
-> ((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map SafeFilePath TreeEntry -> [(SafeFilePath, TreeEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath TreeEntry
m) (((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> ((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, TreeEntry BlobKey
blobKey FileType
ft) -> do
    let dest :: FilePath
dest = FilePath
dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp)
    Bool -> FilePath -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True (FilePath -> ReaderT SqlBackend (RIO env) ())
-> FilePath -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
dest
    Maybe ByteString
mbs <- BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
blobKey
    case Maybe ByteString
mbs of
      Maybe ByteString
Nothing -> do
        -- TODO when we have pantry wire stuff, try downloading
        PantryException -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> ReaderT SqlBackend (RIO env) ())
-> PantryException -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
rpli SafeFilePath
sfp BlobKey
blobKey
      Just ByteString
bs -> do
        FilePath -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
B.writeFile FilePath
dest ByteString
bs
        case FileType
ft of
          FileType
FTNormal -> () -> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          FileType
FTExecutable -> IO () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SqlBackend (RIO env) ())
-> IO () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ do
            Permissions
perms <- FilePath -> IO Permissions
forall (m :: * -> *). MonadIO m => FilePath -> m Permissions
getPermissions FilePath
dest
            FilePath -> Permissions -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> Permissions -> m ()
setPermissions FilePath
dest (Permissions -> IO ()) -> Permissions -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Permissions -> Permissions
setOwnerExecutable Bool
True Permissions
perms

-- | A helper function that performs the basic character encoding
-- necessary.
rawParseGPD
  :: MonadThrow m
  => Either RawPackageLocationImmutable (Path Abs File)
  -> ByteString
  -> m ([PWarning], GenericPackageDescription)
rawParseGPD :: Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD Either RawPackageLocationImmutable (Path Abs File)
loc ByteString
bs =
    case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres of
      Left (Maybe Version
mversion, NonEmpty PError
errs) -> PantryException -> m ([PWarning], GenericPackageDescription)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PantryException -> m ([PWarning], GenericPackageDescription))
-> PantryException -> m ([PWarning], GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ Either RawPackageLocationImmutable (Path Abs File)
-> Maybe Version -> [PError] -> [PWarning] -> PantryException
InvalidCabalFile Either RawPackageLocationImmutable (Path Abs File)
loc Maybe Version
mversion (NonEmpty PError -> [PError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs) [PWarning]
warnings
      Right GenericPackageDescription
gpkg -> ([PWarning], GenericPackageDescription)
-> m ([PWarning], GenericPackageDescription)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PWarning]
warnings, GenericPackageDescription
gpkg)
  where
    ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres) = 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))
-> ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
bs