{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeOperators #-}

{-# LANGUAGE QuasiQuotes #-}

{-# LANGUAGE MultiWayIf #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Server

( start

, publicApiMarkdown

) where

import Network.Wai

import Network.HTTP.Types

import Network.Wai.Handler.Warp (runSettings, setPort, setHost, defaultSettings)

import Network.Wai.Middleware.RequestLogger

import Data.Monoid

import qualified Data.Text as Text

import qualified Data.Text.Lazy as LT

import qualified Data.Text.Lazy.Encoding as LTE

import qualified Data.Binary.Builder as Builder

import qualified Data.Map.Strict as Map

import qualified Data.ByteString.Lazy as LBS

import qualified Data.ByteString.Lazy.Char8 as LC

import qualified Data.Array

import Data.List.Extra

import Data.String

import qualified Data.Hash.MD5 as MD5

import Safe

import Text.Regex.PCRE

import System.FileLock

import System.Posix.User

import Path

import Path.IO

import qualified System.FilePath as FilePath

import qualified System.Directory as Directory

import Control.Exception

import Control.Monad.STM

import Control.Concurrent.STM.TMVar

import Control.Monad.IO.Class

import Control.Lens ((&), (<>~))

import Servant

import Servant.Docs

import qualified Text.HTML.TagSoup as Soup

import Utils

import qualified DevDocs

import qualified DevDocsMeta

import qualified Doc

import qualified Config

import qualified Slot

import qualified Match

import qualified Opt

start :: Opt.Logging -> Config.T -> ConfigRoot -> CacheRoot -> Slot.T -> IO ()

start logging config configRoot cacheRoot slot = do

-- TODO @incomplete: make the lock global

userId <- getRealUserID

lockFilePath <- do

a <- parseRelDir $ show userId

return $ [absdir|/run/user|] </> a </> [relfile|doc-browser/server.lock|]

createDirIfMissing True $ parent lockFilePath

report ["wait for server slot"]

withFileLock (toFilePath lockFilePath) Exclusive $ \_lock -> do

report ["start new server"]

let middleware = case logging of

Opt.NoLog -> id

Opt.Log -> logStdout

let settings = setPort (Config.port config) $ setHost "127.0.0.1" defaultSettings

runSettings settings (middleware $ app config configRoot cacheRoot slot)

type API = PublicAPI :<|> PrivateAPI

api :: Proxy Server.API

api = Proxy

app :: Config.T -> ConfigRoot -> CacheRoot -> Slot.T -> Application

app config configRoot cacheRoot slot =

serve api

(publicServer slot

:<|> privateServer config configRoot cacheRoot)

type Q = QueryParam' '[Required] "q" String

instance ToParam Q where

toParam _ =

DocQueryParam

"q"

["os.path", "/pyos.path", "forM/hh", "etc."]

"String to search"

Normal

instance ToSample () where

toSamples _ = noSamples

instance ToSample Match.T where

toSamples _ = samples

[ Match.T

{ Match.vendor = "DevDocs"

, Match.name = "os.path"

, Match.collection = "Python"

, Match.version = "3.6.4"

, Match.url = "http://localhost:7701/DevDocs/Python==3.6.4/library/os.path"

, Match.package_ = Nothing

, Match.module_ = Nothing

, Match.typeConstraint = Nothing

, Match.icon = Just "Python"}

]

type SearchAPI = "search" :> Q :> Get '[JSON] [Match.T]

type SummonAPI = "summon" :> Q :> Get '[JSON] ()

type PublicAPI

= SummonAPI

:<|> SearchAPI

publicApi :: Proxy PublicAPI

publicApi = Proxy

publicApiMarkdown :: String

publicApiMarkdown =

let docOptions = defaultDocOptions

docIntro = DocIntro "HTTP API for doc-browser" $ paragraphs

[ [ "You can interact with this application using HTTP requests."]

, [ "All URL should be prefixed with `http://localhost:<port>`,"

, "where `<port>` is 7701 if the user didn't change its configuration,"

, "generally, you can use `doc-browser --get-port` to get the port."]

, [ "If you are using Insomnia, you can import `insomnia.json`,"

, "found at the root of this repository."]

, [ "APIs are listed below."]

]

extraInfoSearch = extraInfo (Proxy :: Proxy SearchAPI) $

defAction & notes <>~ [DocNote "Function"

["Search doc-browser with the given string, and return the search result as a JSON array. Detailed documentation of the type of the element of the returned array can be found at: https://qwfy.github.io/doc-browser/doc/Match.html#t:T"]]

extraInfoSummon = extraInfo (Proxy :: Proxy SummonAPI) $

defAction & notes <>~ [DocNote "Function"

["Bring the doc-browser GUI to front, and search it with the given string."]]

in markdown $ docsWith docOptions [docIntro] (extraInfoSearch <> extraInfoSummon) publicApi

publicServer :: Slot.T -> Server PublicAPI

publicServer slot =

summon

:<|> search

where

summon :: String -> Servant.Handler ()

summon queryStr = liftIO $ do

atomically $ putTMVar (Slot.summon slot) queryStr

search :: String -> Servant.Handler [Match.T]

search queryStr = liftIO $ do

resultTMVar <- atomically $ newEmptyTMVar

atomically $ updateTMVar (Slot.query slot) (Slot.HttpQuery queryStr resultTMVar)

atomically $ takeTMVar resultTMVar

type PrivateAPI

= "cache" :> Raw

:<|> "abspath" :> Raw

:<|> Raw

privateServer :: Config.T -> ConfigRoot -> CacheRoot -> Server PrivateAPI

privateServer config configRoot cacheRoot =

serveCache

:<|> serveAbspath

:<|> Tagged (rawServer config configRoot cacheRoot)

where

serveCache = serveDirectoryWebApp (toFilePath $ getCacheRoot cacheRoot)

serveAbspath = serveDirectoryWebApp "/"

rawServer :: Config.T -> ConfigRoot -> CacheRoot -> Application

rawServer config configRoot cacheRoot request respond = do

let paths = pathInfo request |> map Text.unpack

-- TODO @incomplete: send css and js files directly to socket instead of reading and then sending

let mime ext

| ext == ".css" = "text/css; charset=utf-8"

| ext == ".js" = "text/javascript; charset=utf-8"

| otherwise = "text/html; charset=utf-8"

let contentType' = maybe

"text/html; charset=utf-8"

(mime . FilePath.takeExtension)

(lastMay paths)

let headers = [("Content-Type", contentType')]

case paths of

(vendor : cv : rest) | vendor == show Doc.DevDocs -> do

(collection, version) <- parseRelDir cv >>= Doc.breakCollectionVersion

path <- parseRelFile $ intercalate "/" rest

builder <- fetchDevdocs configRoot cacheRoot collection version path

respond (responseBuilder status200 headers builder)

(vendor : rest) | vendor == show Doc.Dash -> do

path <- parseRelFile $ intercalate "/" rest

resp <- fetchDash configRoot path

respond (responseLBS status200 headers resp)

(vendor : _) | vendor == show Doc.Hoogle -> do

let path = intercalate "/" paths

resp <- fetchHoogle config configRoot path

respond (responseLBS status200 headers resp)

_ -> do

let resp = "Unhandled URL: " <> (LBS.fromStrict $ rawPathInfo request)

respond (responseLBS status400 headers resp)

fetchDash :: ConfigRoot -> Path Rel File -> IO LBS.ByteString

fetchDash configRoot path = do

vendorPart <- parseRelDir $ show Doc.Dash

let filePath = getConfigRoot configRoot </> vendorPart </> path

if fileExtension filePath `elem` [".html", ".htm"]

then LTE.encodeUtf8 . urlDecodeAnchors . LTE.decodeUtf8 <$> LBS.readFile (toFilePath filePath)

else LBS.readFile (toFilePath filePath)

urlDecodeAnchors str =

Soup.parseTags str

|> map decodeOpen

|> Soup.renderTags

where

-- map <a class="dashAnchor" name="//apple_ref/func/all%2F2"></a>

-- to <a class="dashAnchor" name="//apple_ref/func/all/2"></a>

-- because QtWebEngine have trouble handling anchor name like these

decodeOpen old@(Soup.TagOpen tagName attrs) =

case lower tagName == "a" of

True ->

case decodeAttrs attrs of

Nothing -> old

Just new -> Soup.TagOpen tagName new

False ->

old

decodeOpen x = x

lower = LT.toLower

urlDecode' x = LTE.encodeUtf8 x |> LBS.toStrict |> urlDecode False |> LBS.fromStrict |> LTE.decodeUtf8

decodeAttrs attrs =

case foldr f ([], False, False) attrs of

(new, True, True) -> Just new

(_, _, _ ) -> Nothing

where

f attr@(attrName, attrValue) (processed, classFound, nameFound) =

if | (not classFound) && lower attrName == "class" && attrValue == "dashAnchor" ->

(attr:processed, True, nameFound)

| (not nameFound) && lower attrName == "name" ->

((attrName, urlDecode' attrValue):processed, classFound, True)

| otherwise ->

(attr:processed, classFound, nameFound)

fetchHoogle :: Config.T -> ConfigRoot -> FilePath -> IO LBS.ByteString

fetchHoogle config configRoot path = do

let filePath = FilePath.joinPath [toFilePath $ getConfigRoot configRoot, path]

fileToRead <- do

isFile <- Directory.doesFileExist filePath

if isFile

then return filePath

else do

let indexHtml = filePath FilePath.</> "index.html"

indexExist <- Directory.doesFileExist indexHtml

if indexExist

then return indexHtml

-- TODO @incomplete: Add this file

else return "404.html"

LBS.readFile fileToRead >>= replaceMathJax (Config.mathJaxDirectory config)

replaceMathJax :: Config.MathJaxDirectory -> LBS.ByteString -> IO LBS.ByteString

replaceMathJax (Config.MathJaxDirectory mathJaxDir) source = do

-- TODO @incomplete: ability to install another copy

-- or make this configurable

let distDir = toFilePath mathJaxDir

hasMathJaxDist <- Directory.doesDirectoryExist distDir

if not hasMathJaxDist

then return source

else do

let str = "src=\"https?://.+/MathJax\\.js(\\?config=[^\"]+)\"" :: LBS.ByteString

let regex = makeRegex str :: Regex

case matchOnceText regex source of

Nothing ->

return source

Just (before', match', after') -> do

let (cfg, _) = match' Data.Array.! 1

let localFile = fromString $ FilePath.joinPath ["/abspath", tail distDir, "MathJax.js"]

return $ before' <> "src=\"" <> localFile <> cfg <> "\"" <> after'

fetchDevdocs :: ConfigRoot

-> CacheRoot

-> Doc.Collection

-> Doc.Version

-> Path Rel File

-> IO Builder.Builder

fetchDevdocs configRoot cacheRoot collection version path = do

filePath <- (getConfigRoot configRoot </>) <$> DevDocs.getDocFile collection version path

content <- Builder.fromLazyByteString <$> LBS.readFile (toFilePath filePath)

cssUrl <- getCached cacheRoot "https://devdocs.io/application.css" "css"

jsUrl <- getCached cacheRoot "https://raw.githubusercontent.com/freeCodeCamp/devdocs/main/assets/javascripts/vendor/prism.js" "js"

let css = "<link rel='stylesheet' href='" <> cssUrl <> "'>"

let js = "<script src='" <> jsUrl <> "'></script>" <> "\

-- TODO @incomplete: handle the concatenation properly

let begin' =

"<html class='_theme-default'>\

\ " <> css <> "\

pageDiv =

case Map.lookup collection DevDocsMeta.typeMap of

Nothing ->

"<div class='_page'>"

Just t ->

Data.String.fromString $ "<div class='_page _" ++ t ++ "'>"

begin = Builder.fromLazyByteString $ begin' <> pageDiv

let end = Builder.fromLazyByteString $

" </div>\

\ " <> js <> "\

return $ begin <> content <> end

getCached :: CacheRoot -> LBS.ByteString -> String -> IO LBS.ByteString

getCached cacheRoot url' ext = do

let url = LC.unpack url'

basename <- parseRelFile (MD5.md5s (MD5.Str url)) >>= (<.> ext)

let cachedUrl = fromString . toFilePath $ [absdir|/cache|] </> basename

let storage = getCacheRoot cacheRoot </> basename

cached <- doesFileExist storage

if cached

then

return cachedUrl

else do

dlRes <- try (withLock (getCacheRoot cacheRoot) $ downloadFile url storage) :: IO (Either SomeException ())

case dlRes of

Right () -> do

report ["cached url:", url, "to:", toFilePath storage]

return cachedUrl

Left e -> do

report ["error caching:", url, show e]

return url'