{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module HaskellWorks.CabalCache.Concurrent.DownloadQueue
  ( DownloadStatus(..),
    createDownloadQueue,
    runQueue,
    downloadSucceed,
    downloadFail,
  ) where

import Control.Monad.Catch          (MonadMask(..))
import Control.Monad.Except         (MonadError)
import Data.Set                     ((\\))
import Prelude                      hiding (fail)
import HaskellWorks.Prelude

import qualified Control.Concurrent.STM                  as STM
import qualified Control.Monad.Catch                     as CMC
import qualified Control.Monad.Oops                      as OO
import qualified Data.Relation                           as R
import qualified Data.Set                                as S
import qualified HaskellWorks.CabalCache.Concurrent.Type as Z
import qualified HaskellWorks.CabalCache.IO.Console      as CIO
import qualified System.IO                               as IO

data DownloadStatus = DownloadSuccess | DownloadFailure deriving (DownloadStatus -> DownloadStatus -> Bool
(DownloadStatus -> DownloadStatus -> Bool)
-> (DownloadStatus -> DownloadStatus -> Bool) -> Eq DownloadStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DownloadStatus -> DownloadStatus -> Bool
== :: DownloadStatus -> DownloadStatus -> Bool
$c/= :: DownloadStatus -> DownloadStatus -> Bool
/= :: DownloadStatus -> DownloadStatus -> Bool
Eq, Int -> DownloadStatus -> ShowS
[DownloadStatus] -> ShowS
DownloadStatus -> String
(Int -> DownloadStatus -> ShowS)
-> (DownloadStatus -> String)
-> ([DownloadStatus] -> ShowS)
-> Show DownloadStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DownloadStatus -> ShowS
showsPrec :: Int -> DownloadStatus -> ShowS
$cshow :: DownloadStatus -> String
show :: DownloadStatus -> String
$cshowList :: [DownloadStatus] -> ShowS
showList :: [DownloadStatus] -> ShowS
Show)

downloadSucceed :: forall e a m. ()
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` DownloadStatus
  => m a
downloadSucceed :: forall (e :: [*]) a (m :: * -> *).
(MonadError (Variant e) m, CouldBe e DownloadStatus) =>
m a
downloadSucceed = DownloadStatus -> m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw DownloadStatus
DownloadSuccess

downloadFail :: forall e a m. ()
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` DownloadStatus
  => m a
downloadFail :: forall (e :: [*]) a (m :: * -> *).
(MonadError (Variant e) m, CouldBe e DownloadStatus) =>
m a
downloadFail = DownloadStatus -> m a
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw DownloadStatus
DownloadFailure

createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue
createDownloadQueue :: [(PackageId, PackageId)] -> STM DownloadQueue
createDownloadQueue [(PackageId, PackageId)]
dependencies = do
  TVar (Relation PackageId PackageId)
tDependencies <- Relation PackageId PackageId
-> STM (TVar (Relation PackageId PackageId))
forall a. a -> STM (TVar a)
STM.newTVar ([(PackageId, PackageId)] -> Relation PackageId PackageId
forall a b. (Ord a, Ord b) => [(a, b)] -> Relation a b
R.fromList [(PackageId, PackageId)]
dependencies)
  TVar (Set PackageId)
tUploading    <- Set PackageId -> STM (TVar (Set PackageId))
forall a. a -> STM (TVar a)
STM.newTVar Set PackageId
forall a. Set a
S.empty
  TVar (Set PackageId)
tFailures     <- Set PackageId -> STM (TVar (Set PackageId))
forall a. a -> STM (TVar a)
STM.newTVar Set PackageId
forall a. Set a
S.empty
  DownloadQueue -> STM DownloadQueue
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
tUploading :: TVar (Set PackageId)
tFailures :: TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: TVar (Relation PackageId PackageId)
$sel:tUploading:DownloadQueue :: TVar (Set PackageId)
$sel:tFailures:DownloadQueue :: TVar (Set PackageId)
..}

takeReady :: Z.DownloadQueue -> STM.STM (Maybe Z.PackageId)
takeReady :: DownloadQueue -> STM (Maybe PackageId)
takeReady Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
tUploading :: TVar (Set PackageId)
tFailures :: TVar (Set PackageId)
..} = do
  Relation PackageId PackageId
dependencies  <- TVar (Relation PackageId PackageId)
-> STM (Relation PackageId PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Relation PackageId PackageId)
tDependencies
  Set PackageId
uploading     <- TVar (Set PackageId) -> STM (Set PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Set PackageId)
tUploading
  Set PackageId
failures      <- TVar (Set PackageId) -> STM (Set PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Set PackageId)
tFailures

  let ready :: Set PackageId
ready = Relation PackageId PackageId -> Set PackageId
forall a b. Relation a b -> Set b
R.ran Relation PackageId PackageId
dependencies Set PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => Set a -> Set a -> Set a
\\ Relation PackageId PackageId -> Set PackageId
forall a b. Relation a b -> Set a
R.dom Relation PackageId PackageId
dependencies Set PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => Set a -> Set a -> Set a
\\ Set PackageId
uploading Set PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => Set a -> Set a -> Set a
\\ Set PackageId
failures

  case Set PackageId -> Maybe PackageId
forall a. Set a -> Maybe a
S.lookupMin Set PackageId
ready of
    Just PackageId
packageId -> do
      TVar (Set PackageId) -> Set PackageId -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Set PackageId)
tUploading (PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => a -> Set a -> Set a
S.insert PackageId
packageId Set PackageId
uploading)
      Maybe PackageId -> STM (Maybe PackageId)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> Maybe PackageId
forall a. a -> Maybe a
Just PackageId
packageId)
    Maybe PackageId
Nothing -> if Set PackageId -> Bool
forall a. Set a -> Bool
S.null (Relation PackageId PackageId -> Set PackageId
forall a b. Relation a b -> Set b
R.ran Relation PackageId PackageId
dependencies Set PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => Set a -> Set a -> Set a
\\ Relation PackageId PackageId -> Set PackageId
forall a b. Relation a b -> Set a
R.dom Relation PackageId PackageId
dependencies Set PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => Set a -> Set a -> Set a
\\ Set PackageId
failures)
      then Maybe PackageId -> STM (Maybe PackageId)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageId
forall a. Maybe a
Nothing
      else STM (Maybe PackageId)
forall a. STM a
STM.retry

commit :: Z.DownloadQueue -> Z.PackageId -> STM.STM ()
commit :: DownloadQueue -> PackageId -> STM ()
commit Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
tUploading :: TVar (Set PackageId)
tFailures :: TVar (Set PackageId)
..} PackageId
packageId = do
  Relation PackageId PackageId
dependencies  <- TVar (Relation PackageId PackageId)
-> STM (Relation PackageId PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Relation PackageId PackageId)
tDependencies
  Set PackageId
uploading     <- TVar (Set PackageId) -> STM (Set PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Set PackageId)
tUploading

  TVar (Set PackageId) -> Set PackageId -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Set PackageId)
tUploading    (Set PackageId -> STM ()) -> Set PackageId -> STM ()
forall a b. (a -> b) -> a -> b
$ PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => a -> Set a -> Set a
S.delete PackageId
packageId Set PackageId
uploading
  TVar (Relation PackageId PackageId)
-> Relation PackageId PackageId -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Relation PackageId PackageId)
tDependencies (Relation PackageId PackageId -> STM ())
-> Relation PackageId PackageId -> STM ()
forall a b. (a -> b) -> a -> b
$ Set PackageId
-> Relation PackageId PackageId -> Relation PackageId PackageId
forall a b. (Ord a, Ord b) => Set b -> Relation a b -> Relation a b
R.withoutRan (PackageId -> Set PackageId
forall a. a -> Set a
S.singleton PackageId
packageId) Relation PackageId PackageId
dependencies

failDownload :: Z.DownloadQueue -> Z.PackageId -> STM.STM ()
failDownload :: DownloadQueue -> PackageId -> STM ()
failDownload Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
tUploading :: TVar (Set PackageId)
tFailures :: TVar (Set PackageId)
..} PackageId
packageId = do
  Set PackageId
uploading <- TVar (Set PackageId) -> STM (Set PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Set PackageId)
tUploading
  Set PackageId
failures  <- TVar (Set PackageId) -> STM (Set PackageId)
forall a. TVar a -> STM a
STM.readTVar TVar (Set PackageId)
tFailures

  TVar (Set PackageId) -> Set PackageId -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Set PackageId)
tUploading  (Set PackageId -> STM ()) -> Set PackageId -> STM ()
forall a b. (a -> b) -> a -> b
$ PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => a -> Set a -> Set a
S.delete PackageId
packageId Set PackageId
uploading
  TVar (Set PackageId) -> Set PackageId -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Set PackageId)
tFailures   (Set PackageId -> STM ()) -> Set PackageId -> STM ()
forall a b. (a -> b) -> a -> b
$ PackageId -> Set PackageId -> Set PackageId
forall a. Ord a => a -> Set a -> Set a
S.insert PackageId
packageId Set PackageId
failures

runQueue :: (MonadIO m, MonadMask m) => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m ()
runQueue :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
DownloadQueue -> (PackageId -> m DownloadStatus) -> m ()
runQueue DownloadQueue
downloadQueue PackageId -> m DownloadStatus
f = do
  Maybe PackageId
maybePackageId <- IO (Maybe PackageId) -> m (Maybe PackageId)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe PackageId) -> m (Maybe PackageId))
-> IO (Maybe PackageId) -> m (Maybe PackageId)
forall a b. (a -> b) -> a -> b
$ STM (Maybe PackageId) -> IO (Maybe PackageId)
forall a. STM a -> IO a
STM.atomically (STM (Maybe PackageId) -> IO (Maybe PackageId))
-> STM (Maybe PackageId) -> IO (Maybe PackageId)
forall a b. (a -> b) -> a -> b
$ DownloadQueue -> STM (Maybe PackageId)
takeReady DownloadQueue
downloadQueue

  case Maybe PackageId
maybePackageId of
    Just PackageId
packageId -> do
      DownloadStatus
downloadStatus <- PackageId -> m DownloadStatus
f PackageId
packageId
        m DownloadStatus
-> (m DownloadStatus -> m DownloadStatus) -> m DownloadStatus
forall a b. a -> (a -> b) -> b
& do (SomeException -> m DownloadStatus)
-> m DownloadStatus -> m DownloadStatus
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
(SomeException -> m a) -> m a -> m a
CMC.handleAll \SomeException
e -> do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> PackageId -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> PackageId -> m ()
CIO.hPutStrLn Handle
IO.stderr (PackageId -> IO ()) -> PackageId -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageId
"Warning: Unexpected exception during download of " PackageId -> PackageId -> PackageId
forall a. Semigroup a => a -> a -> a
<> PackageId
packageId PackageId -> PackageId -> PackageId
forall a. Semigroup a => a -> a -> a
<> PackageId
": " PackageId -> PackageId -> PackageId
forall a. Semigroup a => a -> a -> a
<> SomeException -> PackageId
forall a. Show a => a -> PackageId
tshow SomeException
e
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
IO.hFlush Handle
IO.stderr
              DownloadStatus -> m DownloadStatus
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DownloadStatus
DownloadFailure
      case DownloadStatus
downloadStatus of
        DownloadStatus
DownloadSuccess -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> PackageId -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> PackageId -> m ()
CIO.hPutStrLn Handle
IO.stderr (PackageId -> IO ()) -> PackageId -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageId
"Downloaded " PackageId -> PackageId -> PackageId
forall a. Semigroup a => a -> a -> a
<> PackageId
packageId
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DownloadQueue -> PackageId -> STM ()
commit DownloadQueue
downloadQueue PackageId
packageId
        DownloadStatus
DownloadFailure -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> PackageId -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> PackageId -> m ()
CIO.hPutStrLn Handle
IO.stderr (PackageId -> IO ()) -> PackageId -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageId
"Failed to download " PackageId -> PackageId -> PackageId
forall a. Semigroup a => a -> a -> a
<> PackageId
packageId
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ DownloadQueue -> PackageId -> STM ()
failDownload DownloadQueue
downloadQueue PackageId
packageId
      DownloadQueue -> (PackageId -> m DownloadStatus) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
DownloadQueue -> (PackageId -> m DownloadStatus) -> m ()
runQueue DownloadQueue
downloadQueue PackageId -> m DownloadStatus
f

    Maybe PackageId
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()