-- CGI program to put a Cabal package into the package archive

module Main (main) where

import Control.Monad		( when )
import Data.Char		( toLower )
import Data.Version		( showVersion )
import Distribution.PackageDescription
				( GenericPackageDescription(..),
				  package, hasLibs )
import Distribution.PackageDescription.Configuration
				( flattenPackageDescription )
import Distribution.Package	( PackageIdentifier(..) )
import Distribution.Text	( display )
import Network.CGI		( runCGI, handleErrors,
				  getVarWithDefault, getInputFilename,
				  getInputFPS, outputError, liftIO, output,
				  setHeader )
import System.Cmd		( rawSystem )
import System.Directory		( doesFileExist )
import System.FilePath		( (</>) )
import System.Time		( getClockTime, toUTCTime,
				  calendarTimeToString )
import Text.XHtml		( Html, renderHtml, (<<), h2, paragraph,
				  ulist, li )

import PublicFile
import Locations		( archiveDir, postUploadHook )
import HackagePage		( hackagePage )
import Unpack			( unpackPackage )
import Util
import TagMap			( storeTagMap, noTags, setTag )

logFile :: FilePath
logFile = localFile archiveDir </> "log"

main :: IO ()
main = runCGI $ handleErrors $ do
	-- package field is a filename, of the form <package>-<version>.tar.gz
	mb_tarFile <- getInputFilename "package"
	mb_contents <- getInputFPS "package"
	user <- getVarWithDefault "REMOTE_USER" "unknown"
	case (mb_tarFile, mb_contents) of
	    (Just tarFile, Just contents) -> do
		res <- liftIO $ unpackPackage (basename tarFile) contents True
		case res of
		    Left err -> do
			outputError 400 "Error in upload" [err]
		    Right (pkg, warnings) -> do
			liftIO $ updatePackage user pkg
			-- If the caller accepts only text/plain (e.g. the
			-- command-line client), only send the warnings.
			accept <- getVarWithDefault "HTTP_ACCEPT" "text/html"
			if map toLower accept == "text/plain"
			    then do
				setHeader "Content-type" "text/plain"
				output (unlines warnings)
			    else
				output $ renderHtml $ packagePage pkg warnings
	    _ -> outputError 400 "malformed URL" []

updatePackage :: String -> GenericPackageDescription -> IO ()
updatePackage user pkg = do
	let pkgId = package (packageDescription pkg)

	-- Add a line to the logfile <archiveDir>/log
	now <- getClockTime
	let date_string = calendarTimeToString (toUTCTime now)
	appendFile logFile $
		date_string ++ " " ++
		user ++ " " ++ display (pkgName pkgId) ++ " " ++
		showVersion (pkgVersion pkgId) ++ "\n"

	-- Record upload information in the tags file
	storeTagMap pkgId $
		setTag "uploaded by" user $
		setTag "upload date" date_string $
		noTags

	-- Call hook to regenerate indices
	postUploadHookExists <- doesFileExist postUploadHook
	when postUploadHookExists $ do
		rawSystem postUploadHook []
		return ()

packagePage :: GenericPackageDescription -> [String] -> Html
packagePage pkg warnings = hackagePage "package added" $
	[paragraph << (
		"Package " ++ display pkgId ++ " added to the database." ++
		if hasLibs (flattenPackageDescription pkg)
		then " Library documentation will not appear immediately; it is generated by a later batch process."
		else "")] ++
	if null warnings then [] else
	[h2 << "Warnings", ulist << map (li <<) warnings]
  where pkgId = package (packageDescription pkg)