content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  -- | run with
  --
  -- > ./hyperlink --http=8080
  
  {-# LANGUAGE ApplicativeDo, TypeApplications #-}
  module Hyperlink (main) where
  
  import Data.Function
  import Control.Monad
  import Glean.Schema.Builtin.Types (schema_id)
  import qualified Glean.Schema.Src.Types as Src
  import qualified Glean.Schema.Cxx1.Types as Cxx
  import qualified Glean.Schema.Pp1.Types as Pp1
  import qualified Glean.Schema.Codemarkup.Types as CodeMarkup
  import qualified Glean.Schema.CodemarkupTypes.Types as CodeMarkup
  
  import qualified Glean
  import qualified Glean.Remote
  import Glean.Impl.ConfigProvider
  import Glean.Angle as Angle
  import Glean.Util.ConfigProvider
  import Glean.Util.Range (ByteRange(..), byteOffsetToLineCol, getLineOffsets)
  import Glean.Util.XRefs (collectXRefTargets)
  import Glean.Util.Some
  
  import Util.EventBase (withEventBaseDataplane)
  import Util.Log
  import Util.OptParse
  import Util.Timing
  
  import qualified Network.HTTP.Types as HTTP
  import qualified Network.Wai as Wai
  import qualified Network.Wai.Handler.Warp as Warp
  
  import Control.DeepSeq
  import Control.Exception
  import Control.Monad.Extra (whenJust)
  import Control.Monad.IO.Class
  import Control.Monad.Trans.Reader as Reader
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Char8 as BC
  import Data.Binary.Builder (Builder)
  import qualified Data.Binary.Builder as Builder
  import Data.Char (ord)
  import Data.List (sort, sortBy)
  import Data.Maybe
  import qualified Data.Set as Set
  import Data.String (fromString)
  import Data.Text (Text)
  import qualified Data.Text as Text
  import qualified Data.Text.Encoding as Text
  import Data.Word (Word8)
  import qualified Options.Applicative as O
  import System.FilePath
  
  data Config = Config
    { cfgService :: Glean.ThriftSource Glean.ClientConfig
    , cfgHttp :: Maybe Int
    , cfgHttpIface :: String
    , cfgRepoName :: Text
    , cfgRepoHash :: Maybe String
    , cfgRoot :: FilePath
    , cfgStyles :: [String]
    }
  
  options :: O.ParserInfo Config
  options = O.info (O.helper <*> parser) O.fullDesc
    where
      parser = Config
        <$> Glean.Remote.options
        <*> O.optional (O.option O.auto
              (O.long "http" <> O.metavar "PORT"))
        <*> O.strOption (O.long "http-iface" <> O.metavar "IFACE" <> O.value "*6")
        <*> textOption (O.long "repo" <> O.metavar "NAME" <> O.value "fbsource")
        <*> O.optional (O.strOption (O.long "repo-hash" <> O.metavar "HASH"))
        <*> O.strOption (O.long "root" <> O.metavar "PATH" <> O.value "")
        <*> O.many (O.option (O.maybeReader style)
              (O.long "highlight" <> O.short 'l' <> O.metavar "KIND:COLOUR"))
  
      style s
        | (kind,':':color) <- break (==':') s =
            Just $ '.' : kind ++ " { background-color: " ++ color ++ "; }"
        | otherwise = Nothing
  
  data State = State
    { stateCfg  :: Config
    , stateBackend :: Some Glean.Backend
    , stateRepo :: Glean.Repo
    }
  
  type HM = Reader.ReaderT State IO
  
  
  haxl :: Glean.Haxl w a -> HM a
  haxl h = do
    backend <- Reader.asks stateBackend
    repo <- Reader.asks stateRepo
    liftIO $ Glean.runHaxl backend repo h
  
  listFiles :: State -> IO Builder.Builder
  listFiles State{..} = do
    files <- Glean.runQuery_ stateBackend stateRepo $ Angle.query $
      predicate @Src.File wild
    let
      paths =
        [ path
        | Src.File { Src.file_key = Just path } <- files ]
    return $ htmlPre stateCfg Nothing $ mconcat
      [mconcat $ map Builder.fromByteString
        ["<a href=\"", path, "\">", path, "</a>\n"]
          | path <- map Text.encodeUtf8 $ sort paths]
  
  data TargetLoc
    = TargetLine !Int
    | TargetByteOffset !Int
  
  data Target = Target
    { targetKind :: !ByteString
    , targetPath :: !ByteString
    , targetLoc :: !TargetLoc
    }
  
  
  data Hyperlink = Hyperlink
    { hlBegin :: !Int
    , hlEnd :: !Int
    , hlTarget :: !Target
    }
  instance NFData Hyperlink where
    rnf x = x `seq` ()
  
  hyperlinkFile :: State -> FilePath -> Maybe Int -> IO Builder.Builder
  hyperlinkFile st path offset = do
    text <- BS.readFile $ cfgRoot (stateCfg st) </> path
    links <- reportTime ("queries for " ++ path) $ do
      r <- flip runReaderT st $ haxl $ do
        cxx <- cxxGetHyperlinks (fromString path)
        cm <- codeMarkupHyperlinks (fromString path)
        return (cxx ++ cm)
      evaluate (force r)
    let
      jump = case offset of
        Nothing -> Nothing
        Just o -> Just $ fromIntegral $ fst $
          byteOffsetToLineCol (getLineOffsets text) (fromIntegral o)
  
    return $ hyperlink (stateCfg st) links jump text
  
  codeMarkupHyperlinks :: Text.Text -> Glean.Haxl w [Hyperlink]
  codeMarkupHyperlinks path = do
    xrefs <- Glean.search_ $ Angle.query $
      var $ \x -> x `where_` [
        wild .= predicate @CodeMarkup.FileEntityXRefLocations (
          rec $
            field @"file" (string path) $
            field @"xref" x
          end)
        ]
  
    hyperlinks <- forM xrefs $ \CodeMarkup.XRefLocation{..} -> do
      file <- Glean.keyOf (CodeMarkup.location_file xRefLocation_target)
      let
        (start,length) = case xRefLocation_source of
          CodeMarkup.RangeSpan_span span ->
            ( fromIntegral $ Glean.unNat $ Src.byteSpan_start span
            , fromIntegral $ Glean.unNat $ Src.byteSpan_length span
            )
          _ -> (0,0)
      return Hyperlink
        { hlBegin = start
        , hlEnd = start + length
        , hlTarget = Target
          { targetKind = Text.encodeUtf8 $
              CodeMarkup.location_name xRefLocation_target
          , targetPath = Text.encodeUtf8 file
          , targetLoc = TargetByteOffset $
              case CodeMarkup.location_location xRefLocation_target of
                CodeMarkup.RangeSpan_span span ->
                  fromIntegral (Glean.unNat (Src.byteSpan_start span))
                _ -> 0
          }
        }
  
    let
      -- When there are annotations covering identical spans, prefer an
      -- annotation that points to a different file.  This is mainly to
      -- support Flow, which for a non-local reference produces two
      -- Annotations, one pointing to the import declaration and another
      -- pointing to the original declaraiton.
      unoverlap :: [Hyperlink] -> [Hyperlink]
      unoverlap links = walk links
        where
        walk (a : b : xs)
          | hlBegin a == hlBegin b && hlEnd a == hlEnd b =
            walk (preferred a b : xs)
          | otherwise = a : walk (b : xs)
        walk xs = xs
  
        -- prefer links that point to a different file
        preferred a b
          | targetPath (hlTarget a) /= Text.encodeUtf8 path = a
          | otherwise = b
  
    return $ unoverlap $ sortBy (compare `on` hlBegin) hyperlinks
  
  
  -- | Find all 'Hyperlink' spans for the given file
  cxxGetHyperlinks :: Text.Text -> Glean.Haxl w [Hyperlink]
  cxxGetHyperlinks path = do  -- ApplicativeDo makes these parallel:
  
    xref_links <- do
      filexrefs <-
        Glean.search_ $
          Glean.expanding @Cxx.FileXRefMap $
          Glean.expanding @Cxx.XRefTargets $
          Angle.query $
          predicate @Cxx.FileXRefs $
            rec $
              field @"xmap" (rec $ field @"file" (string path) end)
            end
  
      let
        crossref (ByteRange{byteRange_begin=b, byteRange_length=l}, tgt) =
          fmap (Hyperlink (fromIntegral b) (fromIntegral (b+l)))
            <$> xrefTarget tgt
  
        unoverlap :: [(ByteRange, a)] -> [(ByteRange, a)]
        unoverlap = go 0
          where
            go !_ [] = []
            go k (x@(ByteRange{byteRange_begin=b, byteRange_length=l}, _) : xs)
              | b >= k = x : go (b+l) xs
              | otherwise = go k xs
  
        -- A given file can have *many* cxx1.FileXRefs facts corresponding
        -- to different compilation traces, but we only want one hyperlink
        -- for each non-overlapping source range. So we want to de-duplicate
        -- the xrefs *before* we start fetching the data about what they
        -- refer to, otherwise we overfetch.
        xrefs = unoverlap $ Set.toList $ collectXRefTargets filexrefs
  
      mapM crossref xrefs
  
    pp_links <- do
      traces <- Glean.search_ $ Angle.query $
        predicate @Cxx.PPTrace $ rec $ field @"file" (string path) end
  
      let crossref (Cxx.PPEvent_include_ trace) = do
            key <- Glean.getKey (Cxx.includeTrace_include_ trace)
            let !Pp1.Include_key
                  { include_key_file = file
                  , include_key_pathSpan = Src.ByteSpan s l } = key
            fmap (Hyperlink (fromIntegral $ Glean.unNat s)
                (fromIntegral $ Glean.unNat s + Glean.unNat l))
              <$> target_locH "include" file (Glean.Nat 1)
  
          crossref (Cxx.PPEvent_use use) = do
            key <- Glean.getKey use
            case key of
              Pp1.Use_key
                { use_key_nameSpan = Src.ByteSpan s l
                , use_key_definition = Just (Src.Loc file line _) } ->
                fmap (Hyperlink (fromIntegral $ Glean.unNat s)
                    (fromIntegral $ Glean.unNat s + Glean.unNat l))
                  <$> target_locH "macro" file line
              _ -> return Nothing
  
          crossref _ = return Nothing
  
      fmap catMaybes
        $ mapM crossref
        $ concatMap Cxx.pPTrace_key_events
        $ mapMaybe Cxx.pPTrace_key traces
  
    return
      $ unoverlap
      $ sortBy order $ catMaybes xref_links ++ pp_links
  
    where
      order :: Hyperlink -> Hyperlink -> Ordering
      order (Hyperlink a1 b1 _) (Hyperlink a2 b2 _) =
        compare a1 a2 <> compare b1 b2
  
      unoverlap [] = []
      unoverlap (h : hs) = h : go (hlEnd h) hs
        where
          go !_ [] = []
          go k (h : hs)
            | hlBegin h >= k = h : go (hlEnd h) hs
            | otherwise = go k hs
  
      -- Thanks to the magic of Haxl, all the Glean.getKey calls below
      -- are batched into a single request to Glean, and sharing in
      -- the results is retained.
      xrefTarget :: Cxx.XRefTarget -> Glean.Haxl w (Maybe Target)
      xrefTarget x = case x of
        Cxx.XRefTarget_declaration (Cxx.Declaration_namespace_ r) -> do
          key <- Glean.getKey r
          target_range "namespace" $ Cxx.namespaceDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_namespaceAlias r) -> do
          key <- Glean.getKey r
          target_range "namespace" $ Cxx.namespaceAliasDeclaration_key_source key
  
        Cxx.XRefTarget_declaration Cxx.Declaration_usingDeclaration{} ->
          return Nothing
  
        Cxx.XRefTarget_declaration Cxx.Declaration_usingDirective{} ->
          return Nothing
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_record_ r) -> do
          key <- Glean.getKey r
          target_range "record" $ Cxx.recordDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_enum_ r) -> do
          key <- Glean.getKey r
          target_range "enum" $ Cxx.enumDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_typeAlias r) -> do
          key <- Glean.getKey r
          let kind = case Cxx.typeAliasDeclaration_key_kind key of
                Cxx.TypeAliasKind_Typedef -> "typedef"
                Cxx.TypeAliasKind_Using -> "using"
                Cxx.TypeAliasKind__UNKNOWN{} -> ""
          target_range
            ("type alias (" <> kind <> ")")
            $ Cxx.typeAliasDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_function_ r) -> do
          key <- Glean.getKey r
          target_range "function" $
            Cxx.functionDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_variable r) -> do
          key <- Glean.getKey r
          let mkind = case Cxx.variableDeclaration_key_kind key of
                Cxx.VariableKind_global_{} -> Just "variable"
                Cxx.VariableKind_local{} -> Just "variable"
                Cxx.VariableKind_field{} -> Just "field"
                Cxx.VariableKind_ivar{} -> Just "ivar"
                Cxx.VariableKind_EMPTY -> Nothing
          case mkind of
            Nothing -> return Nothing
            Just kind -> target_range kind $
              Cxx.variableDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_objcContainer r) -> do
          key <- Glean.getKey r
          let mkind = case Cxx.objcContainerDeclaration_key_id key of
                Cxx.ObjcContainerId_protocol{} -> Just "objc protocol"
                Cxx.ObjcContainerId_interface_{} -> Just "objc interface"
                Cxx.ObjcContainerId_categoryInterface{} -> Just "objc category"
                Cxx.ObjcContainerId_extensionInterface{} -> Just "objc extension"
                Cxx.ObjcContainerId_implementation{} -> Just "objc implementation"
                Cxx.ObjcContainerId_categoryImplementation{} ->
                  Just "objc category implementation"
                Cxx.ObjcContainerId_EMPTY -> Nothing
          case mkind of
            Nothing -> return Nothing
            Just kind -> target_range kind $
              Cxx.objcContainerDeclaration_key_source key
  
        Cxx.XRefTarget_declaration Cxx.Declaration_EMPTY ->
          return Nothing
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_objcMethod r) -> do
          key <- Glean.getKey r
          target_range "objc method" $
            Cxx.objcMethodDeclaration_key_source key
  
        Cxx.XRefTarget_declaration (Cxx.Declaration_objcProperty r) -> do
          key <- Glean.getKey r
          target_range "objc property" $
            Cxx.objcPropertyDeclaration_key_source key
  
        Cxx.XRefTarget_enumerator r -> do
          key <- Glean.getKey r
          target_range "enumerator" $ Cxx.enumerator_key_source key
  
        Cxx.XRefTarget_objcSelector{} -> return Nothing
  
        Cxx.XRefTarget_objcSelectorSlot{} -> return Nothing
  
        Cxx.XRefTarget_unknown (Src.Loc file line _) ->
          target_locH "unknown" file line
  
        Cxx.XRefTarget_indirect r -> do
          key <- Glean.getKey r
          xrefTarget $ Cxx.xRefIndirectTarget_key_target key
  
        Cxx.XRefTarget_EMPTY ->
          return Nothing
  
      target_range kind (Src.Range file line _ _ _) =
        target_locH kind file line
  
      target_locH kind file line = do
        path <- Glean.getKey (file :: Src.File)
        return (Just $ Target kind (Text.encodeUtf8 path) $
          TargetLine $ fromIntegral $ Glean.unNat line)
  
  
  
  hyperlink :: Config -> [Hyperlink] -> Maybe Int -> ByteString -> Builder
  hyperlink cfg links jump s =
    htmlPre cfg jump $ mconcat $ map html $ chunks links s
  
  data Chunk
    = BeginLink !Target
    | EndLink
    | BeginLine !Int
    | EndLine
    | Text ByteString
  
  ord8 :: Char -> Word8
  ord8 = fromIntegral . ord
  
  html :: Chunk -> Builder
  html (BeginLink t) = Builder.fromByteString $ mconcat $
    ["<a href=\"/", targetPath t] ++
    (case targetLoc t of
      TargetLine l -> ["#", fromString $ show l]
      TargetByteOffset o -> ["?offset=", fromString $ show o]) ++
    ["\" title=\"", targetKind t, "\" class=\"", targetKind t, "\"/>"]
  html EndLink = Builder.fromByteString "</a>"
  html (BeginLine n) = Builder.fromByteString $ mconcat
    ["\n<code id=\"", fromString $ show n, "\">"]
  html EndLine = Builder.fromByteString "</code>"
  html (Text s) =
    mconcat $ map (Builder.fromByteString . escape) $ BS.unpack s
    where
      escape c
        | c == ord8 '<' = "&lt;"
        | c == ord8 '>' = "&gt;"
        | c == ord8 '&' = "&amp;"
        | otherwise = BS.singleton c
  
  chunks :: [Hyperlink] -> ByteString -> [Chunk]
  chunks links !s = BeginLine 1 : notLinked 1 0 0 links
    where
      !n = BS.length s
  
      notLinked !_line !begin !end _
        | end == n = [text begin end, EndLine]
      notLinked !line !begin !end (link : links)
        | hlBegin link < end = notLinked line begin end links
        | hlBegin link == end =
          let begin_link = BeginLink $ hlTarget link
          in
          text begin end
          : begin_link : linked line end end (hlEnd link) begin_link links
      notLinked !line !begin !end links
        | BS.index s end == ord8 '\n' =
            text begin end
            : EndLine
            : BeginLine (line+1)
            : notLinked (line+1) (end+1) (end+1) links
        | otherwise = notLinked line begin (end+1) links
  
      linked !line !begin !end !k begin_link links
        | end == n = [text begin end, EndLink, EndLine]
        | end == k = text begin end : EndLink : notLinked line end end links
        | BS.index s end == ord8 '\n' =
            text begin end
            : EndLink
            : EndLine
            : BeginLine (line+1)
            : begin_link
            : linked (line+1) (end+1) (end+1) k begin_link links
        | otherwise = linked line begin (end+1) k begin_link links
  
      text begin end = Text $ BS.take (end-begin) $ BS.drop begin s
  
  htmlPre :: Config -> Maybe Int -> Builder -> Builder
  htmlPre cfg j s = mconcat
    [ Builder.fromByteString header
    , s
    , Builder.fromByteString footer
    ]
    where
      header = fromString $ unlines $
        ["<html><head>"
        ,"<style>"]
        ++
        cfgStyles cfg
        ++
        ["</style>"] ++
        jump j ++
        ["</head><body><pre>"]
      footer = "</pre></body></html>"
  
      -- Scroll the page to the desired line
      jump :: Maybe Int -> [String]
      jump Nothing = []
      jump (Just o) =
        [ "<script>"
        , "function scroll(id){"
        , "var e = document.getElementById(id);"
        , "window.scrollTo(e.offsetLeft, e.offsetTop);}"
        , "window.onload = function() { scroll(\"" <> show o <> "\"); };"
        , "</script>"
        ]
  
  serve :: State -> Wai.Application
  serve state req respond = do
    s <- if Wai.pathInfo req `elem` [[],["index.html"]]
      then do
        logInfo "list files"
        listFiles state
      else do
        let path = joinPath $ map Text.unpack $ Wai.pathInfo req
        logInfo path
        let
          offset = case Wai.queryString req of
            [("offset", Just n)] -> Just (read (BC.unpack n))
            _ -> Nothing
        hyperlinkFile state path offset
    respond $
      Wai.responseBuilder
        HTTP.status200
        [(HTTP.hContentType, "text/html")]
        s
  
  main :: IO ()
  main =
    withConfigOptions options $ \(cfg, cfgOpts) ->
    withEventBaseDataplane $ \evb ->
    withConfigProvider cfgOpts $ \(configAPI :: ConfigAPI) -> do
      Glean.Remote.withRemoteBackend evb configAPI
        (cfgService cfg) (Just schema_id) $ \backend -> do
        repo <- case cfgRepoHash cfg of
          Nothing -> Glean.getLatestRepo backend (cfgRepoName cfg)
          Just hash -> return $ Glean.Repo
            (cfgRepoName cfg)
            (fromString hash)
  
        let state = State
              { stateCfg = cfg
              , stateBackend = Some backend
              , stateRepo = repo
              }
  
        whenJust (cfgHttp cfg) $ \port -> do
          Warp.runSettings
            (Warp.setPort port
              $ Warp.setHost (fromString $ cfgHttpIface cfg)
              Warp.defaultSettings)
            (serve state)
  