Initial commit

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."