content: {- LinkMetadata.hs: module for generating Pandoc links which are annotated with metadata, which can then be displayed to the user as 'popups' by /static/js/popups.js. These popups can be excerpts, abstracts, article introductions etc, and make life much more pleasant for the reader - hover over link, popup, read, decide whether to go to link.
  Author: Gwern Branwen
  Date: 2019-08-20
  License: CC-0
  -}
  
  -- TODO:
  -- 1. fix Unicode handling: `shellToCommand` seems to mangle Unicode, screwing up abstracts
  -- 2. scrape more sites: possibilities include  predictionbook.com, amazon.com, nature.com, longbets.org, *plos.org, ssrn.com, wiley.com, bmj.com, cran.r-project.org, and rand.org
  -- 3. bugs in packages: the WMF API omits the need for `-L` in curl but somehow their live demo works anyway (?!); rxvist doesn't appear to support all biorxiv schemas, including the '/early/' links, forcing me to use curl+Tagsoup; the R library 'fulltext' crashes on examples like `ft_abstract(x = c("10.1038/s41588-018-0183-z"))`
  -- fix arxiv PDF links
  
  {-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
  module LinkMetadata where
  
  import qualified Data.ByteString.Lazy as B (concat, length, unpack, putStrLn)
  import qualified Data.ByteString.Lazy.UTF8 as U -- (encode, decode) -- TODO: why doesn't using U.toString fix the Unicode problems?
  import Data.Aeson
  import GHC.Generics
  import Data.List
  import Data.Char
  import Data.Maybe
  import qualified Data.Map.Strict as M -- (fromList, lookup, Map)
  import Text.Pandoc
  import qualified Data.Text.IO as TIO
  import qualified Data.Text as T
  import Data.FileStore.Utils (runShellCommand)
  import System.Exit (ExitCode(ExitFailure))
  import Data.List.Utils
  import System.Directory
  import System.IO.Temp
  import Network.Api.Arxiv hiding (Link)
  import Text.HTML.TagSoup -- (renderTagsOptions,parseTags,renderOptions, optMinimize, Tag(TagOpen))
  import Text.Show.Pretty (ppShow)
  
  type Metadata = M.Map Path MetadataItem -- (Title, Author, Date, DOI, Abstract)
  type MetadataItem = (String, String, String, String, String)
  type MetadataList = [(Path, MetadataItem)]
  type Path = String
  
  readLinkMetadata :: IO Metadata
  readLinkMetadata = do
               -- for hand created definitions, to be saved
               custom <- (fmap (read . T.unpack) $ TIO.readFile "static/metadata/custom.hs") :: IO MetadataList
               -- auto-generated cached definitions; can be deleted if gone stale
               auto   <- (fmap (read . T.unpack) $ TIO.readFile "static/metadata/auto.hs") :: IO MetadataList
               return $ M.union (M.fromList custom) (M.fromList auto) -- left-biased, 'custom' overrides 'auto'
  
  writeLinkMetadata :: Path -> MetadataItem -> IO ()
  writeLinkMetadata l m = do auto <- (fmap (read . T.unpack) $ TIO.readFile "static/metadata/auto.hs") :: IO MetadataList
                             let auto' = M.insert l m $ M.fromList auto
                             temp <- writeSystemTempFile "popup-metadata-auto.db.hs" (ppShow $ M.toAscList auto')
                             renameFile temp "static/metadata/auto.hs"
                             -- alternative: because of the slowdown from blind rewriting of the db, it may be easier
                             -- to do one pass, appending everything to a file, and then manually editing file to populate auto.hs:
                             -- appendFile "static/metadata/auto.hs-tmp" (ppShow [(l, m)])
  
  annotateLink :: Metadata -> Inline -> IO Inline
  -- Pandoc types: Link = Link Attr [Inline] Target; Attr = (String, [String], [(String, String)]); Target = (String, String)
  annotateLink md x@(Link attr text (target, tooltip)) =
    do
       -- normalize: convert 'https://www.shawwn.com/docs/foo.pdf' to '/docs/foo.pdf' and './docs/foo.pdf' to '/docs/foo.pdf'
       -- the leading '/' indicates this is a local shawwn.com file
       let target' = replace "https://www.shawwn.com/" "/" target
       let target'' = if head target' == '.' then drop 1 target' else target'
  
       let annotated = M.lookup target'' md
       print (attr, text, target, tooltip, annotated)
       case annotated of
         -- the link has a valid annotation already defined, so build & return
         Just l  -> return $ constructLink x l
         Nothing -> do new <- linkDispatcher target''
                       case new of
                         Nothing -> writeLinkMetadata target'' ("", "", "", "", "") >> return x
                         Just (p,m) -> do
                                         writeLinkMetadata target'' m
                                         return $ constructLink x m
  annotateLink _ x = return x
  
  constructLink :: Inline -> MetadataItem -> Inline
  constructLink x@(Link _ text (target, tooltip)) (title, author, date, doi, abstract) =
    if abstract == "" then x else -- if no abstract, don't bother
     Link ("", ["docMetadata"],
          (filter (\d -> (snd d) /= "") [("popup-title",title), ("popup-author",author), ("popup-date",date), ("popup-doi",doi), ("popup-abstract",abstract)]))
          text (target, tooltip)
  constructLink a b = error $ "Error: a non-Link was passed into 'constructLink'! This should never happen." ++ show a ++ " " ++ show b
  
  linkDispatcher, wikipedia, gwern, arxiv, biorxiv :: Path -> IO (Maybe (Path, MetadataItem))
  linkDispatcher l | "https://en.wikipedia.org/wiki/" `isPrefixOf` l = wikipedia l
                   | "https://arxiv.org/abs/" `isPrefixOf` l = arxiv l
                   | "https://www.biorxiv.org/content/" `isPrefixOf` l = biorxiv l
                   | "https://www.shawwn.com/" `isPrefixOf` l = gwern (drop 22 l)
                   | head l == '/' = gwern (drop 1 l)
                   | otherwise = return Nothing
  
  pdf :: Path -> IO (Maybe (Path, MetadataItem))
  pdf p = do (_,_,mb) <- runShellCommand "./" Nothing "exiftool" ["-printFormat", "$Title$/$Author$/$Date$/$DOI", "-Title", "-Author", "-Date", "-DOI", p]
             if B.length mb > 0 then
               do let (etitle:eauthor:edate:edoi:_) = lines $ U.toString mb
                  print $ "PDF: " ++ p ++" DOI: " ++ edoi
                  aMaybe <- doi2Abstract edoi
                  -- if there is no abstract, there's no point in displaying title/author/date since that's already done by tooltip+URL:
                  case aMaybe of
                    Nothing -> return Nothing
                    Just a -> return $ Just (p, (trim etitle, trim eauthor, trim edate, edoi, a))
             else return Nothing
  
  -- nested JSON object: eg 'jq .message.abstract'
  data Crossref = Crossref { message :: Message } deriving (Show,Generic)
  instance FromJSON Crossref
  data Message = Message { abstract :: Maybe String } deriving (Show,Generic)
  instance FromJSON Message
  doi2Abstract :: [Char] -> IO (Maybe String)
  doi2Abstract doi = if length doi <7 then return Nothing
                     else do (_,_,bs) <- runShellCommand "./" Nothing "curl" ["--location", "--silent", "https://api.crossref.org/works/"++doi, "--user-agent", "gwern@gwern.net"]
                             if bs=="Resource not found." then return Nothing
                             else let j = eitherDecode bs :: Either String Crossref
                                  in case j of -- start unwrapping...
                                      Left e -> putStrLn ("Error: Crossref request failed: "++doi++" "++e) >> return Nothing
                                      Right j' -> let j'' = abstract $ message j' in
                                        case j'' of
                                         Nothing -> return Nothing
                                         Just a -> let trimmedAbstract = replace "</jats:p>" "" $ replace "<jats:title>Abstract</jats:title>\n\t  <jats:p>" "" $ trim a
                                                   in return $ Just trimmedAbstract
  
  data WP = WP { title :: !String, extract_html :: !String } deriving (Show,Generic)
  instance FromJSON WP
  wikipedia p
    | "https://en.wikipedia.org/wiki/Special" `isPrefixOf` p = return Nothing
    | "https://en.wikipedia.org/wiki/User:" `isPrefixOf` p = return Nothing
    | "https://en.wikipedia.org/wiki/Talk:" `isPrefixOf` p = return Nothing
    | "https://en.wikipedia.org/wiki/Category:" `isPrefixOf` p = return Nothing
    | otherwise = do let p' = replace "/" "%2F" $ replace "%20" "_" $ drop 30 p
                     let p'' = [toUpper (head p')] ++ tail p'
                     let p''' = if '#' `elem` p'' then head $ split "#" p'' else p''
                     -- print p''
                     let rq = "https://en.wikipedia.org/api/rest_v1/page/summary/"++p'''++"?redirect=true"
                     -- `--location` is required or redirects will not be followed by *curl*; '?redirect=true' only makes the *API* follow redirects
                     (status,_,bs) <- runShellCommand "./" Nothing "curl" ["--location", "--silent", rq, "--user-agent", "gwern+wikipediascraping@gwern.net"]
                     case status of
                       ExitFailure _ -> putStrLn ("Wikipedia tooltip failed: " ++ p''') >> return Nothing
                       _ -> let j = eitherDecode bs :: Either String WP
                            in case j of
                                 Left e -> putStrLn ("WP request failed: " ++ e ++ " " ++ p ++ " " ++ p''') >> return Nothing
                                 Right wp -> let wp' = wp in
                                              return $ Just (p, (title wp', "English Wikipedia", "", "", extract_html wp'))
  
  biorxiv p = do (status,_,bs) <- runShellCommand "./" Nothing "curl" ["--location", "--silent", p, "--user-agent", "gwern+biorxivscraping@gwern.net"]
                 case status of
                   ExitFailure _ -> putStrLn ("Biorxiv download failed: " ++ p) >> return Nothing
                   _ -> do
                          let b = U.toString bs
                          let f = parseTags b
                          let metas = filter (isTagOpenName "meta") f
                          let title = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "DC.Title" then snd $ head b else "") metas
                          let date = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "DC.Date" then snd $ head b else "") metas
                          let author = intercalate ", " $ filter (/="") $ map (\x@(TagOpen _ (a:b)) -> if snd a == "DC.Contributor" then snd $ head b else "") metas
                          let doi = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "citation_doi" then snd $ head b else "") metas
                          let abstract = replace "<h3>ABSTRACT</h3>" "" $ replace "<h3>Abstract</h3>" "" $ replace "<h3>SUMMARY</h3>" "" $
                                          trim $ concatMap (\x@(TagOpen _ (a:b:c)) ->
                                                               if snd a == "citation_abstract" then snd $ head c else "") metas
                          return $ Just (p, (title, author, date, doi, abstract))
  
  
  arxiv url = do -- Arxiv direct PDF links are deprecated but sometimes sneak through
                 let arxivid = if "/pdf/" `isInfixOf` url && ".pdf" `isSuffixOf` url
                                   then replace "https://arxiv.org/pdf/" "" $ replace ".pdf" "" url
                                   else replace "https://arxiv.org/abs/" "" url
                 (status,_,bs) <- runShellCommand "./" Nothing "curl" ["--location","--silent","https://export.arxiv.org/api/query?search_query=id:"++arxivid++"&start=0&max_results=1", "--user-agent", "gwern+arxivscraping@gwern.net"]
                 case status of
                   ExitFailure _ -> putStrLn ("Error: on Arxiv ID " ++ arxivid) >> return Nothing
                   _ -> do let tags = parseTags $ U.toString bs
                           let at = getTitle $ drop 8 tags
                           let aau = intercalate ", " $ getAuthorNames tags
                           let ad = take 10 $ getUpdated tags
                           let ado = getDoi tags
                           let aa = trim $ replace "\n" " " $ getSummary tags
                           return $ Just (url, (at, aau, ad, ado, aa))
  
  trim :: String -> String
  trim = reverse . dropWhile (isSpace) . reverse . dropWhile (isSpace) . filter (/='\n')
  
  gwern p | ".pdf" `isSuffixOf` p = pdf p
          | otherwise =
              do (status,_,bs) <- runShellCommand "./" Nothing "curl" ["--location", "--silent", "https://www.shawwn.com/"++p, "--user-agent", "shawnpresser+gwernscraping@gmail.com"]
                 case status of
                   ExitFailure _ -> putStrLn ("Gwern.net download failed: " ++ p) >> return Nothing
                   _ -> do
                          let b = U.toString bs
                          let f = parseTags b
                          let metas = filter (isTagOpenName "meta") f
                          let title = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "title" then snd $ head b else "") metas
                          let date = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "dc.date.issued" then snd $ head b else "") metas
                          let author = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "author" then snd $ head b else "") metas
                          let doi = ""
                          let abstract      = trim $ renderTags $ filter filterAbstract $ takeWhile takeToAbstract $ dropWhile dropToAbstract f
                          let description = concatMap (\x@(TagOpen _ (a:b)) -> if snd a == "description" then snd $ head b else "") metas
                          -- the description is inferior to the abstract, so we don't want to simply combine them, but if there's no abstract, settle for the description:
                          let abstract'     = if length description > length abstract then description else abstract
  
                          return $ Just (p, (title, author, date, doi, abstract'))
          where
            dropToAbstract (TagOpen "div" [("id", "abstract")]) = False
            dropToAbstract _ = True
            takeToAbstract (TagClose "div") = False
            takeToAbstract _ = True
            filterAbstract (TagOpen "div" _) = False
            filterAbstract (TagClose "div") = False
            filterAbstract (TagOpen "blockquote" _) = False
            filterAbstract (TagClose "blockquote") = False
            filterAbstract _ = True
  