module Debian.Repo.Repository
( UploadFile(..)
, prepareRepository
, repoArchList
, readPkgVersion
, showPkgVersion
, invalidRevision
, verifyUploadURI
, uploadRemote
) where
import Control.Exception (Exception(..))
import Control.Monad.Trans
import Control.Monad.State (get, put)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import qualified Debian.Control.ByteString as B
import qualified Debian.Control.String as S
import Debian.Extra.CIO (tMessage, printOutput)
import Debian.Repo.Changes
import Debian.Repo.IO
import Debian.Repo.LocalRepository
import Debian.Repo.Types
import Debian.Shell
import Debian.URI
import Debian.Version
import Extra.Bool
import Extra.Either
import Extra.Files
import Extra.List
import Extra.Net
import Extra.SSH
import Extra.CIO
import System.FilePath
import System.Unix.Process
import System.Cmd
import System.Directory
import qualified System.IO as IO
import System.IO.Unsafe
import System.Time
import Text.Regex
data UploadFile = Upload FilePath String DebianVersion Arch
prepareRepository :: CIO m => URI -> AptIOT m Repository
prepareRepository uri =
do state <- get
repo <- maybe newRepo return (lookupRepository uri state)
put (insertRepository uri repo state)
return repo
where
newRepo =
case uriScheme uri of
"file:" -> prepareLocalRepository (EnvPath (EnvRoot "") (uriPath uri)) Nothing >>= return . LocalRepo
_ -> verifyRepository (UnverifiedRepo (show uri))
verifyRepository :: CIO m => Repository -> AptIOT m Repository
verifyRepository (UnverifiedRepo uri) =
do
lift (vPutStrBl 2 ("verifyRepository " ++ uri))
releaseInfo <- do lift (vPutChar 2 '*')
liftIO . unsafeInterleaveIO . getReleaseInfoRemote . fromJust . parseURI $ uri
return $ VerifiedRepo uri releaseInfo
verifyRepository x = return x
getReleaseInfoRemote :: URI -> IO [ReleaseInfo]
getReleaseInfoRemote uri =
IO.hPutStr IO.stderr ("(verifying " ++ uriToString' uri ++ ".") >>
dirFromURI distsURI >>=
either (error . show) verify >>= return . catMaybes >>=
(\ result -> IO.hPutStr IO.stderr ")" >> return result)
where
distsURI = uri {uriPath = uriPath uri </> "dists/"}
verify names =
do let dists = map parseReleaseName names
releaseFiles <- mapM getReleaseFile dists
let releasePairs = zip3 (map getSuite releaseFiles) releaseFiles dists
return $ map (uncurry3 getReleaseInfo) releasePairs
releaseNameField releaseFile = case fmap B.unpack (B.fieldValue "Origin" releaseFile) of Just "Debian" -> "Codename"; _ -> "Suite"
getReleaseInfo :: Maybe B.ByteString -> B.Paragraph -> ReleaseName -> Maybe ReleaseInfo
getReleaseInfo Nothing _ _ = Nothing
getReleaseInfo (Just dist) _ relname | (parseReleaseName (B.unpack dist)) /= relname = Nothing
getReleaseInfo (Just dist) info _ = Just $ makeReleaseInfo "" info (parseReleaseName (B.unpack dist)) []
getSuite releaseFile = B.fieldValue (releaseNameField releaseFile) releaseFile
getReleaseFile :: ReleaseName -> IO (S.Paragraph' B.ByteString)
getReleaseFile distName =
do IO.hPutChar IO.stderr '.'
release <- fileFromURI releaseURI >>= return . either Left (Right . B.concat . L.toChunks)
let control = either Left (either (Left . ErrorCall . show) Right . B.parseControl (show uri)) release
case control of
Right (B.Control [info]) -> return info
_ -> error ("Failed to get release info from " ++ show releaseURI)
where
releaseURI = distURI {uriPath = uriPath distURI </> "Release"}
distURI = distsURI {uriPath = uriPath distsURI </> releaseName' distName}
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
verifyUploadURI :: CIO m => Bool -> URI -> AptIOT m ()
verifyUploadURI doExport uri =
case doExport of
True -> export
False -> verify
where
export =
do liftIO $ uncurry sshExport (uriDest uri)
verify
mkdir
verify =
do result <- liftIO $ uncurry sshVerify (uriDest uri)
case result of
False -> error $ "Unable to reach " ++ uriToString' uri ++ ", consider using --ssh-export"
True -> return ()
mkdir
uriDest uri =
let auth = maybe (error "Internal error 8") id (uriAuthority uri) in
let port =
case uriPort auth of
(':' : number) -> Just (read number)
"" -> Nothing
x -> error $ "Internal error 9: invalid port " ++ x in
(uriUserInfo auth ++ uriRegName auth, port)
mkdir :: CIO m => AptIOT m ()
mkdir =
case uriAuthority uri of
Nothing -> error $ "Internal error 7"
Just auth ->
do let cmd = "ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " mkdir -p " ++ uriPath uri ++ "/incoming"
result <- liftIO $ system cmd
case result of
ExitSuccess -> return ()
_ -> error $ "Failure: " ++ cmd
uploadRemote :: CIO m
=> LocalRepository
-> URI
-> AptIOT m [Either String ([Output], TimeDiff)]
uploadRemote repo uri =
do uploaded <- liftIO (uploadFind (outsidePath root)) >>=
return . Set.fromList . map uploadKey . rightOnly
(accepted, rejected) <- liftIO (findChangesFiles (outsidePath root)) >>= return . (\x -> (x, [])) >>=
return . accept (notUploaded uploaded) (\ x -> (x, "Already uploaded")) >>=
return . rejectOlder >>=
acceptM (liftIO . validRevision) (\ x -> (x, "Invalid revision"))
case rejected of
[] -> return ()
_ -> lift (vPutStr 0 ("Rejected:\n " ++ consperse "\n " (map showReject rejected) ++ "\n"))
case accepted of
[] -> do lift (vPutStr 0 "Nothing to upload."); return []
_ -> do mapM (lift . dupload uri (outsidePath root)) (map Debian.Repo.Changes.path accepted)
where
root = repoRoot repo
rejectOlder :: ([ChangesFile], [(ChangesFile, String)]) -> ([ChangesFile], [(ChangesFile, String)])
rejectOlder (accept, reject) =
(accept', (map tag reject' ++ reject))
where accept' = map head sortedGroups
reject' = concat . map tail $ sortedGroups
sortedGroups = map (sortBy compareVersions) (groupByNameAndDist accept)
tag x = (x, "Not the newest version in incoming")
compareVersions a b = compare (changeVersion b) (changeVersion a)
groupByNameAndDist = groupBy equalNameAndDist . sortBy compareNameAndDist
equalNameAndDist a b = compareNameAndDist a b == EQ
compareNameAndDist a b =
case compare (changePackage a) (changePackage b) of
EQ -> compare (changeRelease a) (changeRelease b)
x -> x
notUploaded uploaded changes = not . Set.member (Debian.Repo.Changes.key changes) $ uploaded
validRevision c =
do
let dscPath = changeDir c </> changePackage c ++ "_" ++ show (changeVersion c) ++ ".dsc"
doesFileExist dscPath >>= cond (S.parseControlFromFile dscPath >>= either (error . show) (checkRevision dscPath)) (return True)
where
checkRevision _dscPath (S.Control [p]) =
case maybe Nothing parseRevision (S.fieldValue "Revision" p) of
Nothing -> return False
Just (x, _) | x == invalidRevision -> return False
Just _ -> return True
checkRevision dscPath _ = error ("Invalid .dsc file: " ++ show dscPath)
showReject (changes, tag) = Debian.Repo.Changes.name changes ++ ": " ++ tag
uploadKey :: UploadFile -> (String, DebianVersion, Arch)
uploadKey (Upload _ name ver arch) = (name, ver, arch)
uploadLoad :: FilePath -> String -> (Either [String] UploadFile)
uploadLoad dir file =
case parseUploadFilename file of
Just (name, ver, arch) -> Right $ Upload dir name ver arch
Nothing -> Left ["Couldn't parse upload filename: " ++ file]
uploadFind :: FilePath -> IO [Either [String] UploadFile]
uploadFind dir =
getDirectoryContents dir >>=
return . filter (isSuffixOf ".upload") >>=
return . map (uploadLoad dir)
parseUploadFilename :: String -> Maybe (String, DebianVersion, Arch)
parseUploadFilename name =
case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.upload$") name of
Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch)
_ -> error ("Invalid .upload file name: " ++ name)
invalidRevision = "none"
parseRevision :: String -> Maybe (String, [PkgVersion])
parseRevision s =
case words s of
[] -> Nothing
(revision : buildDeps) -> Just (revision, map readPkgVersion buildDeps)
showPkgVersion :: PkgVersion -> String
showPkgVersion v = show v
readPkgVersion :: String -> PkgVersion
readPkgVersion s = case mapSnd (parseDebianVersion . (drop 1)) (span (/= '=') s) of
(n, v) -> PkgVersion { getName = n, getVersion = v }
mapSnd f (a, b) = (a, f b)
accept :: (a -> Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> ([a], [(a, String)])
accept p tag (accepted, rejected) =
(accepted', map tag rejected' ++ rejected)
where (accepted', rejected') = partition p accepted
acceptM :: (Monad m) => (a -> m Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> m ([a], [(a, String)])
acceptM p tag (accept, reject) =
do (accept', reject') <- partitionM p accept
return (accept', (map tag reject' ++ reject))
dupload :: CIO m
=> URI
-> FilePath
-> String
-> m (Either String ([Output], TimeDiff))
dupload uri dir changesFile =
case uriAuthority uri of
Nothing -> error ("Invalid Upload-URI: " ++ uriToString' uri)
Just auth ->
do
let config = ("package config;\n" ++
"$cfg{'default'} = {\n" ++
" fqdn => \"" ++ uriRegName auth ++ uriPort auth ++ "\",\n" ++
" method => \"scpb\",\n" ++
" login => \"" ++ init (uriUserInfo auth) ++ "\",\n" ++
" incoming => \"" ++ uriPath uri ++ "/incoming\",\n" ++
" dinstall_runs => 1,\n" ++
"};\n\n" ++
"$preupload{'changes'} = '';\n\n" ++
"1;\n")
liftIO $ replaceFile (dir ++ "/dupload.conf") config
liftIO (lazyCommand (cmd changesFile) L.empty) >>=
tMessage ("Uploading " ++ show changesFile) >>=
printOutput >>=
dotOutput 128 >>=
(\ output -> timeTask (checkResult fail (return (Right output)) output)) >>=
(\ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result))
where
fail n =
ePutStrBl message >> return (Left message)
where message = "dupload failed: " ++ cmd changesFile ++ " -> " ++ show n
cmd file = "cd " ++ dir ++ " && dupload --to default -c " ++ file
repoArchList :: Repo r => r -> [Arch]
repoArchList repo =
listIntersection (map releaseInfoArchitectures (repoReleaseInfo repo))