module Debian.Repo.Package
    ( -- * Source and binary packages 
      sourceFilePaths
    , binaryPackageSourceVersion
    , binarySourceVersion
    , sourcePackageBinaryNames
    , sourceBinaryNames
    , toSourcePackage
    , toBinaryPackage
    , binaryPackageSourceID
    , sourcePackageBinaryIDs
    , sourcePackagesOfIndex
    , sourcePackagesOfIndex'
    , binaryPackagesOfIndex
    , binaryPackagesOfIndex'
    , getPackages
    , putPackages
    , releaseSourcePackages
    , releaseBinaryPackages
    -- * Deprecated stuff for interfacing with Debian.Relation
    ) where

import Debian.Apt.Index (Compression(..), controlFromIndex)
import Debian.Control
import Debian.Repo.PackageIndex
import qualified Debian.Control.ByteString as B
import qualified Debian.Relation.ByteString as B
import Debian.Repo.IO
import Debian.Shell
import Debian.Repo.Types
import Debian.URI
import Debian.Version

import Control.Exception (Exception(..))
import Control.Monad.Trans
import Control.Monad.State (get, put)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as B
import Data.List
import Data.Maybe
import qualified Extra.Either as EE
import qualified Extra.Files as EF
import Extra.CIO (CIO(..), vEPutStrBl)
import System.Directory
import System.FilePath((</>))
import System.IO.Unsafe
import System.Posix
import System.Unix.Process
import Text.Regex

sourceFilePaths :: SourcePackage -> [FilePath]
sourceFilePaths package =
    map ((sourceDirectory package) </>) . map sourceFileName . sourcePackageFiles $ package

-- | Return the name and version number of the source package that
-- generated this binary package.  
binaryPackageSourceVersion :: BinaryPackage -> Maybe (String, DebianVersion)
binaryPackageSourceVersion package =
    let binaryName = packageName . packageID $ package
        binaryVersion = packageVersion . packageID $ package in
    binarySourceVersion' binaryName binaryVersion (packageInfo package)

-- |Return the name and version number of the source package that
-- generated this binary package.
-- see also: 'binaryPackageSourceVersion'
binarySourceVersion :: B.Paragraph -> Maybe ((String, DebianVersion), (String, DebianVersion))
binarySourceVersion paragraph =
    let mBinaryName = fmap B.unpack $ fieldValue "Package" paragraph
        mBinaryVersion = fmap (parseDebianVersion . B.unpack) $ fieldValue "Version" paragraph
    in
      case (mBinaryName, mBinaryVersion) of
        (Just binaryName, Just binaryVersion) ->
            fmap ((,) (binaryName, binaryVersion)) $ binarySourceVersion' binaryName binaryVersion paragraph
        _ -> Nothing

binarySourceVersion' :: (ControlFunctions a) => String -> DebianVersion -> Paragraph' a -> Maybe (String, DebianVersion)
binarySourceVersion' binaryName binaryVersion paragraph =
    case (B.fieldValue "Source" paragraph) of
      Just source ->
          case matchRegex re (asString source) of
            Just [name, _, ""] -> Just (name, binaryVersion)
            Just [name, _, version] -> Just (name, parseDebianVersion version)
            _ -> error "internal error"
      Nothing ->
          Just (asString binaryName, binaryVersion)
    where
      re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$"

sourcePackageBinaryNames :: SourcePackage -> [String]
sourcePackageBinaryNames package =
    sourceBinaryNames (sourceParagraph package)

sourceBinaryNames :: B.Paragraph -> [String]
sourceBinaryNames paragraph = 
    case B.fieldValue "Binary" paragraph of
      Just names -> splitRegex (mkRegex "[ ,]+") (B.unpack names)
      _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ paragraph))

toSourcePackage :: PackageIndex -> B.Paragraph -> SourcePackage
toSourcePackage index package =
    case (B.fieldValue "Directory" package,
          B.fieldValue "Files" package,
          B.fieldValue "Package" package,
          maybe Nothing (Just . parseDebianVersion . B.unpack) (B.fieldValue "Version" package)) of
      (Just directory, Just files, Just name, Just version) ->
          case parseSourcesFileList files of
            Right files ->
                SourcePackage
                { sourcePackageID =
                      PackageID
                      { packageIndex = index
                      , packageName = B.unpack name
                      , packageVersion = version }
                , sourceParagraph = package
                , sourceDirectory = B.unpack directory
                , sourcePackageFiles = files }
            Left messages -> error $ "Invalid file list: " ++ show messages
      _ -> error $ "Missing info in source package control information:\n" ++ B.unpack (formatParagraph package)
    where      
      -- Parse the list of files in a paragraph of a Sources index.
      parseSourcesFileList :: B.ByteString -> Either [String] [SourceFileSpec]
      parseSourcesFileList text =
          merge . catMaybes . map parseSourcesFiles . lines . B.unpack $ text
      parseSourcesFiles line =
          case words line of
            [md5sum, size, name] -> Just (Right (SourceFileSpec md5sum (read size) name))
            [] -> Nothing
            _ -> Just (Left ("Invalid line in Files list: '" ++ show line ++ "'"))
      merge x = case partition (either (const True) (const False)) x of
                  (a, []) -> Left . catMaybes . map (either Just (const Nothing )) $ a
                  (_, a) -> Right . catMaybes . map (either (const Nothing) Just) $ a

toBinaryPackage :: PackageIndex -> B.Paragraph -> BinaryPackage
toBinaryPackage index p =
    case (B.fieldValue "Package" p, B.fieldValue "Version" p) of
      (Just name, Just version) ->
          BinaryPackage 
          { packageID = PackageID { packageIndex = index
                                  , packageName = B.unpack name
                                  , packageVersion = parseDebianVersion (B.unpack version) }
          , packageInfo = p
          , pDepends = tryParseRel $ B.lookupP "Depends" p
          , pPreDepends = tryParseRel $ B.lookupP "Pre-Depends" p
          , pConflicts = tryParseRel $ B.lookupP "Conflicts" p
          , pReplaces =  tryParseRel $ B.lookupP "Replaces" p
          , pProvides =  tryParseRel $ B.lookupP "Provides" p
          }
      _ -> error ("Invalid data in source index:\n " ++ packageIndexPath index)

tryParseRel :: Maybe B.Field -> B.Relations
tryParseRel (Just (B.Field (_, relStr))) = either (error . show) id (B.parseRelations relStr)
tryParseRel _ = []

-- | Parse the /Source/ field of a binary package's control
-- information, this may specify a version number for the source
-- package if it differs from the version number of the binary
-- package.
binaryPackageSourceID :: BinaryPackage -> PackageID
binaryPackageSourceID package =
    case maybe Nothing (matchRegex re . B.unpack) (B.fieldValue "Source" (packageInfo package)) of
      Just [name, _, ""] -> PackageID { packageIndex = sourceIndex
                                      , packageName = name
                                      , packageVersion = packageVersion id }
      Just [name, _, version] -> PackageID { packageIndex = sourceIndex
                                           , packageName = name
                                           , packageVersion = parseDebianVersion version }
      _ -> error "Missing Source attribute in binary package info"
    where
      sourceIndex = PackageIndex release component Source
      (PackageIndex release component _) = packageIndex id
      id = packageID package
      re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$"

sourcePackageBinaryIDs :: Arch -> SourcePackage -> [PackageID]
sourcePackageBinaryIDs Source _ = error "invalid argument"
sourcePackageBinaryIDs arch package =
    case (B.fieldValue "Version" info, B.fieldValue "Binary" info) of
      (Just version, Just names) -> map (binaryID (parseDebianVersion (B.unpack version))) $ splitRegex (mkRegex "[ ,]+") (B.unpack names)
      _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ info))
    where
      -- Note that this version number may be wrong - we need to
      -- look at the Source field of the binary package info.
      binaryID version name = PackageID { packageIndex = binaryIndex
                                        , packageName = name
                                        , packageVersion = version }
      sourceIndex = packageIndex (sourcePackageID package)
      binaryIndex = sourceIndex { packageIndexArch = arch }
      info = sourceParagraph package

-- | Get the contents of a package index
getPackages :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage])
getPackages index =
    liftIO (fileFromURI (uri {uriPath = uriPath uri </> packageIndexPath index ++ ".gz"})) >>=
    return . either Left (\ s -> case controlFromIndex GZ (show uri) s of
                                   Left e -> Left (ErrorCall (show e))
                                   Right (B.Control control) -> Right $ map (toBinaryPackage index) control)
    where
      uri = repoURI repo
      release = packageIndexRelease index
      repo = releaseRepo release

-- | Get the contents of a package index
binaryPackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage])
binaryPackagesOfIndex index =
    case packageIndexArch index of
      Source -> return (Right [])
      _ -> getPackages index -- >>= return . either Left (Right . map (toBinaryPackage index . packageInfo))

-- | Get the contents of a package index
sourcePackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [SourcePackage])
sourcePackagesOfIndex index =
    case packageIndexArch index of
      Source -> getPackages index >>= return . either Left (Right . map (toSourcePackage index . packageInfo))
      _ -> return (Right [])

-- FIXME: assuming the index is part of the cache 
sourcePackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [SourcePackage]
sourcePackagesOfIndex' cache index =
    do state <- get
       let cached = lookupSourcePackages path state
       status <- liftIO $ getFileStatus path
       case cached of
         Just (status', packages) | status == status' -> return packages
         _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path)
                 let packages = map (toSourcePackage index) paragraphs 
                 put (insertSourcePackages path (status, packages) state)
                 return packages
    where
      path = rootPath (rootDir cache) ++ indexCacheFile cache index

indexCacheFile :: (AptCache a) => a -> PackageIndex -> FilePath
indexCacheFile apt index =
    case (aptArch apt, packageIndexArch index) of
      (Source, _) -> error "Invalid build architecture: Source"
      (Binary _, Source) -> indexPrefix index ++ "_source_Sources"
      (Binary _, Binary arch) -> indexPrefix index ++ "_binary-" ++ arch ++ "_Packages"

indexPrefix :: PackageIndex -> FilePath
indexPrefix index =
    (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") ++
     releaseName' distro ++ "_" ++ (sectionName' $ section))
    where
      release = packageIndexRelease index
      section = packageIndexComponent index
      repo = releaseRepo release
      uri = repoURI repo
      distro = releaseInfoName . releaseInfo $ release
      scheme = uriScheme uri
      auth = uriAuthority uri
      path = uriPath uri
      userpass = maybe "" uriUserInfo auth
      reg = maybeOfString $ maybe "" uriRegName auth
      port = maybe "" uriPort auth
      (user, pass) = break (== ':') userpass
      user' = maybeOfString user
      pass' = maybeOfString pass
      uriText = prefix scheme user' pass' reg port path
      -- If user is given and password is not, the user name is
      -- added to the file name.  Otherwise it is not.  Really.
      prefix "http:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "http:" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix "ftp:" _ _ (Just host) _ path =
          host ++ escape path
      prefix "file:" Nothing Nothing Nothing "" path =
          escape path
      prefix "ssh:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "ssh" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix _ _ _ _ _ _ = error ("invalid repo URI: " ++ (uriToString' . repoURI. releaseRepo . packageIndexRelease $ index))
      maybeOfString "" = Nothing
      maybeOfString s = Just s
      escape s = intercalate "_" (wordsBy (== '/') s)
      wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]
      wordsBy p s = 
          case (break p s) of
            (s, []) -> [s]
            (h, t) -> h : wordsBy p (drop 1 t)

(+?+) :: String -> String -> String
(+?+) a ('_' : b) = a +?+ b
(+?+) "" b = b
(+?+) a b =
    case last a of
      '_' -> (init a) +?+ b
      _ -> a ++ "_" ++ b

-- FIXME: assuming the index is part of the cache 
binaryPackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [BinaryPackage]
binaryPackagesOfIndex' cache index =
    do state <- get
       let cached = lookupBinaryPackages path state
       status <- liftIO $ getFileStatus path
       case cached of
         Just (status', packages) | status == status' -> return packages
         _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path)
                 let packages = map (toBinaryPackage index) paragraphs 
                 put (insertBinaryPackages path (status, packages) state)
                 return packages
    where
      path = rootPath (rootDir cache) ++ indexCacheFile cache index

-- | Return a list of all source packages.
releaseSourcePackages :: CIO m => Release -> m (Either Exception [SourcePackage])
releaseSourcePackages release =
    mapM sourcePackagesOfIndex (sourceIndexList release) >>= return . test
    where
      test xs = case EE.partitionEithers xs of
                  ([], ok) -> Right (concat ok)
                  (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad)

-- | Return a list of all the binary packages for all supported architectures.
releaseBinaryPackages :: CIO m => Release -> m (Either Exception [BinaryPackage])
releaseBinaryPackages release =
    mapM binaryPackagesOfIndex (binaryIndexList release) >>= return . test
    where
      test xs = case EE.partitionEithers xs of
                  ([], ok) -> Right (concat ok)
                  (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad)

-- | Write a set of packages into a package index.
putPackages :: PackageIndexLocal ->  [BinaryPackageLocal] -> IO (Either [String] ())
putPackages index packages =
    case releaseRepo release of
      LocalRepo repo -> EF.writeAndZipFileWithBackup (outsidePath (repoRoot repo) </> packageIndexPath index) text
      x -> error $ "Package.putPackages: Expected local repository, found " ++ show x
    where
      release = packageIndexRelease index
      --repo = releaseRepo release
      text = L.fromChunks [B.concat (intersperse (B.pack "\n") . map formatParagraph . map packageInfo $ packages)]