{-# LANGUAGE PatternGuards #-}
module Distribution.Server.Features.ServerIntrospect (
    serverIntrospectFeature
  ) where

import Distribution.Server.Framework
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
import Distribution.Server.Pages.Template (hackagePage)

import Text.XHtml.Strict
         ( Html, URL, (+++), concatHtml, noHtml, toHtml, (<<)
         , h2, h3, h4, p, tt, emphasize, bold, primHtmlChar
         , blockquote, thespan, thestyle
         , anchor, (!), href, name
         , ordList, unordList )
import Data.Aeson (Value(..))
import qualified Data.Aeson.Key      as Key
import qualified Data.Aeson.KeyMap   as KeyMap
import qualified Data.Vector         as Vector
import qualified Data.Text           as Text
import Data.List
import Data.Function (on)
import Control.Arrow (first)

-- | A feature to serve information and status about the server itself.
-- It has access to all the other features on the server so can do some
-- amount of introspection.
--
-- In particular it provides:
--
-- * API introspection: let people find out what the API of this Hackage server
-- instance is. It lists all the active features and all the resources they
-- serve, including what methods and formats they support.
-- This should make things more obvious to people writing clients.
--
-- * Memory consumption by each of the features
--
serverIntrospectFeature :: [HackageFeature] -> HackageFeature
serverIntrospectFeature serverFeatures = (emptyHackageFeature "serverapi") {
    featureDesc = "Lists the resources available on this server."
  , featureResources =
      [ (resourceAt "/api.:format") {
            resourceDesc = [ (GET, "This page") ]
          , resourceGet  = [ ("html", \_ -> serveApiDocHtml serverFeatures)
                           , ("json", \_ -> serveApiDocJSON serverFeatures)
                           ]
          }
      , (resourceAt "/server-status/memory.:format") {
            resourceDesc = [ (GET, "Server memory usage") ]
          , resourceGet  = [ ("html", \_ -> serveMemSizeHtml serverFeatures)
                           ]
          }
      ]
  , featureState = []
  }

-------------------
-- Server API stuff
--

serveApiDocHtml :: [HackageFeature] -> ServerPartE Response
serveApiDocHtml = return . toResponse . Resource.XHtml . apiDocPageHtml

serveApiDocJSON :: [HackageFeature] -> ServerPartE Response
serveApiDocJSON = return . toResponse . apiDocJSON


-- TODO: all-resources from all features combined
--       and also for the JSON that's all we really want.

apiDocPageHtml :: [HackageFeature] -> Html
apiDocPageHtml serverFeatures = hackagePage title content
  where
    title = "Server API"
    descr = "This page lists all of the resources available on this server. "
         ++ "The same list is also available in machine readable formats "
         ++ "(see link below)."
    content = [ h2 << title
              , p  << descr
              , featureLinks
              , featureList ]

    featureLinks =
      h3 << "Enabled server features" +++
      unordList
        [ anchor ! [ href ('#' : featureName feature) ] << featureName feature
        | feature <- serverFeatures ]

    featureList =
      concatHtml
        [ anchor ! [ name (featureName feature) ] << h3 << ("The " +++ featureName feature +++ " feature")
          +++ p << (let desc = featureDesc feature
                    in if null desc then thespan ! [thestyle "color: red"] << "Feature description unavailable"
                                    else toHtml desc)
          +++ stateList feature
          +++ resourceList feature
        | feature <- serverFeatures ]

    stateList feature =
      let states = map abstractStateDesc (featureState feature) in
      if null states
        then     p << "This feature does not have any state."
        else     p << emphasize << "State"
             +++ unordList states

    resourceList feature =
          p << emphasize << "Resources"
      +++ unordList [
                  renderLocationTemplate resource
              +++ renderResourceWithExtensions (Just feature) resource
            | resource <- featureResources feature
            ]

    renderResourceWithExtensions mFeature resource =
            methodList resource
        +++ case mFeature of
               Nothing      -> mempty
               Just feature -> extensionsElsewhere feature resource

    methodList resource =
      unordList
        [ show httpMethod +++ ": " +++ formatList formats +++ " -- " +++ description
        | (httpMethod, formats, description) <- resourceMethodsAndFormats resource ]

    formatList formats =
      intersperse (toHtml ", ")
        [ tt << format | format <- formats ]

    renderLocationTemplate :: Resource -> Html
    renderLocationTemplate resource =
        let (components, mUrl) = renderComponents pathComponents
            trailer            = renderTrailer (resourceFormat resource) (resourcePathEnd resource)
        in tt << case mUrl of
             Nothing  -> components +++ trailer
             Just url -> anchor ! [href (url ++ trailer)] << (components +++ trailer)
      where
        pathComponents = reverse (resourceLocation resource)

        renderComponents :: [BranchComponent] -> (Html, Maybe URL)
        renderComponents (StaticBranch sdir:cs) =
          let (rest, url) = renderComponents cs
          in ("/" +++ sdir +++ rest, liftM (("/" ++ sdir) ++) url)
        renderComponents [DynamicBranch leaf]
          | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource =
              ("/" +++ leaf, Just ("/" ++ leaf))
        renderComponents (DynamicBranch ddir:cs) =
          let (rest, _) = renderComponents cs
          in ("/" +++ emphasize << (":" ++ ddir) +++ rest, Nothing)
        renderComponents (TrailingBranch :_ ) =
          (emphasize << "/..", Nothing)
        renderComponents [] =
          (noHtml, Just "")

        renderTrailer (ResourceFormat (StaticFormat ext) _) _ = "." ++ ext
        renderTrailer _ Slash                                 = "/"
        renderTrailer _ _                                     = ""

    extensionsElsewhere feature resource =
        if null matchingResources
          then mempty
          else p << "Methods defined in other features:"
               +++ blockquote << matchingResources
      where
        matchingResources :: [Html]
        matchingResources =
          [ toHtml [ p << ("In the " +++ featureName feature' +++ " feature")
                   , p << renderResourceWithExtensions Nothing resource' ]
          | feature'  <- serverFeatures
          , featureName feature' /= featureName feature
          , resource' <- featureResources feature'
          , resourceLocation resource' == resourceLocation resource
          , not (null (resourceMethods resource'))
          ]

resourceMethodsAndFormats :: Resource -> [(Method, [String], Html)]
resourceMethodsAndFormats (Resource _ rget rput rpost rdelete _ _ desc) =
    [ (httpMethod, [ formatName | (formatName, _) <- handlers ], descriptionFor httpMethod desc)
    | (handlers@(_:_), httpMethod) <- zip methodsHandlers methodsKinds ]
  where
    methodsHandlers = [rget, rput, rpost, rdelete]
    methodsKinds    = [GET,  PUT,  POST,  DELETE]

    descriptionFor :: Method -> [(Method, String)] -> Html
    descriptionFor _ [] = thespan ! [thestyle "color: red"] << "Method description unavailable"
    descriptionFor m ((m',d):ds)
      | m == m'   = toHtml d
      | otherwise = descriptionFor m ds

apiDocJSON :: [HackageFeature] -> Value
apiDocJSON serverFeatures = featureList
  where
    featureList =
      array
        [ object
            [ ("feature", string $ featureName feature)
            , ("resources", resourceList feature) ]
        | feature <- serverFeatures ]

    resourceList :: HackageFeature -> Value
    resourceList feature =
      array
        [ object
            [ ("location", string $ renderLocationTemplate resource)
            , ("methods", methodList resource) ]
        | resource <- featureResources feature ]

    methodList :: Resource -> Value
    methodList resource =
      array
        [ object
            [ ("method", string $ show httpMethod)
            , ("formats", formatList formats) ]
        | (httpMethod, formats, _) <- resourceMethodsAndFormats resource ]

    formatList formats =
      array
        [ object
            [ ("name", string format)
            ] -- could add here ("mimetype", ...)
        | format <- formats ]

    renderLocationTemplate :: Resource -> String
    renderLocationTemplate resource =
           renderComponents pathComponents
        ++ renderTrailer (resourceFormat resource) (resourcePathEnd resource)
      where
        pathComponents = reverse (resourceLocation resource)

        renderComponents (StaticBranch  sdir:cs) = "/" ++ sdir
                                                       ++ renderComponents cs
        renderComponents [DynamicBranch leaf]
          | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource
                                                 = "/" ++ leaf
        renderComponents (DynamicBranch ddir:cs) = "/" ++ ":" ++ ddir
                                                       ++ renderComponents cs
        renderComponents (TrailingBranch    :_ ) = "/.."
        renderComponents []                      = ""

        renderTrailer (ResourceFormat (StaticFormat ext) _) _ = "." ++ ext
        renderTrailer _ Slash                                 = "/"
        renderTrailer _ _                                     = ""

----------------------
-- Memory consumption
--

serveMemSizeHtml :: [HackageFeature] -> ServerPartE Response
serveMemSizeHtml serverFeatures =
      toResponse
    . Resource.XHtml
    . memSizePageHtml
  <$> liftIO (mapM getFeatureSizes serverFeatures)
  where
    getFeatureSizes feature =
      (,,,) <$> pure (featureName feature)
            <*> pure (featureDesc feature)
            <*> mapM getCanonicalStateSizes (featureState feature)
            <*> mapM getCacheStateSizes     (featureCaches feature)

    getCanonicalStateSizes component =
      (,)   <$> pure (abstractStateDesc component)
            <*> abstractStateSize component

    getCacheStateSizes component =
      (,)   <$> pure (cacheDesc component)
            <*> getCacheMemSize component

memSizePageHtml :: [(String, String, [(String, Int)], [(String, Int)])] -> Html
memSizePageHtml featureStateSizes =
    hackagePage title content
  where
    title = "Server memory use"
    descr = "This page lists the memory use all of the in-memory data stores "
         ++ "and caches on the server."
    content = [ h2 << title
              , p  << descr
              , sectionLinks
              , totalSection
              , bySizeList
              , byFeatureList
              ]

    sectionLinks =
      h3 << "Contents" +++
      unordList
        [ anchor ! [ href ('#' : ref) ] << section
        | (section, ref) <- [("Total",      "total")
                            ,("By size",    "by-size")
                            ,("By feature", "by-feature")] ]

    orderedStateSizes = sortBy (flip compare `on` (\(x,_,_,_) -> x))
      [ (sz, isCanonical, cname, fname)
      | (fname, _, canonical, caches) <- featureStateSizes
      , ((cname, sz), isCanonical) <- zip canonical (repeat True)
                                   ++ zip caches    (repeat False) ]

    totalSize = sum [ sz | (sz,_,_,_) <- orderedStateSizes ]

    totalSection =
      h3 << (anchor ! [ name "total" ] << "Total")
        +++ p << "Total memory use of all state components and all caches:"
        +++ unordList [ show (memSizeMb totalSize) ++ "MB" ]
        +++ p << ("Note that the real heap size is usually 2x-3x greater than "
              ++ "this due to the way the GC works.")

    bySizeList =
      h3 << (anchor ! [ name "by-size" ] << "By size") +++
      ordList
        [ bold << (show (memSizeMb sz) ++ " MB: ")
          +++ cname +++ " " +++ primHtmlChar "mdash" +++ " "
           ++ (if isCanonical then "state component" else "cache")
           ++ " from feature "
          +++ anchor ! [ href ('#' : fname) ] << fname
        | (sz, isCanonical, cname, fname) <- orderedStateSizes ]


    byFeatureList =
      h3 << (anchor ! [ name "by-feature" ] << "By feature") +++
      concatHtml
        [ anchor ! [ name fname ] << h4 << fname
          +++ p << fdesc
          +++ stateList "state"  "State components:" states
          +++ stateList "caches" "Cache components:" caches
        | (fname, fdesc, states, caches) <- featureStateSizes ]

    stateList thing1 thing2 states =
      if null states
        then p << ("This feature does not have any " ++ thing1 ++ ".")
        else p << emphasize << thing2
              +++ unordList [ bold << (show (memSizeMb sz) ++ " MB: ")
                                  +++ cname
                            | (cname, sz) <- states ]

{------------------------------------------------------------------------------
  Some aeson auxiliary functions
------------------------------------------------------------------------------}

array :: [Value] -> Value
array = Array . Vector.fromList

object :: [(String, Value)] -> Value
object = Object . KeyMap.fromList . map (first Key.fromString)

string :: String -> Value
string = String . Text.pack
