moduleDebian.Repo.LocalRepositorywhereimportqualifiedDebian.Control.ByteStringasB-- required despite warningimportqualifiedDebian.Control.StringasSimportDebian.Repo.IOimportDebian.Repo.Types--import Debian.ReleaseimportControl.Monad.TransimportControl.Monad.State(get,put)importExtra.CIOimportControl.MonadimportqualifiedData.ByteString.Char8asBimportData.ListimportData.MaybeimportExtra.FilesimportExtra.List(partitionM)importSystem.FilePathimportSystem.Unix.DirectoryimportSystem.DirectoryimportSystem.IOimportqualifiedSystem.Posix.FilesasFimportText.Regex-- | Create or update the compatibility level file for a repository.setRepositoryCompatibility::LocalRepository->IO()setRepositoryCompatibility(LocalRepositoryroot__)=maybeWriteFilepathtextwheretext=showlibraryCompatibilityLevel++"\n"path=outsidePathroot</>compatibilityFile-- | Return the subdirectory where a source package with the given-- section and name would be installed given the layout of the-- repository.poolDir::LocalRepository->Section->String->FilePathpoolDir(LocalRepository_(JustPool)_)sectionsource="pool/"++sectionName'section</>prefixDir</>sourcewhereprefixDir=ifisPrefixOf"lib"sourcethentake(min4(lengthsource))sourceelsetake(min1(lengthsource))sourcepoolDir(LocalRepository___)__=""-- | Remove all the packages from the repository and then re-create-- the empty releases.flushLocalRepository::CIOm=>LocalRepository->AptIOTmLocalRepositoryflushLocalRepository(LocalRepositorypathlayout_)=doliftIO$removeRecursiveSafely(outsidePathpath)prepareLocalRepositorypathlayout-- | Create or verify the existance of the directories which will hold-- a repository on the local machine. Verify the index files for each of-- its existing releases.prepareLocalRepository::CIOm=>EnvPath->MaybeLayout->AptIOTmLocalRepositoryprepareLocalRepositoryrootlayout=dolift(vPutStrBl3$"Preparing local repository at "++outsidePathroot)mapM_(liftIO.initDir)[(".",0o40755),("dists",0o40755),("incoming",0o41755),("removed",0o40750),("reject",0o40750)]layout'<-lift(liftIO(computeLayout(outsidePathroot)))>>=(return.maybelayoutJust)-- >>= return . maybe (maybe (error "No layout specified for new repository") id layout) idmapM_(liftIO.initDir)(caselayout'ofJustPool->[("pool",0o40755),("installed",0o40755)]JustFlat->[]Nothing->[])readLocalReporootlayout'whereinitDir(name,mode)=doletpath=outsidePathroot</>namefilterM(\f->doesDirectoryExistf>>=return.not)[path]>>=mapM_(\f->createDirectoryIfMissingTruef)actualMode<-F.getFileStatuspath>>=return.F.fileModewhen(mode/=actualMode)(F.setFileModepathmode){- notSymbolicLink root name =
getSymbolicLinkStatus (root ++ "/dists/" ++ name) >>= return . not . isSymbolicLink
hasReleaseFile root name =
doesFileExist (root ++ "/dists/" ++ name ++ "/Release") -}readLocalRepo::CIOm=>EnvPath->MaybeLayout->AptIOTmLocalRepositoryreadLocalReporootlayout=dostate<-getnames<-liftIO(getDirectoryContentsdistDir)>>=return.filter(\x->not.elemx$[".",".."])(links,dists)<-partitionM(liftIO.isSymLink.(distDir</>))nameslinkText<-mapM(liftIO.F.readSymbolicLink)(map(distDir</>)links)letaliasPairs=ziplinkTextlinks++map(\dist->(dist,dist))distsletdistGroups=groupByfstEq.sort$aliasPairsletaliases=map(checkAliases.partition(uncurry(==)))distGroupsreleaseInfo<-mapM(lift.getReleaseInfo)aliasesletrepo=LocalRepository{repoRoot=root,repoLayout=layout,repoReleaseInfoLocal=releaseInfo}put(insertRepository(repoURIrepo)(LocalReporepo)state)returnrepowherefstEq(a,_)(b,_)=a==bcheckAliases::([(String,String)],[(String,String)])->(ReleaseName,[ReleaseName])checkAliases([(realName,_)],aliases)=(parseReleaseNamerealName,map(parseReleaseName.snd)aliases)checkAliases_=error"Symbolic link points to itself!"getReleaseInfo::CIOm=>(ReleaseName,[ReleaseName])->mReleaseInfogetReleaseInfo(dist,aliases)=parseReleaseFile(releasePathdist)distaliasesreleasePathdist=distDir</>releaseName'dist++"/Release"distDir=outsidePathroot++"/dists"parseReleaseFile::CIOm=>FilePath->ReleaseName->[ReleaseName]->mReleaseInfoparseReleaseFilepathdistaliases=dotext<-liftIO(B.readFilepath)return$parseReleasepathtextdistaliasesparseRelease::FilePath->B.ByteString->ReleaseName->[ReleaseName]->ReleaseInfoparseReleasefiletextnamealiases=caseeither(error.show)id(B.parseControlfiletext)ofS.Control[]->error$"Empty release file: "++fileS.Control(info:_)->makeReleaseInfofileinfonamealiasesmakeReleaseInfo::FilePath->B.Paragraph->ReleaseName->[ReleaseName]->ReleaseInfomakeReleaseInfofileinfonamealiases=case(B.fieldValue"Architectures"info,B.fieldValue"Components"info)of(JustarchList,JustcompList)->case(splitRegexre(B.unpackarchList),splitRegexre(B.unpackcompList))of(architectures@(_:_),components@(_:_))->ReleaseInfo{releaseInfoName=name,releaseInfoAliases=aliases,releaseInfoArchitectures=mapBinaryarchitectures,releaseInfoComponents=mapSectioncomponents}_->error$"Invalid Architectures or Components field in Release file "++file_->error$"Missing Architectures or Components field in Release file "++filewherere=mkRegex"[ ,]+"isSymLinkpath=F.getSymbolicLinkStatuspath>>=return.F.isSymbolicLink-- |Try to determine a repository's layout.computeLayout::FilePath->IO(MaybeLayout)computeLayoutroot=do-- If there are already .dsc files in the root directory-- the repository layout is Flat.isFlat<-getDirectoryContentsroot>>=return.(/=[]).catMaybes.map(matchRegex(mkRegex"\\.dsc$"))-- If the pool directory already exists the repository layout is-- Pool.isPool<-doesDirectoryExist(root++"/pool")case(isFlat,isPool)of(True,_)->return(JustFlat)(False,True)->return(JustPool)_->returnNothing