module Debian.Repo.IO
( AptIOT
, io
, tio
, runAptIO
, tryAB
, IOState
, setRepoMap
, getRepoMap
, lookupRepository
, insertRepository
, lookupAptImage
, insertAptImage
, lookupSourcePackages
, insertSourcePackages
, lookupBinaryPackages
, insertBinaryPackages
, readParagraphs
, findRelease
, putRelease
, countTasks
) where
import qualified Debian.Control.ByteString as B
import Debian.Repo.Types
import Control.Exception
import Control.Monad.RWS
import Control.Monad.Trans
import Data.Char
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Debian.URI
import Extra.TIO
import qualified System.IO as IO
import System.Posix.Files
import Text.Printf
instance Ord FileStatus where
compare a b = compare (deviceID a, fileID a, modificationTime a) (deviceID b, fileID b, modificationTime b)
instance Eq FileStatus where
a == b = compare a b == EQ
type AptIOT = RWST () () IOState
type AptIO = AptIOT TIO
data IOState
= IOState { repoMap :: Map.Map URI (Maybe Repository)
, releaseMap :: Map.Map (URI, ReleaseName) (Maybe Release)
, aptImageMap :: Map.Map SliceName (Maybe AptImage)
, sourcePackageMap :: Map.Map FilePath (Maybe (FileStatus, [SourcePackage]))
, binaryPackageMap :: Map.Map FilePath (Maybe (FileStatus, [BinaryPackage]))
}
io :: CIO m => IO a -> AptIOT m a
io = lift . liftIO
tio :: CIO m => m a -> AptIOT m a
tio = lift
runAptIO :: CIO m => AptIOT m a -> m a
runAptIO action = (runRWST action) () initState >>= \ (a, _, _) -> return a
tryAB :: AptIO a -> AptIO (Either Exception a)
tryAB task =
do
state <- get
liftAB (try' state) task
where
try' state task =
do result <- tryTIO task
case result of
Left e -> return (Left e, state, ())
Right (a, s, _) -> return (Right a, s, ())
liftAB :: (TIO (a, IOState, ()) -> TIO (b, IOState, ())) -> (AptIO a -> AptIO b)
liftAB f = mapRWST f
initState :: IOState
initState = IOState { repoMap = Map.empty
, releaseMap = Map.empty
, aptImageMap = Map.empty
, sourcePackageMap = Map.empty
, binaryPackageMap = Map.empty
}
setRepoMap :: Map.Map URI (Maybe Repository) -> IOState -> IOState
setRepoMap m state = state {repoMap = m}
getRepoMap :: IOState -> Map.Map URI (Maybe Repository)
getRepoMap state = repoMap state
lookupRepository :: URI -> IOState -> Maybe Repository
lookupRepository uri state = Map.findWithDefault Nothing uri (repoMap state)
insertRepository :: URI -> Repository -> IOState -> IOState
insertRepository uri repo state = state {repoMap = Map.insert uri (Just repo) (repoMap state)}
lookupAptImage :: SliceName -> IOState -> Maybe AptImage
lookupAptImage name state = Map.findWithDefault Nothing name (aptImageMap state)
insertAptImage :: SliceName -> AptImage -> IOState -> IOState
insertAptImage name image state = state {aptImageMap = Map.insert name (Just image) (aptImageMap state)}
lookupSourcePackages :: FilePath -> IOState -> Maybe (FileStatus, [SourcePackage])
lookupSourcePackages key state = Map.findWithDefault Nothing key (sourcePackageMap state)
insertSourcePackages :: FilePath -> (FileStatus, [SourcePackage]) -> IOState -> IOState
insertSourcePackages key packages state = state {sourcePackageMap = Map.insert key (Just packages) (sourcePackageMap state)}
lookupBinaryPackages :: FilePath -> IOState -> Maybe (FileStatus, [BinaryPackage])
lookupBinaryPackages key state = Map.findWithDefault Nothing key (binaryPackageMap state)
insertBinaryPackages :: FilePath -> (FileStatus, [BinaryPackage]) -> IOState -> IOState
insertBinaryPackages key packages state =
state {binaryPackageMap = Map.insert key (Just packages) (binaryPackageMap state)}
readParagraphs :: FilePath -> IO [B.Paragraph]
readParagraphs path =
do
h <- IO.openBinaryFile path IO.ReadMode
B.Control paragraphs <- B.parseControlFromHandle path h >>= return . (either (error . show) id)
IO.hClose h
return paragraphs
findRelease :: Repository -> ReleaseName -> IOState -> Maybe Release
findRelease repo dist state =
Map.findWithDefault Nothing (repoURI repo, dist) (releaseMap state)
putRelease :: Repository -> ReleaseName -> Release -> IOState -> IOState
putRelease repo dist release state =
state {releaseMap = Map.insert (repoURI repo, dist) (Just release) (releaseMap state)}
countTasks :: CIO m => [(String, m a)] -> m [a]
countTasks tasks =
mapM (countTask (length tasks)) (zip [1..] tasks)
where
countTask :: CIO m => Int -> (Int, (String, m a)) -> m a
countTask count (index, (message, task)) =
(ePutStrBl (printf "[%2d of %2d] %s:" index count message)) >>
task