{-# 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 ()