{-# LANGUAGE DoRec, RankNTypes, NamedFieldPuns, RecordWildCards #-}
module Distribution.Server.Features.Upload (
    UploadFeature(..),
    UploadResource(..),
    initUploadFeature,
    UploadResult(..),
  ) where

import Distribution.Server.Framework
import Distribution.Server.Framework.BackupDump

import Distribution.Server.Features.Upload.State
import Distribution.Server.Features.Upload.Backup

import Distribution.Server.Features.Core
import Distribution.Server.Features.Users

import Distribution.Server.Users.Backup
import Distribution.Server.Packages.Types
import qualified Distribution.Server.Users.Types as Users
import qualified Distribution.Server.Users.Group as Group
import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription)
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Packages.Unpack as Upload
import Distribution.Server.Packages.PackageIndex (PackageIndex)
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex

import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Function (fix)
import Data.ByteString.Lazy (ByteString)

import Distribution.Package
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.Text (display)
import qualified Distribution.Server.Util.GZip as GZip


data UploadFeature = UploadFeature {
    uploadFeatureInterface :: HackageFeature,

    uploadResource     :: UploadResource,
    uploadPackage      :: ServerPartE UploadResult,

    --TODO: consider moving the trustee and/or per-package maintainer groups
    --      lower down in the feature hierarchy; many other features want to
    --      use the trustee group purely for auth decisions
    trusteesGroup      :: UserGroup,
    uploadersGroup     :: UserGroup,
    maintainersGroup   :: PackageName -> UserGroup,

    guardAuthorisedAsMaintainer          :: PackageName -> ServerPartE (),
    guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (),

    extractPackage     :: (Users.UserId -> UploadResult -> IO (Maybe ErrorResponse))
                       -> ServerPartE (Users.UserId, UploadResult, PkgTarball)
}

instance IsHackageFeature UploadFeature where
    getFeatureInterface = uploadFeatureInterface

data UploadResource = UploadResource {
    uploadIndexPage :: Resource,
    deletePackagePage  :: Resource,
    maintainersGroupResource :: GroupResource,
    trusteesGroupResource    :: GroupResource,
    uploadersGroupResource   :: GroupResource,
    packageMaintainerUri :: String -> PackageId -> String,
    trusteeUri  :: String -> String,
    uploaderUri :: String -> String
}

data UploadResult = UploadResult {
    uploadDesc :: !GenericPackageDescription,
    uploadCabal :: !ByteString,
    uploadWarnings :: ![String]
}

initUploadFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO UploadFeature
initUploadFeature env@ServerEnv{serverStateDir}
                  core@CoreFeature{..} user@UserFeature{..} = do

    -- Canonical state
    trusteesState    <- trusteesStateComponent    serverStateDir
    uploadersState   <- uploadersStateComponent   serverStateDir
    maintainersState <- maintainersStateComponent serverStateDir

    -- Recusively tie the knot: the feature contains new user group resources
    -- but we make the functions needed to create those resources along with
    -- the feature
    rec let (feature,
             getTrusteesGroup, getUploadersGroup, makeMaintainersGroup)
              = uploadFeature env core user
                              trusteesState    trusteesGroup    trusteesGroupResource
                              uploadersState   uploadersGroup   uploadersGroupResource
                              maintainersState maintainersGroup maintainersGroupResource

        (trusteesGroup,  trusteesGroupResource) <-
          groupResourceAt "/packages/trustees"  (getTrusteesGroup  [adminGroup])

        (uploadersGroup, uploadersGroupResource) <-
          groupResourceAt "/packages/uploaders" (getUploadersGroup [adminGroup])

        pkgNames <- PackageIndex.packageNames <$> queryGetPackageIndex
        (maintainersGroup, maintainersGroupResource) <-
          groupResourcesAt "/package/:package/maintainers"
                           (makeMaintainersGroup [adminGroup, trusteesGroup])
                           (\pkgname -> [("package", display pkgname)])
                           (packageInPath coreResource)
                           pkgNames

    return feature

trusteesStateComponent :: FilePath -> IO (StateComponent AcidState HackageTrustees)
trusteesStateComponent stateDir = do
  st <- openLocalStateFrom (stateDir </> "db" </> "HackageTrustees") initialHackageTrustees
  return StateComponent {
      stateDesc    = "Trustees"
    , stateHandle  = st
    , getState     = query st GetHackageTrustees
    , putState     = update st . ReplaceHackageTrustees . trusteeList
    , backupState  = \(HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees]
    , restoreState = HackageTrustees <$> groupBackup ["trustees.csv"]
    , resetState   = trusteesStateComponent
    }

uploadersStateComponent :: FilePath -> IO (StateComponent AcidState HackageUploaders)
uploadersStateComponent stateDir = do
  st <- openLocalStateFrom (stateDir </> "db" </> "HackageUploaders") initialHackageUploaders
  return StateComponent {
      stateDesc    = "Uploaders"
    , stateHandle  = st
    , getState     = query st GetHackageUploaders
    , putState     = update st . ReplaceHackageUploaders . uploaderList
    , backupState  = \(HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders]
    , restoreState = HackageUploaders <$> groupBackup ["uploaders.csv"]
    , resetState   = uploadersStateComponent
    }

maintainersStateComponent :: FilePath -> IO (StateComponent AcidState PackageMaintainers)
maintainersStateComponent stateDir = do
  st <- openLocalStateFrom (stateDir </> "db" </> "PackageMaintainers") initialPackageMaintainers
  return StateComponent {
      stateDesc    = "Package maintainers"
    , stateHandle  = st
    , getState     = query st AllPackageMaintainers
    , putState     = update st . ReplacePackageMaintainers
    , backupState  = \(PackageMaintainers mains) -> [maintToExport mains]
    , restoreState = maintainerBackup
    , resetState   = maintainersStateComponent
    }

uploadFeature :: ServerEnv
              -> CoreFeature
              -> UserFeature
              -> StateComponent AcidState HackageTrustees    -> UserGroup -> GroupResource
              -> StateComponent AcidState HackageUploaders   -> UserGroup -> GroupResource
              -> StateComponent AcidState PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource
              -> (UploadFeature,
                  [UserGroup] -> UserGroup,
                  [UserGroup] -> UserGroup,
                  [UserGroup] -> PackageName -> UserGroup)

uploadFeature ServerEnv{serverBlobStore = store}
              CoreFeature{ coreResource
                         , queryGetPackageIndex
                         , updateAddPackage
                         }
              UserFeature{..}
              trusteesState    trusteesGroup    trusteesGroupResource
              uploadersState   uploadersGroup   uploadersGroupResource
              maintainersState maintainersGroup maintainersGroupResource
   = ( UploadFeature {..}
     , getTrusteesGroup, getUploadersGroup, makeMaintainersGroup)
   where
    uploadFeatureInterface = (emptyHackageFeature "upload") {
        featureDesc = "Support for package uploads, and define groups for trustees, uploaders, and package maintainers"
      , featureResources =
            [ uploadIndexPage uploadResource
            , groupResource     maintainersGroupResource
            , groupUserResource maintainersGroupResource
            , groupResource     trusteesGroupResource
            , groupUserResource trusteesGroupResource
            , groupResource     uploadersGroupResource
            , groupUserResource uploadersGroupResource
            ]
      , featureState = [
            abstractAcidStateComponent trusteesState
          , abstractAcidStateComponent uploadersState
          , abstractAcidStateComponent maintainersState
          ]
      }

    uploadResource = UploadResource
          { uploadIndexPage      = (extendResource (corePackagesPage coreResource)) { resourcePost = [] }
          , deletePackagePage    = (extendResource (corePackagePage coreResource))  { resourceDelete = [] }
          , maintainersGroupResource = maintainersGroupResource
          , trusteesGroupResource    = trusteesGroupResource
          , uploadersGroupResource   = uploadersGroupResource

          , packageMaintainerUri = \format pkgname -> renderResource
                                     (groupResource maintainersGroupResource) [display pkgname, format]
          , trusteeUri  = \format -> renderResource (groupResource trusteesGroupResource)  [format]
          , uploaderUri = \format -> renderResource (groupResource uploadersGroupResource) [format]
          }

    --------------------------------------------------------------------------------
    -- User groups and authentication
    getTrusteesGroup :: [UserGroup] -> UserGroup
    getTrusteesGroup canModify = fix $ \u -> UserGroup {
        groupDesc = trusteeDescription,
        queryUserList  = queryState  trusteesState   GetTrusteesList,
        addUserList    = updateState trusteesState . AddHackageTrustee,
        removeUserList = updateState trusteesState . RemoveHackageTrustee,
        canAddGroup    = [u] ++ canModify,
        canRemoveGroup = canModify
    }

    getUploadersGroup :: [UserGroup] -> UserGroup
    getUploadersGroup canModify = UserGroup {
        groupDesc      = uploaderDescription,
        queryUserList  = queryState  uploadersState   GetUploadersList,
        addUserList    = updateState uploadersState . AddHackageUploader,
        removeUserList = updateState uploadersState . RemoveHackageUploader,
        canAddGroup    = canModify,
        canRemoveGroup = canModify
    }

    makeMaintainersGroup :: [UserGroup] -> PackageName -> UserGroup
    makeMaintainersGroup canModify name = fix $ \u -> UserGroup {
        groupDesc      = maintainerDescription name,
        queryUserList  = queryState  maintainersState $ GetPackageMaintainers name,
        addUserList    = updateState maintainersState . AddPackageMaintainer name,
        removeUserList = updateState maintainersState . RemovePackageMaintainer name,
        canAddGroup    = [u] ++ canModify,
        canRemoveGroup = [u] ++ canModify
      }

    maintainerDescription :: PackageName -> GroupDescription
    maintainerDescription pkgname = GroupDescription
      { groupTitle = "Maintainers"
      , groupEntity = Just (pname, Just $ "/package/" ++ pname)
      , groupPrologue  = "Maintainers for a package can upload new versions and adjust other attributes in the package database."
      }
      where pname = display pkgname

    trusteeDescription :: GroupDescription
    trusteeDescription = nullDescription { groupTitle = "Package trustees", groupPrologue = "Package trustees are essentially maintainers for the entire package database. They can edit package maintainer groups and upload any package." }

    uploaderDescription :: GroupDescription
    uploaderDescription = nullDescription { groupTitle = "Package uploaders", groupPrologue = "Package uploaders allowed to upload packages. If a package already exists then you also need to be in the maintainer group for that package." }

    guardAuthorisedAsMaintainer :: PackageName -> ServerPartE ()
    guardAuthorisedAsMaintainer pkgname =
      guardAuthorised_ [InGroup (maintainersGroup pkgname)]

    guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE ()
    guardAuthorisedAsMaintainerOrTrustee pkgname =
      guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup]


    ----------------------------------------------------

    -- This is the upload function. It returns a generic result for multiple formats.
    uploadPackage :: ServerPartE UploadResult
    uploadPackage = do
        guardAuthorised_ [InGroup uploadersGroup]
        pkgIndex <- queryGetPackageIndex
        (uid, uresult, tarball) <- extractPackage $ \uid info ->
                                     processUpload pkgIndex uid info
        now <- liftIO getCurrentTime
        let (UploadResult pkg pkgStr _) = uresult
            pkgid      = packageId pkg
            cabalfile  = CabalFileText pkgStr
            uploadinfo = (now, uid)
        success <- updateAddPackage pkgid cabalfile uploadinfo (Just tarball)
        if success
          then do
             -- make package maintainers group for new package
            let existedBefore = packageExists pkgIndex pkgid
            when (not existedBefore) $
                liftIO $ addUserList (maintainersGroup (packageName pkgid)) uid
            return uresult
          -- this is already checked in processUpload, and race conditions are highly unlikely but imaginable
          else errForbidden "Upload failed" [MText "Package already exists."]

    -- This is a processing funtion for extractPackage that checks upload-specific requirements.
    -- Does authentication, though not with requirePackageAuth, because it has to be IO.
    -- Some other checks can be added, e.g. if a package with a later version exists
    processUpload :: PackageIndex PkgInfo -> Users.UserId -> UploadResult -> IO (Maybe ErrorResponse)
    processUpload state uid res = do
        let pkg = packageId (uploadDesc res)
        pkgGroup <- queryUserList (maintainersGroup (packageName pkg))
        if packageIdExists state pkg
          then uploadError versionExists --allow trustees to do this?
          else if packageExists state pkg && not (uid `Group.member` pkgGroup)
                 then uploadError (notMaintainer pkg)
                 else return Nothing
      where
        uploadError = return . Just . ErrorResponse 403 [] "Upload failed" . return . MText
        versionExists = "This version of the package has already been uploaded.\n\nAs a matter of "
                     ++ "policy we do not allow package tarballs to be changed after a release "
                     ++ "(so we can guarantee stable md5sums etc). The usual recommendation is "
                     ++ "to upload a new version, and if necessary blacklist the existing one. "
                     ++ "In extraordinary circumstances, contact the administrators."
        notMaintainer pkg = "You are not authorised to upload new versions of this package. The "
                     ++ "package '" ++ display (packageName pkg) ++ "' exists already and you "
                     ++ "are not a member of the maintainer group for this package.\n\n"
                     ++ "If you believe you should be a member of the maintainer group for this "
                     ++ "package, then ask an existing maintainer to add you to the group. If "
                     ++ "this is a package name clash, please pick another name or talk to the "
                     ++ "maintainers of the existing package."

    -- This function generically extracts a package, useful for uploading, checking,
    -- and anything else in the standard user-upload pipeline.
    extractPackage :: (Users.UserId -> UploadResult -> IO (Maybe ErrorResponse))
                   -> ServerPartE (Users.UserId, UploadResult, PkgTarball)
    extractPackage processFunc =
        withDataFn (lookInput "package") $ \input ->
            case inputValue input of -- HS6 this has been updated to use the new file upload support in HS6, but has not been tested at all
              (Right _) -> errBadRequest "Upload failed" [MText "package field in form data is not a file."]
              (Left file) ->
                  let fileName    = (fromMaybe "noname" $ inputFilename input)
                  in upload fileName file
      where
        upload name file =
         do -- initial check to ensure logged in.
            --FIXME: this should have been covered earlier
            uid <- guardAuthenticated
            let processPackage :: ByteString -> IO (Either ErrorResponse (UploadResult, BlobStorage.BlobId))
                processPackage content' = do
                    -- as much as it would be nice to do requirePackageAuth in here,
                    -- processPackage is run in a handle bracket
                    case Upload.unpackPackage name content' of
                      Left err -> return . Left $ ErrorResponse 400 [] "Invalid package" [MText err]
                      Right ((pkg, pkgStr), warnings) -> do
                        let uresult = UploadResult pkg pkgStr warnings
                        res <- processFunc uid uresult
                        case res of
                            Nothing ->
                                do let decompressedContent = GZip.decompressNamed file content'
                                   blobIdDecompressed <- BlobStorage.add store decompressedContent
                                   return . Right $ (uresult, blobIdDecompressed)
                            Just err -> return . Left $ err
            mres <- liftIO $ BlobStorage.consumeFileWith store file processPackage
            case mres of
                Left  err -> throwError err
                Right ((res, blobIdDecompressed), blobId) ->
                    return (uid, res, tarball)
                  where
                    tarball = PkgTarball { pkgTarballGz   = blobId,
                                           pkgTarballNoGz = blobIdDecompressed }