{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE PatternGuards #-}
module Distribution.Server.Pages.PackageFromTemplate
  ( packagePageTemplate
  , candidatesPageTemplate
  , renderVersion
  , latestVersion
  , commaList
  ) where

import Distribution.Server.Framework.Templating
import Distribution.Server.Features.PreferredVersions
import Distribution.Server.Features.Core

import Distribution.Server.Util.DocMeta
import Distribution.Server.Packages.Render
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import Distribution.Server.Packages.PackageIndex (PackageIndex)
import Distribution.Server.Packages.Types
import Distribution.Server.Features.PackageCandidates
import Distribution.Server.Users.Types (UserInfo, userStatus, userName, isActiveAccount)
import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown)
import Data.TarIndex (TarIndex)
import Distribution.Server.Features.Distro.Types

import Distribution.Package
import Distribution.PackageDescription as P
import Distribution.Version
import Distribution.Text        (display)
import Distribution.Utils.ShortText (fromShortText)
import qualified Distribution.Utils.ShortText as Short
import Text.XHtml.Strict hiding (p, name, title, content)
import qualified Text.XHtml.Strict as XHtml

import Data.Maybe               (maybeToList, fromMaybe, isJust)
import Data.List                (intercalate, intersperse)
import System.FilePath.Posix    ((</>), takeFileName, dropTrailingPathSeparator)
import Data.Time.Format         (defaultTimeLocale, formatTime)

import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.ByteString.Lazy as BS (ByteString, toStrict)

import qualified Distribution.Server.Pages.Package as Old
import Data.Time.Clock (UTCTime)

import Distribution.Server.Features.Html.HtmlUtilities

-- | Populates template variables for the package page.
-- | There are 4 main namespaces provided for templating:
--
-- | 1) Top Level
--      ($varName$)
--    Most of these variables are specific to Hackage, including variables that
--    need to be populated using IO or HTML that is generated by other features.
--    This includes things like download counts and build status.
--    (These could be moved to the "hackage" prefix if it's convenient.)
--
-- | 2) The "package" namespace
--      ($package.varName$)
--   This is the minimal amount of information needed to upload a package
--   to Hackage, as per the information provided by the 'cabal init' and
--   'cabal check' commands.
--
-- | 3) The "package.optional" namespace
--      ($package.optional.hasVarName$ and $package.optional.varName$)
--   This includes everything else that may or may not be present, such
--   package descriptions or categories (which can either be missing or empty),
--   but do not prevent a package from being uploaded.
--
-- | 4) The "hackage" namespace
--      ($hackage.varName$)
--    Attempts to factor out the information that hackage itself tracks about
--    a given package, as opposed to the information that is implicitly provided
--    by the package (i.e., through the cabal file).
--    These items may vary across different instances/mirrors of hackage.
--    Variables in this namespace would include things like the
--    package's upload time, the last time it was updated, and the number of
--    votes it has.
packagePageTemplate :: PackageRender
            -> Maybe TarIndex -> Maybe DocMeta -> Maybe BS.ByteString
            -> URL -> Maybe PackageId -> [(DistroName, DistroPackageInfo)]
            -> Maybe [PackageName]
            -> HtmlUtilities
            -> Bool
            -> [TemplateAttr]
packagePageTemplate render
            mdocIndex mdocMeta mreadme
            docURL mPkgId distributions
            deprs utilities isCandidate =
  if isCandidate
    then
    -- The main two namespaces
    [ "package"           $= packageFieldsTemplate
    , "hackage"           $= hackageFieldsTemplate
    , "doc"               $= docFieldsTemplate
    ] ++
    -- Miscellaneous things that could still stand to be refactored a bit.
    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL mPkgId hasQuickNav
    , "downloadSection"   $= Old.downloadSection render
    ]
    else
    -- The main two namespaces
    [ "package"           $= packageFieldsTemplate
    , "hackage"           $= hackageFieldsTemplate
    , "doc"               $= docFieldsTemplate
    ] ++
    -- Miscellaneous things that could still stand to be refactored a bit.
    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL mPkgId hasQuickNav
    , "executables"       $= (commaList . map toHtml $ rendExecNames render)
    , "downloadSection"   $= Old.downloadSection render
    , "stability"         $= renderStability desc
    , "isDeprecated"      $= isJust deprs
    , "deprecatedMsg"     $= deprHtml deprs
    ]
  where
    -- Access via "$hackage.varName$"
    hackageFieldsTemplate =
      if isCandidate
        then templateDict $
        [ templateVal "uploadTime"
            (uncurry renderUploadInfo $ rendUploadInfo render)
        ] ++
        [ templateVal "hasUpdateTime"
            (case rendUpdateInfo render of Nothing -> False; _ -> True)
        , templateVal "updateTime" [ renderUpdateInfo revisionNo utime uinfo
            | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ]
        ] ++
        [ templateVal "hasFlags"
            (if rendFlags render == [] then False else True)
        , templateVal "flagsSection"
            (Old.renderPackageFlags render docURL)
        ]
        else templateDict $
        [ templateVal "uploadTime"
            (uncurry renderUploadInfo $ rendUploadInfo render)
        ] ++

        [ templateVal "hasUpdateTime"
            (case rendUpdateInfo render of Nothing -> False; _ -> True)
        , templateVal "updateTime" [ renderUpdateInfo revisionNo utime uinfo
            | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ]
        ] ++
        [ templateVal "hasDistributions"
            True
            {-(if distributions == [] then False else True)-}
        , templateVal "distributions"
            (concatHtml . intersperse (toHtml ", ") $ map showDist distributions)
        ] ++
        [ templateVal "hasFlags"
            (if rendFlags render == [] then False else True)
        , templateVal "flagsSection"
            (Old.renderPackageFlags render docURL)
        ]
        where
          showDist (dname, info) = toHtml (display dname ++ ":") +++
            anchor ! [href $ distroUrl info] << toHtml (display $ distroVersion info)


    -- Fields from the .cabal file.
    -- Access via "$package.varName$"
    packageFieldsTemplate = templateDict
      [ templateVal "name"          pkgName
      , templateVal "version"       pkgVer
      , templateVal "license"       (Old.rendLicense render)
      , templateVal "author"        (toHtml $ author desc)
      , templateVal "maintainer"    (Old.maintainField $ rendMaintainer render)
      , templateVal "maintainerURL" (toHtml $ "/package" </> pkgName </> "maintainers")
      , templateVal "buildDepends"  (snd (Old.renderDependencies render))
      , templateVal "optional"      optionalPackageInfoTemplate
      , templateVal "candidateBanner" candidateBanner
      ]

    docFieldsTemplate =
      templateDict [ templateVal "hasQuickNavV1" hasQuickNavV1
                   , templateVal "baseUrl" docURL ]

    -- Fields that may be empty, along with booleans to see if they're present.
    -- Access via "$package.optional.varname$"
    optionalPackageInfoTemplate = templateDict $
      [ templateVal "hasDescription"
          (not . Short.null . description $ rendOther render)
      , templateVal "description"
          (Old.renderHaddock (Old.moduleToDocUrl render docURL)
                             (fromShortText . description $ rendOther render))
      ] ++

      [ templateVal "hasReadme"
          (isJust $ rendReadme render)
      , templateVal "readme"
          (readmeSection render mreadme)
      ] ++

      [ templateVal "hasChangelog"
          (isJust $ rendChangeLog render)
      , templateVal "changelog"
          (renderChangelog render)
      ] ++

      [ templateVal "hasCopyright"
          (not . Short.null $ P.copyright desc)
      , templateVal "copyright"
          renderCopyright
      ] ++

      [ templateVal "hasCategories"
          (not . null $ rendCategory render)
      , templateVal "category"
          (commaList . map Old.categoryField $ rendCategory render)
      ] ++

      [ templateVal "hasHomePage"
          (not . Short.null $ homepage desc)
      , templateVal "homepage"
          (homepage desc)
      ] ++

      [ templateVal "hasBugTracker"
          (not . Short.null $ bugReports desc)
      , templateVal "bugTracker"
          (bugReports desc)
      ] ++

      [ templateVal "hasSourceRepository"
          (not . null $ sourceRepos desc)
      , templateVal "sourceRepository"
          (vList $ map sourceRepositoryToHtml (sourceRepos desc))
      ] ++

      [ templateVal "hasTestedWith"
          (not $ null pkgTestedWith)
      , templateVal "testedWith"
          (intercalate ", " pkgTestedWith)
      ] ++

      [ templateVal "hasSynopsis"
          (not . Short.null $ synopsis (rendOther render))
      , templateVal "synopsis"
          (synopsis (rendOther render))
      ]


    pkgid   = rendPkgId render
    pkgVer  = display $ pkgVersion pkgid
    pkgName = display $ packageName pkgid
    pkgTestedWith =
      [ display compilerFlavor ++ " " ++ display versionRange
      | (compilerFlavor, versionRange) <- testedWith desc
      ]

    desc = rendOther render

    candidateBanner
      | isCandidate = [ thediv ! [theclass "candidate-info"]
                        << [ paragraph << [ strong (toHtml "This is a package candidate release!")
                                          , toHtml " Here you can preview how this package release will appear once published to the main package index (which can be accomplished via the 'maintain' link below)."
                                          , toHtml " Please note that once a package has been published to the main package index it cannot be undone!"
                                          , toHtml " Please consult the "
                                          , anchor ! [href "/upload"] << "package uploading documentation"
                                          , toHtml " for more information."
                                          ] ] ]
      | otherwise = []

    renderCopyright :: Html
    renderCopyright = toHtml $ case fromShortText $ P.copyright desc of
      "" -> "None provided"
      x -> x

    renderUpdateInfo :: Int -> UTCTime -> Maybe UserInfo -> Html
    renderUpdateInfo revisionNo utime uinfo =
        anchor ! [href revisionsURL] << ("Revision " +++ show revisionNo)
        +++ " made " +++
        renderUploadInfo utime uinfo
      where
        revisionsURL = rendPkgUri render </> "revisions/"

    renderUploadInfo :: UTCTime -> Maybe UserInfo -> Html
    renderUploadInfo utime uinfo =
        "by " +++ user +++ " at " +++ timeHtml
      where
        uname   = maybe "Unknown" (display . userName) uinfo
        uactive = maybe False (isActiveAccount . userStatus) uinfo
        user  | uactive   = anchor ! [href $ "/user/" ++ uname] << uname
              | otherwise = toHtml uname
        timeHtml = XHtml.thespan ! [XHtml.title $ formatTime defaultTimeLocale "%c" utime ]
            << [toHtml (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" utime) ]

    renderChangelog :: PackageRender -> Html
    renderChangelog r = case rendChangeLog r of
      Nothing            -> toHtml "None available"
      Just (_,_,_,fname) -> anchor ! [href (rendPkgUri r </> "changelog")] << takeFileName fname

    renderStability :: PackageDescription -> Html
    renderStability d = toHtml $ case fromShortText (stability d) of
      "" -> "Unknown"
      x  -> x

    deprHtml :: Maybe [PackageName] -> Html
    deprHtml ds = case ds of
      Just fors -> case fors of
          [] -> noHtml
          _  -> concatHtml . (toHtml " in favor of ":) .
                intersperse (toHtml ", ") .
                map (packageNameLink utilities) $ fors
      Nothing -> noHtml

    hasQuickNavVersion :: Int -> Bool
    hasQuickNavVersion expected
      | Just docMeta <- mdocMeta
      , Just quickjumpVersion <- docMetaQuickJumpVersion docMeta
      = quickjumpVersion == expected
      | otherwise
      = False

    hasQuickNavV1 :: Bool
    hasQuickNavV1 = hasQuickNavVersion 1

    hasQuickNav :: Bool
    hasQuickNav = hasQuickNavV1

candidatesPageTemplate :: (PackageIndex CandPkgInfo) -> PackageCandidatesResource -> CoreResource -> [TemplateAttr]
candidatesPageTemplate cands candidates candidatesCore=
  ["heading" $= "Package candidates"
  ,"content" $= (paragraph <<
    [ toHtml "Here follow all the candidate package versions on Hackage. "
      , thespan ! [thestyle "color: gray"] <<
          [ toHtml "["
          , anchor ! [href "/packages/candidates/upload"] << "upload"
          , toHtml "]" ]
      ])
  ,"list"   $= (unordList $ map showCands $ PackageIndex.allPackagesByName cands)
  ]
  where showCands pkgs = case packageDescription <$> pkgDescMaybe (candPkgInfo $ last pkgs) of
          Nothing -> []
          Just desc ->
                -- TODO: Duncan changed this to packageSynopsis but without an
                -- accomponaying definition of packageSynposis. Changed back for now.
                let pkgname = packageName desc
                    -- candidates     = candidatesResource
                    -- candidatesCore = candidatesCoreResource
                in  [ anchor ! [href $ packageCandidatesUri candidates "" pkgname ] << display pkgname
                    , toHtml ": "
                    , toHtml $ intersperse (toHtml ", ") $ flip map pkgs $ \pkg ->
                         anchor ! [href $ corePackageIdUri candidatesCore "" (packageId pkg)] << display (packageVersion pkg)
                    , toHtml $ ". " ++ fromShortText (synopsis desc)
                    ]

-- #ToDo: Pick out several interesting versions to display, with a link to
-- display all versions.
renderVersion :: PackageId -> [(Version, VersionStatus)] -> Maybe String -> Html
renderVersion (PackageIdentifier pname pversion) allVersions info =
  versionList +++ infoHtml
  where
    (earlierVersions, laterVersionsInc) = span ((<pversion) . fst) allVersions

    (mThisVersion, laterVersions) = case laterVersionsInc of
            (v:later) | fst v == pversion -> (Just v, later)
            later -> (Nothing, later)

    versionList = commaList $ map versionedLink earlierVersions
      ++ (case pversion of
            v | v == nullVersion -> []
            _ -> [strong ! (maybe [] (status . snd) mThisVersion) << display pversion]
        )
      ++ map versionedLink laterVersions

    versionedLink (v, s) = anchor !
      (status s ++ [href $ packageURL $ PackageIdentifier pname v]) <<
        display v

    status st = case st of
        NormalVersion -> []
        DeprecatedVersion  -> [theclass "deprecated"]
        UnpreferredVersion -> [theclass "unpreferred"]

    infoHtml = case info of
      Nothing -> noHtml
      Just str -> " (" +++ (anchor ! [href str] << "info") +++ ")"

sourceRepositoryToHtml :: SourceRepo -> Html
sourceRepositoryToHtml sr
    = toHtml (display (repoKind sr) ++ ": ")
  +++ case repoType sr of
      Just (KnownRepoType Darcs)
       | (Just url, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr) ->
          concatHtml [toHtml "darcs get ",
                      anchor ! [href url] << toHtml url,
                      case repoTag sr of
                          Just tag' -> toHtml (" --tag " ++ tag')
                          Nothing   -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml " ("
                                 +++ (anchor ! [href (url </> sd)]
                                      << toHtml sd)
                                 +++ toHtml ")"
                          Nothing   -> noHtml]
      Just (KnownRepoType Git)
       | (Just url, Nothing) <-
         (repoLocation sr, repoModule sr) ->
          concatHtml [toHtml "git clone ",
                      anchor ! [href url] << toHtml url,
                      case repoBranch sr of
                          Just branch -> toHtml (" -b " ++ branch)
                          Nothing     -> noHtml,
                      case repoTag sr of
                          Just tag' -> toHtml ("(tag " ++ tag' ++ ")")
                          Nothing   -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing -> noHtml]
      Just (KnownRepoType SVN)
       | (Just url, Nothing, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
          concatHtml [toHtml "svn checkout ",
                      anchor ! [href url] << toHtml url,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just (KnownRepoType CVS)
       | (Just url, Just m, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
          concatHtml [toHtml "cvs -d ",
                      anchor ! [href url] << toHtml url,
                      toHtml (" " ++ m),
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just (KnownRepoType Mercurial)
       | (Just url, Nothing) <-
         (repoLocation sr, repoModule sr) ->
          concatHtml [toHtml "hg clone ",
                      anchor ! [href url] << toHtml url,
                      case repoBranch sr of
                          Just branch -> toHtml (" -b " ++ branch)
                          Nothing     -> noHtml,
                      case repoTag sr of
                          Just tag' -> toHtml (" -u " ++ tag')
                          Nothing   -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just (KnownRepoType Bazaar)
       | (Just url, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr) ->
          concatHtml [toHtml "bzr branch ",
                      anchor ! [href url] << toHtml url,
                      case repoTag sr of
                          Just tag' -> toHtml (" -r " ++ tag')
                          Nothing -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just (OtherRepoType "fs")
        | Just url <-
           repoLocation sr ->
                     concatHtml [toHtml "fossil clone ",
                      anchor ! [href url] << toHtml url,
                      toHtml " ",
                      toHtml (takeFileName (dropTrailingPathSeparator url) ++ ".fossil")
                      ]
      Just (KnownRepoType Pijul)
        | (Just url, Nothing, Nothing) <-
           (repoLocation sr, repoModule sr, repoTag sr) ->
                     concatHtml [toHtml "pijul clone ",
                      anchor ! [href url] << toHtml url,
                      case repoBranch sr of
                          Just branch -> toHtml (" --from-branch " ++ branch)
                          Nothing     -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml
                     ]
      _ ->
          -- We don't know how to show this SourceRepo.
          -- This is a kludge so that we at least show all the info.
          -- currently missing known repo types are GnuArch and Monotone
           let url = fromMaybe "" $ repoLocation sr
               showRepoType (OtherRepoType rt) = rt
               showRepoType x = show x
           in  concatHtml $ [anchor ! [href url] << toHtml url]
                           ++ fmap (\r -> toHtml $ ", repo type " ++ showRepoType r) (maybeToList $ repoType sr)
                           ++ fmap (\x -> toHtml $ ", module " ++ x) (maybeToList $ repoModule sr)
                           ++ fmap (\x -> toHtml $ ", branch " ++ x) (maybeToList $ repoBranch sr)
                           ++ fmap (\x -> toHtml $ ", tag "    ++ x) (maybeToList $ repoTag sr)
                           ++ fmap (\x -> toHtml $ ", subdir " ++ x) (maybeToList $ repoSubdir sr)

-- | Handle how version links are displayed.

latestVersion :: PackageId -> [Version] -> Html
latestVersion (PackageIdentifier pname _ ) allVersions =
  versionLink (last allVersions)
  where
    versionLink v = anchor ! [href $ packageURL $ PackageIdentifier pname v] << display v

readmeSection :: PackageRender -> Maybe BS.ByteString -> [Html]
readmeSection PackageRender { rendReadme = Just (_, _etag, _, filename), rendPkgId  = pkgid }
              (Just content) =
    [ thediv ! [theclass "embedded-author-content"]
            << if supposedToBeMarkdown filename
                 then renderMarkdown (display pkgid) content
                 else pre << unpackUtf8 content
    ]
readmeSection _ _ = []


unpackUtf8 :: BS.ByteString -> String
unpackUtf8 = T.unpack
           . T.decodeUtf8With T.lenientDecode
           . BS.toStrict
-----------------------------------------------------------------------------
commaList :: [Html] -> Html
commaList = concatHtml . intersperse (toHtml ", ")

vList :: [Html] -> Html
vList = concatHtml . intersperse br

-- | URL describing a package.
packageURL :: PackageIdentifier -> URL
packageURL pkgId = "/package" </> display pkgId

---
instance ToSElem Short.ShortText where
  toSElem = toSElem . fromShortText
