aboutsummaryrefslogtreecommitdiff
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/Indexer.hs208
-rw-r--r--app/Server.hs1014
2 files changed, 1222 insertions, 0 deletions
diff --git a/app/Indexer.hs b/app/Indexer.hs
new file mode 100644
index 0000000..083c94d
--- /dev/null
+++ b/app/Indexer.hs
@@ -0,0 +1,208 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Codec.Compression.GZip(compress)
+import Control.Exception (SomeException, handle)
+import Control.Monad (when)
+import Control.Monad.Logger (LogLevel(..), runLoggingT)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy.Char8 as BSC
+import qualified Data.HashMap.Strict as HM
+import Data.Maybe (fromMaybe)
+import Data.Semigroup ((<>))
+import qualified Data.Serialize as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time (getZonedTime)
+import Data.Version (Version(..),showVersion)
+import HaskellCodeExplorer.PackageInfo (createPackageInfo)
+import qualified HaskellCodeExplorer.Types as HCE
+import Network.URI.Encode (encode)
+import Options.Applicative
+ ( Parser
+ , (<|>)
+ , execParser
+ , flag
+ , fullDesc
+ , help
+ , helper
+ , info
+ , long
+ , many
+ , metavar
+ , optional
+ , progDesc
+ , short
+ , strOption
+ )
+import Paths_haskell_code_explorer as HSE (version)
+import System.Directory (createDirectoryIfMissing)
+import System.Exit (ExitCode(..), exitWith)
+import System.FilePath ((</>))
+import System.Log.FastLogger
+ ( LoggerSet
+ , ToLogStr(..)
+ , defaultBufSize
+ , fromLogStr
+ , newFileLoggerSet
+ , newStdoutLoggerSet
+ , pushLogStrLn
+ , rmLoggerSet
+ )
+
+data IndexerConfig = IndexerConfig
+ { configPackageDirectoryPath :: FilePath
+ , configPackageDistDirRelativePath :: Maybe FilePath
+ , configOutputDirectoryName :: Maybe String
+ , configLog :: !HCE.Log
+ , configMinLogLevel :: !LogLevel
+ , configSourceCodePreprocessing :: !HCE.SourceCodePreprocessing
+ , configCompression :: !Compression
+ , configGhcOptions :: [String]
+ , configIgnoreDirectories :: [String]
+ } deriving (Show, Eq)
+
+data Compression
+ = Gzip
+ | NoCompression
+ deriving (Show, Eq)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 2, 2, 0], versionTags = []}
+#else
+ghcVersion :: Version
+ghcVersion = Version {versionBranch = [8, 0, 2, 0], versionTags = []}
+#endif
+
+versionInfo :: String
+versionInfo =
+ "haskell-code-indexer version " ++
+ showVersion version ++ ", GHC version " ++ showVersion ghcVersion
+
+main :: IO ()
+main = do
+ let description =
+ "haskell-code-indexer collects and saves information about the source code of a Cabal package. " ++
+ versionInfo
+ config <-
+ execParser $
+ info (helper <*> configParser) (fullDesc <> progDesc description)
+ loggerSet <-
+ case configLog config of
+ HCE.ToFile logfile -> newFileLoggerSet defaultBufSize logfile
+ HCE.StdOut -> newStdoutLoggerSet defaultBufSize
+ let minLogLevel = configMinLogLevel config
+ logger loggerSet minLogLevel LevelInfo versionInfo
+ logger loggerSet minLogLevel LevelDebug $ show config
+ handle
+ (\(e :: SomeException) -> do
+ logger loggerSet minLogLevel LevelError (show e)
+ rmLoggerSet loggerSet
+ exitWith (ExitFailure 1)) $ do
+ packageInfo <-
+ runLoggingT
+ (createPackageInfo
+ (configPackageDirectoryPath config)
+ (configPackageDistDirRelativePath config)
+ (configSourceCodePreprocessing config)
+ (configGhcOptions config)
+ (configIgnoreDirectories config))
+ (\_loc _source level msg -> logger loggerSet minLogLevel level msg)
+ let outputDir =
+ configPackageDirectoryPath config </>
+ fromMaybe
+ HCE.defaultOutputDirectoryName
+ (configOutputDirectoryName config)
+ createDirectoryIfMissing False outputDir
+ logger loggerSet minLogLevel LevelDebug $ "Output directory : " ++ outputDir
+ BS.writeFile
+ (outputDir </> HCE.packageInfoBinaryFileName)
+ (S.encode $ HCE.toCompactPackageInfo packageInfo)
+ mapM_
+ (\(HCE.HaskellModulePath path, modInfo) ->
+ let (compressFunction, compressExtension) =
+ case configCompression config of
+ Gzip -> (compress, ".gz")
+ NoCompression -> (id, "")
+ filePath =
+ outputDir </>
+ (encode (T.unpack path) ++ ".json" ++ compressExtension)
+ in BSL.writeFile filePath . compressFunction . A.encode $ modInfo) .
+ HM.toList $
+ HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.ModuleInfo)
+ BSL.writeFile
+ (outputDir </> HCE.packageInfoJsonFileName)
+ (A.encode packageInfo)
+ BSL.writeFile (outputDir </> "version.txt") (BSC.pack $ showVersion version)
+ logger loggerSet minLogLevel LevelInfo ("Finished" :: T.Text)
+ rmLoggerSet loggerSet
+
+configParser :: Parser IndexerConfig
+configParser =
+ IndexerConfig <$>
+ strOption
+ (long "package" <> short 'p' <> metavar "PATH" <>
+ help "Path to a Cabal package") <*>
+ optional
+ (strOption
+ (long "dist" <> metavar "RELATIVE_PATH" <>
+ help "Relative path to a dist directory")) <*>
+ optional
+ (strOption
+ (long "output" <> metavar "DIRECTORY_NAME" <>
+ help "Output directory (default is '.haskell-code-explorer')")) <*>
+ (pure HCE.StdOut <|>
+ (HCE.ToFile <$>
+ strOption
+ (long "logfile" <> metavar "PATH" <>
+ help "Path to a log file (by default log is written to stdout)"))) <*>
+ flag
+ LevelInfo
+ LevelDebug
+ (long "verbose" <> short 'v' <> help "Write debug information to a log") <*>
+ flag
+ HCE.AfterPreprocessing
+ HCE.BeforePreprocessing
+ (long "before-preprocessing" <>
+ help
+ "Index source code before preprocessor pass (by default source code after preprocessing is indexed)") <*>
+ flag
+ Gzip
+ NoCompression
+ (long "no-compression" <>
+ help
+ "Do not compress json files (by default json files are compressed using gzip)") <*>
+ many
+ (strOption
+ (long "ghc" <> metavar "OPTIONS" <> help "Command-line options for GHC")) <*>
+ many
+ (strOption
+ (long "ignore" <> metavar "DIRECTORY_NAME" <>
+ help "Directories to ignore (e.g. node_modules)"))
+
+logger :: ToLogStr msg => LoggerSet -> LogLevel -> LogLevel -> msg -> IO ()
+logger loggerSet minLogLevel logLevel msg =
+ when (logLevel >= minLogLevel) $ do
+ time <- getZonedTime
+ let showLogLevel :: LogLevel -> T.Text
+ showLogLevel LevelDebug = "[debug]"
+ showLogLevel LevelInfo = "[info]"
+ showLogLevel LevelWarn = "[warn]"
+ showLogLevel LevelError = "[error]"
+ showLogLevel (LevelOther t) = T.concat ["[",t,"]"]
+ text =
+ T.concat
+ [ T.pack $ show time
+ , " : "
+ , showLogLevel logLevel
+ , " "
+ , TE.decodeUtf8 . fromLogStr . toLogStr $ msg
+ ]
+ pushLogStrLn loggerSet $ toLogStr text
diff --git a/app/Server.hs b/app/Server.hs
new file mode 100644
index 0000000..39f550f
--- /dev/null
+++ b/app/Server.hs
@@ -0,0 +1,1014 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Main where
+
+import Control.Exception
+ ( SomeAsyncException
+ , SomeException
+ , fromException
+ , handle
+ , throwIO
+ , throwIO
+ , try
+ )
+import Control.Monad (unless)
+import Control.Monad.Except (ExceptT(..))
+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT(..), asks, liftIO)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.Vector as V
+import qualified Data.ByteString.Lazy as BSL
+import Data.Default (def)
+import Data.Either (lefts, rights)
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import qualified Data.IntervalMap.Strict as IVM
+import qualified Data.List as L
+import qualified Data.Map.Strict as M
+import Data.Maybe(fromMaybe)
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+import qualified GHC.Compact as C
+import Data.Functor.Identity(Identity(..))
+#endif
+import Data.Pagination
+ ( Paginated
+ , hasNextPage
+ , hasPrevPage
+ , mkPagination
+ , paginate
+ , paginatedItems
+ , paginatedPagesTotal
+ )
+import Data.Proxy (Proxy(..))
+import Data.Semigroup ((<>))
+import qualified Data.Serialize as Serialize
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Text.Lazy (toStrict)
+import Data.Text.Read(decimal)
+import Data.Version (Version(..))
+import GHC.Exts (Down(..), groupWith)
+import GHC.Generics (Generic)
+import qualified HaskellCodeExplorer.Types as HCE
+import Network.HTTP.Types
+ ( hContentEncoding
+ , hContentType
+ , status200
+ , status404
+ )
+import Network.Mime (defaultMimeLookup)
+import Network.Wai
+ ( Application
+ , Middleware
+ , Response
+ , pathInfo
+ , responseFile
+ , responseLBS
+ , requestHeaders
+ )
+import Network.Wai.Handler.Warp (run)
+import Network.Wai.Middleware.RequestLogger
+ ( Destination(..)
+ , OutputFormat(..)
+ , RequestLoggerSettings(..)
+ , mkRequestLogger
+ )
+import Numeric.Natural(Natural)
+import Options.Applicative
+ ( Parser
+ , (<**>)
+ , (<|>)
+ , auto
+ , execParser
+ , fullDesc
+ , help
+ , helper
+ , info
+ , long
+ , some
+ , metavar
+ , option
+ , optional
+ , progDesc
+ , short
+ , strOption
+ , switch
+ )
+import Servant
+ ( (:<|>)(..)
+ , (:>)
+ , Capture
+ , FromHttpApiData(..)
+ , Get
+ , Header
+ , Headers
+ , QueryParam
+ , ServantErr
+ , ServerT
+ , ToHttpApiData(..)
+ , addHeader
+ , err404
+ , errBody
+ , serve
+ )
+import Servant.API.ContentTypes (AllCTRender(..), JSON)
+import Servant.Server (Handler(..), hoistServer)
+import Servant.Utils.Links (safeLink)
+import System.Directory (doesFileExist)
+import System.FilePath.Find
+ ( FileType(..)
+ , (&&?)
+ , (/=?)
+ , (==?)
+ , (==?)
+ , depth
+ , filePath
+ , fileType
+ , find
+ )
+import System.FilePath.Posix ((</>),takeFileName)
+import System.Log.FastLogger
+ ( LoggerSet
+ , defaultBufSize
+ , newFileLoggerSet
+ , newStdoutLoggerSet
+ )
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import qualified Text.Blaze.Html5 as Html hiding (html, source)
+
+--------------------------------------------------------------------------------
+-- Server config
+--------------------------------------------------------------------------------
+
+data ServerConfig = ServerConfig
+ { configPackagesPath :: !PackagesPath
+ , configPort :: !Int
+ , configServeStaticFiles :: !Bool
+ , configEnableExpressionInfo :: !Bool
+ , configIndexDirectoryName :: !(Maybe FilePath)
+ , configLog :: !HCE.Log
+ , configStaticFilesUrlPrefix :: !String
+ , configJsDistDirectory :: !(Maybe String)
+ , configMaxPerPage :: !Int
+ } deriving (Show, Eq)
+
+data PackagesPath
+ = DirectoryWithPackages FilePath
+ | Directories [FilePath]
+ deriving (Show, Eq)
+
+configParser :: Parser ServerConfig
+configParser =
+ ServerConfig <$>
+ ((DirectoryWithPackages <$>
+ strOption
+ (long "packages" <> metavar "PATH" <>
+ help "Path to a directory with Cabal packages")) <|>
+ Directories <$>
+ some
+ (strOption
+ (long "package" <> short 'p' <> metavar "PATH" <>
+ help "Path to a Cabal package"))) <*>
+ (pure 8080 <|>
+ option
+ auto
+ (long "port" <> help "Port to use (default is 8080)" <> metavar "PORT")) <*>
+ (not <$> switch (long "no-static" <> help "Do not serve static files")) <*>
+ (not <$>
+ switch
+ (long "no-expressions" <>
+ help "Disable queries that return expressions inside selected span")) <*>
+ optional
+ (strOption
+ (long "index-directory" <>
+ help
+ "Name of a directory with index (default is '.haskell-code-explorer')" <>
+ metavar "DIRECTORY_NAME")) <*>
+ (pure HCE.StdOut <|>
+ (HCE.ToFile <$>
+ strOption
+ (long "logfile" <>
+ help "Path to a log file (by default log is written to stdout)" <>
+ metavar "PATH"))) <*>
+ (pure "files" <|>
+ strOption
+ (long "static-url-prefix" <> metavar "STRING" <>
+ help "URL prefix for static files (default is 'files')")) <*>
+ optional
+ (strOption
+ (long "js-path" <> help "Path to a directory with javascript files" <>
+ metavar "PATH")) <*>
+ (pure 50 <|>
+ option
+ auto
+ (long "max-per-page" <> metavar "INTEGER" <>
+ help "Maximum number of items per page (default is 50)"))
+
+--------------------------------------------------------------------------------
+-- Loading packages
+--------------------------------------------------------------------------------
+
+data PackageVersions = PackageVersions
+ { name :: T.Text
+ , versions :: [Version]
+ } deriving (Show, Ord, Eq, Generic)
+
+type PackageMap
+ = HM.HashMap PackageName (M.Map Version (HCE.PackageInfo HCE.CompactModuleInfo))
+
+type PackagePathMap = HM.HashMap PackageId FilePath
+
+newtype AllPackages =
+ AllPackages BSL.ByteString
+
+newtype PackageId = PackageId
+ { getPackageId :: T.Text
+ } deriving (Show, Eq, Hashable)
+
+newtype PackageName = PackageName
+ { getPackageName :: T.Text
+ } deriving (Show, Eq, Hashable)
+
+instance A.ToJSON PackageVersions
+
+loadPackages ::
+ ServerConfig -> IO (Maybe (PackageMap, PackagePathMap, [PackageVersions]))
+loadPackages config = do
+ packageDirectories <-
+ case configPackagesPath config of
+ DirectoryWithPackages dir ->
+ find (depth ==? 0) (fileType ==? Directory &&? filePath /=? dir) dir
+ Directories dirs -> return dirs
+ result <- mapM (loadPackageInfo config) packageDirectories
+ let loadedPackages = rights result
+ packageLoadErrors = lefts result
+ packageInfos = map fst loadedPackages
+ packageIds =
+ map (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId) packageInfos
+ unless (null packageInfos) $ do
+ putStrLn "Loaded packages : "
+ mapM_ (print . HCE.packageIdToText) packageIds
+ unless (null packageLoadErrors) $ do
+ putStrLn "Package loading errors : "
+ mapM_ (\(err, path) -> putStrLn $ path ++ " : " ++ err) packageLoadErrors
+ if not . null $ loadedPackages
+ then do
+ let packageVersions =
+ L.sortOn (T.toLower . (name :: PackageVersions -> T.Text)) .
+ map
+ (\(name, versions) ->
+ PackageVersions name (L.sortOn Down versions)) .
+ HM.toList .
+ HM.fromListWith (++) .
+ map (\HCE.PackageId {..} -> (name, [version])) $
+ packageIds
+ packageMap =
+ L.foldl'
+ (\hMap packageInfo ->
+ let val = M.singleton (packageVersion packageInfo) packageInfo
+ in HM.insertWith M.union (packageName packageInfo) val hMap)
+ HM.empty
+ packageInfos
+ packagePathMap =
+ L.foldl'
+ (\hMap (packageInfo, path) ->
+ let key =
+ PackageId $
+ HCE.packageIdToText
+ (HCE.id
+ (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo))
+ in HM.insert key path hMap)
+ HM.empty
+ loadedPackages
+ packageMapCompacted <- ghcCompact packageMap
+ packagePathMapCompacted <- ghcCompact packagePathMap
+ packageVersionsCompacted <- ghcCompact packageVersions
+ return . Just $
+ (packageMapCompacted, packagePathMapCompacted, packageVersionsCompacted)
+ else return Nothing
+ where
+ packageName :: HCE.PackageInfo HCE.CompactModuleInfo -> PackageName
+ packageName =
+ PackageName .
+ (HCE.name :: HCE.PackageId -> T.Text) .
+ (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId)
+ packageVersion :: HCE.PackageInfo HCE.CompactModuleInfo -> Version
+ packageVersion =
+ HCE.version . (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId)
+
+ghcCompact :: forall a. a -> IO a
+ghcCompact =
+#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+ (fmap C.getCompact . C.compact)
+#else
+ return
+#endif
+
+loadPackageInfo ::
+ ServerConfig
+ -> String
+ -> IO (Either (String, FilePath) ( HCE.PackageInfo HCE.CompactModuleInfo
+ , FilePath))
+loadPackageInfo config path =
+ handleSync (\e -> return $ Left (show e, path)) $ do
+ let indexDirectory =
+ fromMaybe
+ HCE.defaultOutputDirectoryName
+ (configIndexDirectoryName config)
+ binaryContent <-
+ BS.readFile (path </> indexDirectory </> HCE.packageInfoBinaryFileName)
+ let eitherPackageInfo = Serialize.decode binaryContent
+ enableExpressionInfo = configEnableExpressionInfo config
+ case eitherPackageInfo of
+ Right packageInfo ->
+ return . Right $
+ ( updateEachModuleInfo
+ packageInfo
+ (\modInfo ->
+ let source =
+ HCE.source :: HCE.CompactModuleInfo -> V.Vector T.Text
+ in if not enableExpressionInfo
+ then modInfo
+ { HCE.exprInfoMap = IVM.empty
+ }
+ else modInfo)
+ , path)
+ Left e -> return . Left $ (e, path)
+
+updateEachModuleInfo ::
+ HCE.PackageInfo HCE.CompactModuleInfo
+ -> (HCE.CompactModuleInfo -> HCE.CompactModuleInfo)
+ -> HCE.PackageInfo HCE.CompactModuleInfo
+updateEachModuleInfo packageInfo update =
+ packageInfo {HCE.moduleMap = HM.map update $ HCE.moduleMap packageInfo}
+
+handleSync :: (SomeException -> IO a) -> IO a -> IO a
+handleSync onError =
+ handle
+ (\ex ->
+ case fromException ex of
+ Just (asyncEx :: SomeAsyncException) -> throwIO asyncEx
+ _ -> onError ex)
+
+--------------------------------------------------------------------------------
+-- Servant API
+--------------------------------------------------------------------------------
+
+type API = GetAllPackages
+ :<|> GetDefinitionSite
+ :<|> GetExpressions
+ :<|> GetReferences
+ :<|> GetIdentifiers
+
+type GetAllPackages = "api" :> "packages" :> Get '[JSON] AllPackages
+
+type GetDefinitionSite = "api" :> "definitionSite"
+ :> Capture "packageId" PackageId
+ :> Capture "componentId" HCE.ComponentId
+ :> Capture "moduleName" HCE.HaskellModuleName
+ :> Capture "entity" HCE.LocatableEntity
+ :> Capture "name" T.Text
+ :> Get '[JSON] HCE.DefinitionSite
+
+type GetExpressions = "api" :> "expressions"
+ :> Capture "packageId" PackageId
+ :> Capture "modulePath" HCE.HaskellModulePath
+ :> Capture "lineStart" Int
+ :> Capture "columnStart" Int
+ :> Capture "lineEnd" Int
+ :> Capture "columnEnd" Int
+ :> Get '[JSON] [Expression]
+
+type GetReferences = "api" :> "references"
+ :> Capture "packageId" PackageId
+ :> Capture "name" HCE.ExternalId
+ :> QueryParam "page" Int
+ :> QueryParam "per_page" Int
+ :> Get '[JSON] (Headers '[Header "Link" T.Text,Header "X-Total-Count" Int]
+ [SourceFile])
+
+type GetIdentifiers = "api" :> "identifiers"
+ :> Capture "packageId" PackageId
+ :> Capture "query" T.Text
+ :> QueryParam "page" Int
+ :> QueryParam "per_page" Int
+ :> Get '[JSON] (Headers '[Header "Link" T.Text,Header "X-Total-Count" Int]
+ [HCE.ExternalIdentifierInfo])
+
+instance AllCTRender '[ JSON] AllPackages where
+ handleAcceptH _ _ (AllPackages bytestring) =
+ Just ("application/json", bytestring)
+
+instance FromHttpApiData HCE.LocatableEntity where
+ parseQueryParam "Val" = Right HCE.Val
+ parseQueryParam "Typ" = Right HCE.Typ
+ parseQueryParam "Inst" = Right HCE.Inst
+ parseQueryParam "Mod" = Right HCE.Mod
+ parseQueryParam val = Left $ T.append "Incorrect LocatableEntity : " val
+
+instance ToHttpApiData HCE.LocatableEntity where
+ toUrlPiece HCE.Val = "ValueEntity"
+ toUrlPiece HCE.Typ = "TypeEntity"
+ toUrlPiece HCE.Inst = "InstanceEntity"
+ toUrlPiece HCE.Mod = "ModuleEntity"
+
+instance ToHttpApiData HCE.ExternalId where
+ toUrlPiece (HCE.ExternalId i) = i
+
+instance ToHttpApiData PackageId where
+ toUrlPiece (PackageId p) = p
+
+instance FromHttpApiData HCE.HaskellModulePath where
+ parseQueryParam = Right . HCE.HaskellModulePath
+
+instance FromHttpApiData HCE.ComponentId where
+ parseQueryParam = Right . HCE.ComponentId
+
+instance FromHttpApiData HCE.HaskellModuleName where
+ parseQueryParam = Right . HCE.HaskellModuleName
+
+instance FromHttpApiData HCE.ExternalId where
+ parseQueryParam = Right . HCE.ExternalId
+
+instance FromHttpApiData PackageId where
+ parseQueryParam = Right . PackageId
+
+--------------------------------------------------------------------------------
+-- Request handlers
+--------------------------------------------------------------------------------
+
+data Environment = Environment
+ { envLogger :: !LoggerSet
+ , envPackageMap :: !PackageMap
+ , envPackageVersions :: !AllPackages
+ , envConfig :: !ServerConfig
+ }
+
+data Expression = Expression
+ { srcSpan :: !(IVM.Interval (Int, Int))
+ , info :: !HCE.ExpressionInfo
+ } deriving (Show, Eq, Generic)
+
+instance A.ToJSON Expression
+
+data ReferenceWithSource = ReferenceWithSource
+ { sourceCodeHtml :: !T.Text
+ , idSrcSpan :: !HCE.IdentifierSrcSpan
+ } deriving (Show, Eq, Generic)
+
+data SourceFile = SourceFile
+ { name :: !T.Text
+ , references :: ![ReferenceWithSource]
+ } deriving (Show, Eq, Generic)
+
+instance A.ToJSON ReferenceWithSource
+instance A.ToJSON SourceFile
+
+getAllPackages :: ReaderT Environment IO AllPackages
+getAllPackages = asks envPackageVersions
+
+getPackageInfoAndModulePath ::
+ PackageId
+ -> HCE.ComponentId
+ -> HCE.HaskellModuleName
+ -> ReaderT Environment IO ( HCE.PackageInfo HCE.CompactModuleInfo
+ , HCE.HaskellModulePath)
+getPackageInfoAndModulePath packageId componentId moduleName =
+ withPackageInfo packageId $ \packageInfo ->
+ case HM.lookup moduleName (HCE.moduleNameMap packageInfo) of
+ Just modulePathMap ->
+ case HM.lookup componentId modulePathMap of
+ Just path -> return (packageInfo, path)
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Module "
+ , toLazyBS $ HCE.getHaskellModuleName moduleName
+ , " not found in component "
+ , toLazyBS $ HCE.getComponentId componentId
+ ]
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Module "
+ , toLazyBS $ HCE.getHaskellModuleName moduleName
+ , " not found in package "
+ , toLazyBS $ getPackageId packageId
+ ]
+
+getExpressions ::
+ PackageId
+ -> HCE.HaskellModulePath
+ -> Int -- ^ Start line
+ -> Int -- ^ Start column
+ -> Int -- ^ End line
+ -> Int -- ^ End column
+ -> ReaderT Environment IO [Expression]
+getExpressions packageId modulePath startLine startColumn endLine endColumn = do
+ enableExpressionInfo <- asks (configEnableExpressionInfo . envConfig)
+ if not enableExpressionInfo
+ then error404 "Expression queries are disabled"
+ else withPackageInfo packageId $ \packageInfo ->
+ withModuleInfo packageInfo modulePath $ \modInfo -> do
+ maxPerPage <- asks (configMaxPerPage . envConfig)
+ let exprInfoMap =
+ HCE.exprInfoMap (modInfo :: HCE.CompactModuleInfo)
+ requestedInterval =
+ IVM.ClosedInterval
+ (startLine, startColumn)
+ (endLine, endColumn)
+ return .
+ map (uncurry Expression) .
+ L.take maxPerPage . IVM.toList . IVM.within exprInfoMap $
+ requestedInterval
+
+getDefinitionSite ::
+ PackageId
+ -> HCE.ComponentId
+ -> HCE.HaskellModuleName
+ -> HCE.LocatableEntity
+ -> T.Text
+ -> ReaderT Environment IO HCE.DefinitionSite
+getDefinitionSite packageId componentId modName entity name =
+ withPackageInfo packageId $ \packageInfo ->
+ withModulePath packageInfo componentId modName $ \modPath ->
+ case entity of
+ HCE.Mod ->
+ return $
+ HCE.DefinitionSite
+ (HCE.ExactLocation
+ (HCE.id (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo))
+ modPath
+ modName
+ 1
+ 1
+ 1
+ 1)
+ Nothing
+ _ ->
+ withModuleInfo packageInfo modPath $ \modInfo -> do
+ let defSites =
+ HCE.definitionSiteMap (modInfo :: HCE.CompactModuleInfo)
+ mbDefinitionSite =
+ case entity of
+ HCE.Typ ->
+ HM.lookup (HCE.OccName name) $
+ HCE.types (defSites :: HCE.DefinitionSiteMap)
+ HCE.Val ->
+ HM.lookup (HCE.OccName name) $
+ HCE.values (defSites :: HCE.DefinitionSiteMap)
+ HCE.Inst ->
+ HM.lookup name $
+ HCE.instances (defSites :: HCE.DefinitionSiteMap)
+ _ -> Nothing
+ case mbDefinitionSite of
+ Just definitionSite -> return definitionSite
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ toLazyBS . T.pack $ show entity
+ , " "
+ , toLazyBS name
+ , " "
+ , " not found in a module "
+ , toLazyBS $ HCE.getHaskellModulePath modPath
+ ]
+
+buildLinkHeader :: T.Text -> Paginated a -> Natural -> Natural -> T.Text
+buildLinkHeader url paginated currentPage perPage =
+ T.intercalate
+ ","
+ (let addFirst
+ | currentPage /= 1 =
+ (:) (link (T.append url $ params 1 perPage) "first")
+ | otherwise = id
+ addLast
+ | currentPage /= paginatedPagesTotal paginated =
+ (:)
+ (link
+ (T.append url $ params (paginatedPagesTotal paginated) perPage)
+ "last")
+ | otherwise = id
+ addNext
+ | hasNextPage paginated =
+ (:) (link (T.append url $ params (currentPage + 1) perPage) "next")
+ | otherwise = id
+ addPrev
+ | hasPrevPage paginated =
+ (:) (link (T.append url $ params (currentPage - 1) perPage) "prev")
+ | otherwise = id
+ in addFirst . addLast . addNext . addPrev $ [])
+ where
+ link :: T.Text -> T.Text -> T.Text
+ link u rel = T.concat ["<", u, ">; rel=\"", rel, "\""]
+ params :: Natural -> Natural -> T.Text
+ params p pp =
+ T.concat ["?page=", T.pack . show $ p, "&per_page=", T.pack . show $ pp]
+
+initializePagination ::
+ (MonadReader Environment m)
+ => Maybe Int
+ -> Maybe Int
+ -> m (Natural, Natural)
+initializePagination mbPage mbPerPage = do
+ maxPerPage <- asks (configMaxPerPage . envConfig)
+ let page =
+ case mbPage of
+ Just p ->
+ if p > 0
+ then p
+ else 1
+ Nothing -> 1
+ perPage =
+ case mbPerPage of
+ Just pp ->
+ if pp <= maxPerPage && pp > 0
+ then pp
+ else maxPerPage
+ Nothing -> maxPerPage
+ return (fromIntegral page, fromIntegral perPage)
+
+getReferences ::
+ PackageId
+ -> HCE.ExternalId
+ -> Maybe Int -- ^ Page number
+ -> Maybe Int -- ^ Items per page
+ -> ReaderT Environment IO (Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] [SourceFile])
+getReferences packageId externalId mbPage mbPerPage =
+ withPackageInfo packageId $ \packageInfo ->
+ case S.toList <$> HM.lookup externalId (HCE.externalIdOccMap packageInfo) of
+ Just references -> do
+ (page, perPage) <- initializePagination mbPage mbPerPage
+ pagination <- mkPagination perPage page
+ let totalCount = L.length references
+ paginatedReferences <-
+ paginate
+ pagination
+ (fromIntegral totalCount)
+ (\offset limit -> return . L.take limit . L.drop offset $ references)
+ let url =
+ T.append "/" $
+ toUrlPiece $
+ safeLink
+ (Proxy :: Proxy API)
+ (Proxy :: Proxy GetReferences)
+ packageId
+ externalId
+ Nothing
+ Nothing
+ linkHeader = buildLinkHeader url paginatedReferences page perPage
+ addHeaders ::
+ forall a.
+ a
+ -> Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] a
+ addHeaders = addHeader linkHeader . addHeader totalCount
+ refModulePath :: ReferenceWithSource -> HCE.HaskellModulePath
+ refModulePath =
+ (HCE.modulePath :: HCE.IdentifierSrcSpan -> HCE.HaskellModulePath) .
+ idSrcSpan
+ return $
+ addHeaders $
+ concatMap
+ (\refs ->
+ case refs of
+ ref:_ ->
+ let path =
+ HCE.getHaskellModulePath .
+ (HCE.modulePath :: HCE.IdentifierSrcSpan -> HCE.HaskellModulePath) .
+ idSrcSpan $
+ ref
+ in [SourceFile path refs]
+ _ -> []) $
+ groupWith refModulePath $
+ map
+ (mkReferenceWithSource packageInfo)
+ (paginatedItems paginatedReferences)
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Cannot find references to "
+ , toLazyBS $ HCE.getExternalId externalId
+ ]
+
+mkReferenceWithSource ::
+ HCE.PackageInfo HCE.CompactModuleInfo
+ -> HCE.IdentifierSrcSpan
+ -> ReferenceWithSource
+mkReferenceWithSource packageInfo idSrcSpan =
+ let mbModule =
+ HM.lookup
+ (HCE.modulePath (idSrcSpan :: HCE.IdentifierSrcSpan))
+ (HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo))
+ in case mbModule of
+ Just modInfo ->
+ let sourceCodeHtml =
+ buildHtmlCodeSnippet
+ (HCE.source (modInfo :: HCE.CompactModuleInfo))
+ (HCE.line (idSrcSpan :: HCE.IdentifierSrcSpan))
+ (HCE.startColumn (idSrcSpan :: HCE.IdentifierSrcSpan))
+ (HCE.endColumn (idSrcSpan :: HCE.IdentifierSrcSpan))
+ in ReferenceWithSource sourceCodeHtml idSrcSpan
+ _ -> ReferenceWithSource "" idSrcSpan
+
+buildHtmlCodeSnippet :: V.Vector T.Text -> Int -> Int -> Int -> T.Text
+buildHtmlCodeSnippet sourceLines lineNumber startColumn endColumn =
+ toStrict $
+ renderHtml $ do
+ mkLineNumber (lineNumber - 1) >>
+ Html.toHtml
+ (T.append (fromMaybe "" $ (V.!?) sourceLines (lineNumber - 2)) "\n")
+ mkLineNumber lineNumber >>
+ highlightIdentifier
+ (T.append (fromMaybe "" $ (V.!?) sourceLines (lineNumber - 1)) "\n")
+ mkLineNumber (lineNumber + 1) >>
+ Html.toHtml (T.append (fromMaybe "" $ (V.!?) sourceLines lineNumber) "\n")
+ where
+ mkLineNumber :: Int -> Html.Html
+ mkLineNumber i = Html.toHtml (show i ++ " ")
+ highlightIdentifier :: T.Text -> Html.Html
+ highlightIdentifier line =
+ let (startLine, remaining) = T.splitAt (startColumn - 1) line
+ (identifier, endLine) = T.splitAt (endColumn - startColumn) remaining
+ in Html.toHtml startLine >> Html.b (Html.toHtml identifier) >>
+ Html.toHtml endLine
+
+findIdentifiers ::
+ PackageId
+ -> T.Text
+ -> Maybe Int
+ -> Maybe Int
+ -> ReaderT Environment IO (Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int]
+ [HCE.ExternalIdentifierInfo])
+findIdentifiers packageId query mbPage mbPerPage =
+ withPackageInfo packageId $ \packageInfo -> do
+ let identifiers
+ | not $ T.null query =
+ S.toList $
+ HCE.match (T.unpack query) (HCE.externalIdInfoMap packageInfo)
+ | otherwise = []
+ (page, perPage) <- initializePagination mbPage mbPerPage
+ let totalCount = L.length identifiers
+ pagination <- mkPagination perPage page
+ paginatedIdentifiers <-
+ paginate
+ pagination
+ (fromIntegral totalCount)
+ (\offset limit -> return . L.take limit . L.drop offset $ identifiers)
+ let url =
+ T.append "/" $
+ toUrlPiece $
+ safeLink
+ (Proxy :: Proxy API)
+ (Proxy :: Proxy GetIdentifiers)
+ packageId
+ query
+ Nothing
+ Nothing
+ linkHeader = buildLinkHeader url paginatedIdentifiers page perPage
+ addHeaders ::
+ forall a.
+ a
+ -> Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] a
+ addHeaders = addHeader linkHeader . addHeader totalCount
+ return . addHeaders . paginatedItems $ paginatedIdentifiers
+
+error404 :: BSL.ByteString -> ReaderT Environment IO a
+error404 body = throwServantError $ err404 {errBody = body}
+
+toLazyBS :: T.Text -> BSL.ByteString
+toLazyBS = BSL.fromStrict . TE.encodeUtf8
+
+withPackageInfo ::
+ PackageId
+ -> (HCE.PackageInfo HCE.CompactModuleInfo -> ReaderT Environment IO a)
+ -> ReaderT Environment IO a
+withPackageInfo packageId action
+ | Just (packageName, mbVersion) <- parsePackageId packageId = do
+ packageMap <- asks envPackageMap
+ let mbPackageInfo =
+ HM.lookup packageName packageMap >>=
+ (\packages ->
+ let findLastVersion :: M.Map k v -> Maybe v
+ findLastVersion = fmap (snd . fst) . L.uncons . M.toDescList
+ in case mbVersion of
+ Just version ->
+ M.lookup version packages <|> findLastVersion packages
+ Nothing -> findLastVersion packages)
+ case mbPackageInfo of
+ Just p -> action p
+ Nothing -> packageNotFound packageId
+withPackageInfo packageId _ = packageNotFound packageId
+
+packageNotFound :: PackageId -> ReaderT Environment IO a
+packageNotFound packageId =
+ error404 $
+ BSL.concat ["Package ", toLazyBS $ getPackageId packageId, " is not found."]
+
+withModuleInfo ::
+ HCE.PackageInfo HCE.CompactModuleInfo
+ -> HCE.HaskellModulePath
+ -> (HCE.CompactModuleInfo -> ReaderT Environment IO a)
+ -> ReaderT Environment IO a
+withModuleInfo packageInfo path action =
+ case HM.lookup
+ path
+ (HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) of
+ Just modInfo -> action modInfo
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Module "
+ , toLazyBS $ HCE.getHaskellModulePath path
+ , " is not found in package "
+ , toLazyBS $
+ HCE.packageIdToText $
+ HCE.id (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)
+ ]
+
+withModulePath ::
+ HCE.PackageInfo HCE.CompactModuleInfo
+ -> HCE.ComponentId
+ -> HCE.HaskellModuleName
+ -> (HCE.HaskellModulePath -> ReaderT Environment IO a)
+ -> ReaderT Environment IO a
+withModulePath packageInfo componentId moduleName action =
+ case HM.lookup
+ (ghcPrimHack packageInfo moduleName)
+ (HCE.moduleNameMap packageInfo) of
+ Just modulePathMap ->
+ case HM.lookup componentId modulePathMap of
+ Just path -> action path
+ Nothing ->
+ case HM.lookup (HCE.ComponentId "lib") modulePathMap of
+ Just path -> action path
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Module "
+ , toLazyBS $ HCE.getHaskellModuleName moduleName
+ , " is not found in component "
+ , toLazyBS $ HCE.getComponentId componentId
+ ]
+ Nothing ->
+ error404 $
+ BSL.concat
+ [ "Module "
+ , toLazyBS $ HCE.getHaskellModuleName moduleName
+ , " is not found in package "
+ , toLazyBS $
+ HCE.packageIdToText $
+ HCE.id (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)
+ ]
+
+-- | Workaround for :
+-- https://github.com/ghc/ghc/blob/ghc-8.2.2-release/compiler/main/Finder.hs#L310-L315
+ghcPrimHack ::
+ HCE.PackageInfo HCE.CompactModuleInfo
+ -> HCE.HaskellModuleName
+ -> HCE.HaskellModuleName
+ghcPrimHack packageInfo (HCE.HaskellModuleName modName)
+ | HCE.packageName packageInfo == "ghc-prim" && modName == "GHC.Prim" =
+ HCE.HaskellModuleName "GHC.Prim_"
+ | otherwise = HCE.HaskellModuleName modName
+
+parsePackageId :: PackageId -> Maybe (PackageName, Maybe Version)
+parsePackageId (PackageId text) =
+ case T.splitOn "-" text of
+ [name] -> Just (PackageName name, Nothing)
+ chunks@(_x:_xs) ->
+ case mapM decimal . T.splitOn "." . last $ chunks of
+ Right numbers ->
+ Just
+ ( PackageName $ T.intercalate "-" . init $ chunks
+ , Just $ Version (map fst numbers) [])
+ Left _ -> Just (PackageName text, Nothing)
+ _ -> Nothing
+
+staticMiddleware :: String -> PackagePathMap -> Maybe FilePath -> Middleware
+staticMiddleware staticFilesPrefix packagePathMap _ app req callback
+ | ("api":_) <- pathInfo req = app req callback
+ | (prefix:packageId:rest) <- pathInfo req
+ , prefix == T.pack staticFilesPrefix =
+ case HM.lookup (PackageId packageId) packagePathMap of
+ Just basePath
+ | ".." `notElem` rest -> do
+ let clientAcceptsEncoding =
+ fromMaybe [] $
+ map T.strip . T.splitOn "," . TE.decodeUtf8 <$>
+ lookup "Accept-Encoding" (requestHeaders req)
+ clientAcceptsGzip = "gzip" `elem` clientAcceptsEncoding
+ path = basePath </> T.unpack (T.intercalate "/" rest)
+ gzPath = path ++ ".gz"
+ sendGzipFile <-
+ if clientAcceptsGzip
+ then doesFileExist gzPath
+ else return False
+ if sendGzipFile
+ then callback $
+ responseFile
+ status200
+ [ (hContentEncoding, "gzip")
+ , ( hContentType
+ , defaultMimeLookup . T.pack . takeFileName $ path)
+ ]
+ gzPath
+ Nothing
+ else do
+ exists <- doesFileExist path
+ if exists
+ then callback $ sendFile path
+ else callback fileNotFound
+ _ -> callback fileNotFound
+staticMiddleware _ _ mbJsDistPath _app req callback =
+ case mbJsDistPath of
+ Just jsDistPath -> do
+ let path = jsDistPath </> T.unpack (T.intercalate "/" $ pathInfo req)
+ exists <- doesFileExist path
+ if exists
+ then callback $ sendFile path
+ else callback $ sendFile (jsDistPath </> "index.html")
+ Nothing -> callback fileNotFound
+
+sendFile :: FilePath -> Response
+sendFile path =
+ responseFile
+ status200
+ [(hContentType, defaultMimeLookup $ T.pack $ takeFileName path)]
+ path
+ Nothing
+
+fileNotFound :: Response
+fileNotFound =
+ responseLBS status404 [("Content-Type", "text/plain")] "Not found"
+
+throwServantError :: (MonadIO m) => ServantErr -> m a
+throwServantError = liftIO . throwIO
+
+server :: Environment -> ServerT API Handler
+server env =
+ hoistServer
+ (Proxy :: Proxy API)
+ toServantHandler
+ (getAllPackages :<|>
+ getDefinitionSite :<|>
+ getExpressions :<|>
+ getReferences :<|>
+ findIdentifiers)
+ where
+ toServantHandler :: ReaderT Environment IO a -> Handler a
+ toServantHandler ma = Handler . ExceptT . try . runReaderT ma $ env
+
+application :: Environment -> Application
+application env = serve (Proxy :: Proxy API) (server env)
+
+main :: IO ()
+main = do
+ config <-
+ execParser
+ (Options.Applicative.info
+ (configParser <**> helper)
+ (fullDesc <>
+ progDesc
+ "haskell-code-server provides an HTTP API for Haskell code explorer"))
+ print config
+ packages <- loadPackages config
+ case packages of
+ Just (packageMap, packagePathMap, packageVersions) -> do
+ loggerSet <-
+ case configLog config of
+ HCE.ToFile logfile -> newFileLoggerSet defaultBufSize logfile
+ HCE.StdOut -> newStdoutLoggerSet defaultBufSize
+ loggerMiddleware <-
+ liftIO $
+ mkRequestLogger
+ def {outputFormat = Detailed True, destination = Logger loggerSet}
+ let staticFilePrefix = configStaticFilesUrlPrefix config
+ mbJsDistPath = configJsDistDirectory config
+ environment =
+ Environment
+ loggerSet
+ packageMap
+ (AllPackages . A.encode $ packageVersions)
+ config
+ static =
+ if configServeStaticFiles config
+ then staticMiddleware staticFilePrefix packagePathMap mbJsDistPath
+ else id
+ run
+ (configPort config)
+ (loggerMiddleware . static $ application environment)
+ Nothing -> putStrLn "No packages found."