Repository.hs

{-# LANGUAGE ScopedTypeVariables #-}
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	-- required despite warning
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

-- |The file produced by dupload when a package upload attempt is made.
data UploadFile = Upload FilePath String DebianVersion Arch

-- |This is a remote repository which we have queried to find out the
-- names, sections, and supported architectures of its releases.
--data VerifiedRepo = VerifiedRepo URI [ReleaseInfo]

{- instance Show VerifiedRepo where
    show (VerifiedRepo uri _) = "Verified Repository " ++ show uri -- ++ " " ++ show dists
instance Ord VerifiedRepo where
    compare a b = compare (repoURI a) (repoURI b)
instance Eq VerifiedRepo where
    a == b = compare a b == EQ -}

-- |This is a repository whose structure we haven't examined 
-- to determine what release it contains.
--data UnverifiedRepo = UnverifiedRepo URI

{- instance Show UnverifiedRepo where
    show (UnverifiedRepo uri) = "Unverified Repository " ++ show uri -- ++ " (unverified)"
instance Ord UnverifiedRepo where
    compare a b = compare (repoURI a) (repoURI b)
instance Eq UnverifiedRepo where
    a == b = compare a b == EQ -}

-- | Prepare a repository, which may be remote or local depending on
-- the URI.
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
               -- FIXME: We only want to verifyRepository on demand.
               -- Perhaps we want to use System.IO.Unsafe.unsafeInterleaveIO?
               _ -> verifyRepository (UnverifiedRepo (show uri))
               -- _ -> return . Repository . UnverifiedRepo $ uri

{-# NOINLINE verifyRepository #-}
verifyRepository :: CIO m => Repository -> AptIOT m Repository
verifyRepository (UnverifiedRepo uri) =
    do --tio (vHPutStrBl IO.stderr 0 $ "Verifying repository " ++ show uri ++ "...")
       -- Use unsafeInterleaveIO to avoid querying the repository
       -- until the value is actually needed.
       lift (vPutStrBl 2 ("verifyRepository " ++ uri))
       releaseInfo <- do lift (vPutChar 2 '*')
                         liftIO . unsafeInterleaveIO . getReleaseInfoRemote . fromJust . parseURI $ uri
       {- tio (vHPutStrLn IO.stderr 0 $ "\n" {- -> VerifiedRepo " ++ show uri ++ " " ++ show releaseInfo -} ) -}
       return $ VerifiedRepo uri releaseInfo
verifyRepository x = return x

-- |Get the list of releases of a remote repository.
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 dist " ++ show (relName distName) ++ ", uri " ++ 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

-- |Make sure we can access the upload uri without typing a password.
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

-- | Upload all the packages in a local repository to a the incoming
-- directory of a remote repository (using dupload.)
uploadRemote :: CIO m
	     => LocalRepository		-- ^ Local repository holding the packages.
             -> URI			-- ^ URI of upload repository
             -> 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)

{-
base :: UploadFile -> String
base (Upload _ name ver arch) = name ++ "_" ++ show ver ++ "_" ++ show arch
-}

-- 		       filename     name   version   arch    ext
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"

-- | Parse the "Revision:" value describing the origin of the
-- package's source and the dependency versions used to build it:
--   Revision: <revisionstring> dep1=ver1 dep2=ver2 ...
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))

-- |Run dupload on a changes file with an optional host (--to)
-- argument.
dupload :: CIO m
	=> URI		-- user
        -> FilePath	-- The directory containing the .changes file
        -> String	-- The name of the .changes file to upload
        -> 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))
            --style' $ runCommandQuietlyTimed (cmd changesFile)
    where
{-
      style' = setStyle (setStart (Just ("Uploading " ++ show changesFile)) .
                         setError (Just "dupload failed") .
                         setEcho True)
-}
      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))