{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module HaskellWorks.CabalCache.Concurrent.DownloadQueue
  ( createDownloadQueue
  , anchor
  , runQueue
  ) where

import Control.Monad.IO.Class
import Data.Set               ((\\))

import qualified Control.Concurrent.STM                  as STM
import qualified Data.Map                                as M
import qualified Data.Relation                           as R
import qualified Data.Set                                as S
import qualified HaskellWorks.CabalCache.Concurrent.Type as Z

anchor :: Z.PackageId -> M.Map Z.ConsumerId Z.ProviderId -> M.Map Z.ConsumerId Z.ProviderId
anchor :: PackageId -> Map PackageId PackageId -> Map PackageId PackageId
anchor PackageId
root Map PackageId PackageId
dependencies = Map PackageId PackageId
-> Map PackageId PackageId -> Map PackageId PackageId
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map PackageId PackageId
dependencies (Map PackageId PackageId -> Map PackageId PackageId)
-> Map PackageId PackageId -> Map PackageId PackageId
forall a b. (a -> b) -> a -> b
$ PackageId -> PackageId -> Map PackageId PackageId
forall k a. k -> a -> Map k a
M.singleton PackageId
root ([PackageId] -> PackageId
forall a. Monoid a => [a] -> a
mconcat (Map PackageId PackageId -> [PackageId]
forall k a. Map k a -> [a]
M.elems Map PackageId PackageId
dependencies))

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 (m :: * -> *) a. Monad m => a -> m a
return DownloadQueue :: TVar (Relation PackageId PackageId)
-> TVar (Set PackageId) -> TVar (Set PackageId) -> DownloadQueue
Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
$sel:tFailures:DownloadQueue :: TVar (Set PackageId)
$sel:tUploading:DownloadQueue :: TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: TVar (Relation PackageId PackageId)
tFailures :: TVar (Set PackageId)
tUploading :: TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
..}

takeReady :: Z.DownloadQueue -> STM.STM (Maybe Z.PackageId)
takeReady :: DownloadQueue -> STM (Maybe PackageId)
takeReady Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
tFailures :: TVar (Set PackageId)
tUploading :: TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation 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
  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 (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 (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)
tFailures :: TVar (Set PackageId)
tUploading :: TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId 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)
tFailures :: TVar (Set PackageId)
tUploading :: TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId 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 => Z.DownloadQueue -> (Z.PackageId -> m Bool) -> m ()
runQueue :: DownloadQueue -> (PackageId -> m Bool) -> m ()
runQueue downloadQueue :: DownloadQueue
downloadQueue@Z.DownloadQueue {TVar (Set PackageId)
TVar (Relation PackageId PackageId)
tFailures :: TVar (Set PackageId)
tUploading :: TVar (Set PackageId)
tDependencies :: TVar (Relation PackageId PackageId)
$sel:tFailures:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tUploading:DownloadQueue :: DownloadQueue -> TVar (Set PackageId)
$sel:tDependencies:DownloadQueue :: DownloadQueue -> TVar (Relation PackageId PackageId)
..} PackageId -> m Bool
f = do
  Maybe PackageId
maybePackageId <- IO (Maybe PackageId) -> m (Maybe PackageId)
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
      Bool
success <- PackageId -> m Bool
f PackageId
packageId
      if Bool
success
        then IO () -> m ()
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
        else IO () -> m ()
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 Bool) -> m ()
forall (m :: * -> *).
MonadIO m =>
DownloadQueue -> (PackageId -> m Bool) -> m ()
runQueue DownloadQueue
downloadQueue PackageId -> m Bool
f

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