2018-10-02 13:17:04 +03:00
{- # LANGUAGE CPP # -}
2018-11-07 18:31:43 +03:00
{- # LANGUAGE TemplateHaskell # -}
2019-01-23 17:18:29 +03:00
{- # LANGUAGE TypeFamilies # -}
2018-11-16 16:19:03 +03:00
{- # LANGUAGE TupleSections # -}
2018-10-02 13:17:04 +03:00
{- # LANGUAGE FlexibleInstances # -}
{- # LANGUAGE FlexibleContexts # -}
{- # LANGUAGE ScopedTypeVariables # -}
{- # LANGUAGE RankNTypes # -}
{- # LANGUAGE RecordWildCards # -}
{- # LANGUAGE MultiParamTypeClasses # -}
{- # LANGUAGE DataKinds # -}
{- # LANGUAGE TypeOperators # -}
{- # LANGUAGE DuplicateRecordFields # -}
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE DeriveGeneric # -}
{- # LANGUAGE GeneralizedNewtypeDeriving # -}
2019-02-06 21:42:29 +03:00
{- # LANGUAGE NamedFieldPuns # -}
2019-02-20 18:58:57 +03:00
{- # LANGUAGE PatternGuards # -}
2018-10-02 13:17:04 +03:00
{- # OPTIONS_GHC - fno - warn - orphans # -}
module Main where
2019-01-23 17:18:29 +03:00
import Control.DeepSeq ( NFData , force )
2018-10-02 13:17:04 +03:00
import Control.Exception
( SomeAsyncException
, SomeException
, fromException
, handle
, throwIO
, throwIO
, try
)
2019-02-20 18:58:57 +03:00
import Control.Lens hiding ( children , index )
2019-01-23 17:18:29 +03:00
import Control.Monad ( foldM , unless )
2018-10-02 13:17:04 +03:00
import Control.Monad.Except ( ExceptT ( .. ) )
import Control.Monad.Reader ( MonadIO , MonadReader , ReaderT ( .. ) , asks , liftIO )
2019-02-20 18:58:57 +03:00
import Control.Monad.State.Strict ( StateT ( .. ) )
2018-10-02 13:17:04 +03:00
import qualified Data.Aeson as A
2019-02-20 18:58:57 +03:00
import qualified Data.Aeson.Lens as AL
2018-10-02 13:17:04 +03:00
import qualified Data.ByteString as BS
2019-01-23 17:18:29 +03:00
import qualified Data.ByteString.Char8 as BSC
2018-10-02 13:17:04 +03:00
import qualified Data.ByteString.Lazy as BSL
2019-02-20 18:58:57 +03:00
import qualified Data.ByteString.Short as BSS
2018-10-02 13:17:04 +03:00
import Data.Default ( def )
import Data.Either ( lefts , rights )
import qualified Data.HashMap.Strict as HM
import Data.Hashable ( Hashable )
2019-01-23 17:18:29 +03:00
import Data.IntervalMap.Interval ( Interval ( .. ) , subsumes )
2019-02-20 18:58:57 +03:00
import qualified Data.IntervalMap.Strict as IVM
2018-10-02 13:17:04 +03:00
import qualified Data.List as L
import qualified Data.Map.Strict as M
2018-10-25 01:30:30 +03:00
import Data.Maybe ( fromMaybe , mapMaybe )
2018-11-07 18:31:43 +03:00
import qualified Data.Vector as V
2018-10-02 13:17:04 +03:00
# if MIN_VERSION_GLASGOW_HASKELL ( 8 , 4 , 3 , 0 )
import qualified GHC.Compact as C
# 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
2019-01-23 17:18:29 +03:00
import Network.HTTP.Types ( hContentEncoding , hContentType , status200 , status404 )
2019-02-20 18:58:57 +03:00
import Network.URI.Encode ( encode )
2018-10-02 13:17:04 +03:00
import Network.Mime ( defaultMimeLookup )
import Network.Wai
( Application
, Middleware
, Response
, pathInfo
2019-01-23 17:18:29 +03:00
, requestHeaders
2018-10-02 13:17:04 +03:00
, responseFile
, responseLBS
)
import Network.Wai.Handler.Warp ( run )
2019-02-20 18:58:57 +03:00
import qualified Network.Wreq as Wreq
2018-10-02 13:17:04 +03:00
import Network.Wai.Middleware.RequestLogger
( Destination ( .. )
, OutputFormat ( .. )
, RequestLoggerSettings ( .. )
, mkRequestLogger
)
import Numeric.Natural ( Natural )
import Options.Applicative
( Parser
, ( <**> )
, ( <|> )
, auto
, execParser
, fullDesc
, help
, helper
, info
2019-01-23 17:18:29 +03:00
, long
2018-10-02 13:17:04 +03:00
, metavar
, option
, optional
, progDesc
, short
2019-01-23 17:18:29 +03:00
, some
2018-10-02 13:17:04 +03:00
, strOption
, switch
)
import Servant
( ( :<|> ) ( .. )
, ( :> )
, Capture
, FromHttpApiData ( .. )
, Get
, Header
, Headers
, QueryParam
2019-08-21 12:59:18 +03:00
# if MIN_VERSION_GLASGOW_HASKELL ( 8 , 6 , 5 , 0 )
, ServerError
# else
2018-10-02 13:17:04 +03:00
, ServantErr
2019-08-21 12:59:18 +03:00
# endif
2018-10-02 13:17:04 +03:00
, ServerT
, ToHttpApiData ( .. )
, addHeader
, err404
2019-01-23 17:18:29 +03:00
, err500
2019-02-20 18:58:57 +03:00
, err502
2018-10-02 13:17:04 +03:00
, errBody
, serve
)
import Servant.API.ContentTypes ( AllCTRender ( .. ) , JSON )
import Servant.Server ( Handler ( .. ) , hoistServer )
2019-05-17 18:43:42 +03:00
# if MIN_VERSION_servant ( 0 , 14 , 1 )
import Servant.Links ( safeLink )
# else
2018-10-02 13:17:04 +03:00
import Servant.Utils.Links ( safeLink )
2019-05-17 18:43:42 +03:00
# endif
2018-10-02 13:17:04 +03:00
import System.Directory ( doesFileExist )
2019-01-23 17:18:29 +03:00
import System.Exit ( exitFailure , exitSuccess )
2018-10-02 13:17:04 +03:00
import System.FilePath.Find
( FileType ( .. )
, ( &&? )
, ( /=? )
, ( ==? )
, ( ==? )
, depth
, filePath
, fileType
, find
)
2019-01-23 17:18:29 +03:00
import System.FilePath.Posix ( ( </> ) , takeFileName )
2018-10-02 13:17:04 +03:00
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 )
2018-11-07 18:31:43 +03:00
import Data.FileEmbed ( embedDir , embedFile )
2019-01-23 17:18:29 +03:00
import Data.Bifunctor ( second )
import qualified Store
2018-10-02 13:17:04 +03:00
--------------------------------------------------------------------------------
-- 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
2019-01-23 17:18:29 +03:00
, configStore :: ! ( Maybe Store )
2019-02-20 18:58:57 +03:00
, configUseHoogleApi :: ! Bool
2018-10-02 13:17:04 +03:00
} deriving ( Show , Eq )
2019-03-26 16:45:25 +03:00
data PackagesPath = PackagesPath
{ pathDirWithPackages :: ! ( Maybe FilePath )
-- ^ Path to a directory containing Cabal package subdirectories.
, pathPackages :: ! [ FilePath ]
-- ^ Paths to Cabal packages.
} deriving ( Show , Eq )
2018-10-02 13:17:04 +03:00
2019-01-23 17:18:29 +03:00
data Store
= CreateStore FilePath
| UseStore FilePath
| UseStoreMmap FilePath
deriving ( Show , Eq )
2018-10-02 13:17:04 +03:00
configParser :: Parser ServerConfig
configParser =
ServerConfig <$>
2019-03-26 16:45:25 +03:00
parsePackagesPath
( strOption
2018-10-02 13:17:04 +03:00
( long " packages " <> metavar " PATH " <>
2019-03-26 16:45:25 +03:00
help " Path to a directory with Cabal packages " ) )
( some
( strOption
2018-10-02 13:17:04 +03:00
( long " package " <> short 'p' <> metavar " PATH " <>
2019-03-26 16:45:25 +03:00
help " Path to a Cabal package (defaults to '.' if 'packages' not provided either) " ) ) ) <*>
2018-10-02 13:17:04 +03:00
( 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 " <>
2019-05-26 18:19:35 +03:00
help " Disable queries that return expressions inside selected span (reduces memory usage) " ) ) <*>
2018-10-02 13:17:04 +03:00
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
2019-05-26 18:19:35 +03:00
( long " js-path " <> help " Path to a directory with javascript files (by default, the server uses javascript files that are embedded in the executable) " <>
2018-10-02 13:17:04 +03:00
metavar " PATH " ) ) <*>
( pure 50 <|>
option
auto
( long " max-per-page " <> metavar " INTEGER " <>
2019-01-23 17:18:29 +03:00
help " Maximum number of items per page (default is 50) " ) ) <*>
optional
( CreateStore <$>
strOption
( long " create-store " <>
2019-05-26 18:19:35 +03:00
help " Create a key-value store from PackageInfo of each indexed package. The key-value store allows to significantly reduce memory usage of the server (3x times for a real-world set of Haskell packages). " <>
2019-01-23 17:18:29 +03:00
metavar " PATH_TO_DATA_DIRECTORY " ) <|>
( UseStore <$>
strOption
( long " use-store " <>
help " Use existing key-value store. Read 'values' file into memory. " <>
metavar " PATH_TO_DATA_DIRECTORY " ) ) <|>
( UseStoreMmap <$>
strOption
( long " use-store-mmap " <>
2019-05-26 18:19:35 +03:00
help " Use existing key-value store. Memory map 'values' file (the server uses less memory but may be slower to respond to requests). " <>
2019-02-20 18:58:57 +03:00
metavar " PATH_TO_DATA_DIRECTORY " ) ) ) <*>
switch
( long " use-hoogle-api " <>
help
" Use public Hoogle JSON API (https://github.com/ndmitchell/hoogle/blob/3dbf68bfd701f942d3af2e6debb74a0a78cd392e/docs/API.md#json-api) to get documentation for not indexed packages (disabled by default) " )
2018-10-02 13:17:04 +03:00
2019-03-26 16:45:25 +03:00
parsePackagesPath :: Parser FilePath -> Parser [ FilePath ] -> Parser PackagesPath
parsePackagesPath parseDir parsePaths =
2019-03-26 17:07:04 +03:00
PackagesPath <$> optional parseDir <*> ( parsePaths <|> pure [] )
2019-03-26 16:45:25 +03:00
2018-10-02 13:17:04 +03:00
--------------------------------------------------------------------------------
-- Loading packages
--------------------------------------------------------------------------------
data PackageVersions = PackageVersions
{ name :: T . Text
, versions :: [ Version ]
} deriving ( Show , Ord , Eq , Generic )
2019-01-23 17:18:29 +03:00
instance Serialize . Serialize PackageVersions
data PackageMap
= PackageMap ( HM . HashMap PackageName ( M . Map Version ( HCE . PackageInfo HCE . CompactModuleInfo ) ) )
| PackageMapStore { store :: Store . Store
, packageMap :: HM . HashMap PackageName ( M . Map Version HCE . PackageId ) }
2018-10-02 13:17:04 +03:00
type PackagePathMap = HM . HashMap PackageId FilePath
2019-01-23 17:18:29 +03:00
newtype AllPackages = AllPackages BSL . ByteString
2018-10-02 13:17:04 +03:00
newtype PackageId = PackageId
{ getPackageId :: T . Text
2019-01-23 17:18:29 +03:00
} deriving ( Show , Eq , Hashable , Generic , NFData )
instance Serialize . Serialize PackageId
2018-10-02 13:17:04 +03:00
newtype PackageName = PackageName
{ getPackageName :: T . Text
2019-01-23 17:18:29 +03:00
} deriving ( Show , Eq , Hashable , Generic , NFData )
instance Serialize . Serialize PackageName
2018-10-02 13:17:04 +03:00
instance A . ToJSON PackageVersions
2019-02-06 21:42:29 +03:00
type GlobalReferenceMap = HM . HashMap HCE . ExternalId ( S . Set GlobalReferences )
type GlobalIdentifierMap = HCE . Trie Char HCE . ExternalIdentifierInfo
2018-11-16 16:19:03 +03:00
data GlobalReferences = GlobalReferences
{ count :: Int
, packageId :: T . Text
} deriving ( Show , Eq , Ord , Generic )
2019-01-23 17:18:29 +03:00
instance NFData GlobalReferences
instance Serialize . Serialize GlobalReferences
2018-11-16 16:19:03 +03:00
instance A . ToJSON GlobalReferences
2019-01-23 17:18:29 +03:00
instance Store . StoreItem ( HCE . Trie Char HCE . ExternalIdentifierInfo ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( HCE . Trie Char HCE . ExternalIdentifierInfo ) =
( HCE . PackageId
, String
, Proxy ( HCE . Trie Char HCE . ExternalIdentifierInfo ) )
itemKey ( packageId , prefix , _ ) =
BSS . toShort $ BS . concat
[ " externalIdInfoMap "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, BSC . pack prefix
]
instance Store . StoreItem [ HCE . ExternalIdentifierInfo ] where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs [ HCE . ExternalIdentifierInfo ] = ( HCE . PackageId
, String
, Proxy [ HCE . ExternalIdentifierInfo ] )
itemKey ( packageId , prefix , _ ) =
BSS . toShort $ BS . concat
[ " externalIdInfo "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, BSC . pack prefix
2019-08-21 13:03:31 +03:00
]
2019-01-23 17:18:29 +03:00
instance Store . StoreItem ( S . Set HCE . IdentifierSrcSpan ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( S . Set HCE . IdentifierSrcSpan ) = ( HCE . PackageId
, HCE . ExternalId
, Proxy ( S . Set HCE . IdentifierSrcSpan ) )
itemKey ( packageId , HCE . ExternalId extId , _ ) =
BSS . toShort $ BS . concat
[ " externalIdOcc "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, TE . encodeUtf8 extId
]
instance Store . StoreItem ( HM . HashMap HCE . HaskellModuleName ( HM . HashMap HCE . ComponentId HCE . HaskellModulePath ) ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( HM . HashMap HCE . HaskellModuleName ( HM . HashMap HCE . ComponentId HCE . HaskellModulePath ) ) =
( HCE . PackageId
, Proxy ( HM . HashMap HCE . HaskellModuleName ( HM . HashMap HCE . ComponentId HCE . HaskellModulePath ) ) )
itemKey ( packageId , _ ) =
BSS . toShort $ BS . append " moduleNameMap| " $ TE . encodeUtf8 $ HCE . packageIdToText packageId
instance ( Serialize . Serialize modInfo ) =>
Store . StoreItem ( HM . HashMap HCE . HaskellModulePath modInfo ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( HM . HashMap HCE . HaskellModulePath modInfo ) =
2019-08-21 13:03:31 +03:00
( HCE . PackageId , Proxy ( HM . HashMap HCE . HaskellModulePath modInfo ) )
2019-01-23 17:18:29 +03:00
itemKey ( packageId , _ ) =
BSS . toShort $ BS . append " moduleMap| " $ TE . encodeUtf8 $ HCE . packageIdToText packageId
instance Store . StoreItem HCE . ExpressionInfoMap where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs HCE . ExpressionInfoMap = ( HCE . PackageId
, HCE . HaskellModulePath
2019-08-21 13:03:31 +03:00
, BS . ByteString
2019-01-23 17:18:29 +03:00
, Proxy HCE . ExpressionInfoMap )
itemKey ( packageId , HCE . HaskellModulePath modulePath , topLevelExprKey , _ ) =
BSS . toShort $ BS . concat
[ " exprInfoMap "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, TE . encodeUtf8 modulePath
, " | "
2019-08-21 13:03:31 +03:00
, topLevelExprKey
2019-01-23 17:18:29 +03:00
]
instance Store . StoreItem ( IVM . IntervalMap ( Int , Int ) BS . ByteString ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( IVM . IntervalMap ( Int , Int ) BS . ByteString ) =
( HCE . PackageId
, HCE . HaskellModulePath
, Proxy ( IVM . IntervalMap ( Int , Int ) BS . ByteString ) )
itemKey ( packageId , HCE . HaskellModulePath modulePath , _ ) =
BSS . toShort $ BS . concat
[ " topLevelExpr "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, TE . encodeUtf8 modulePath
]
2019-08-21 13:03:31 +03:00
2019-01-23 17:18:29 +03:00
instance Store . StoreItem HCE . DefinitionSiteMap where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs HCE . DefinitionSiteMap = ( HCE . PackageId
, HCE . HaskellModulePath
, Proxy HCE . DefinitionSiteMap )
itemKey ( packageId , HCE . HaskellModulePath modulePath , _ ) =
BSS . toShort $ BS . concat
[ " definitionSiteMap "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, TE . encodeUtf8 modulePath
]
2019-08-21 13:03:31 +03:00
2019-01-23 17:18:29 +03:00
instance Store . StoreItem ( V . Vector T . Text ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( V . Vector T . Text ) = ( HCE . PackageId
, HCE . HaskellModulePath
, Proxy ( V . Vector T . Text ) )
itemKey ( packageId , HCE . HaskellModulePath modulePath , _ ) =
BSS . toShort $ BS . concat
[ " source "
, " | "
, TE . encodeUtf8 $ HCE . packageIdToText packageId
, " | "
, TE . encodeUtf8 modulePath
]
instance Store . StoreItem ( HM . HashMap PackageName ( M . Map Version HCE . PackageId ) ) where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs ( HM . HashMap PackageName ( M . Map Version HCE . PackageId ) ) =
Proxy ( HM . HashMap PackageName ( M . Map Version HCE . PackageId ) )
itemKey _ = " packageMap "
instance Store . StoreItem PackagePathMap where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs PackagePathMap = Proxy PackagePathMap
itemKey _ = " packagePathMap "
instance Store . StoreItem GlobalReferenceMap where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs GlobalReferenceMap = Proxy GlobalReferenceMap
itemKey _ = " globalReferenceMap "
2019-02-06 21:42:29 +03:00
newtype GlobalIdentifierMapWrapper = GlobalIdentifierMapWrapper
{ getGlobalIdentifierMap :: GlobalIdentifierMap
}
instance Store . StoreItem GlobalIdentifierMapWrapper where
toByteString ( GlobalIdentifierMapWrapper idMap ) = Serialize . encode idMap
fromByteString bs = GlobalIdentifierMapWrapper <$> Serialize . decode bs
type KeyArgs GlobalIdentifierMapWrapper = Proxy GlobalIdentifierMapWrapper
2019-08-21 13:03:31 +03:00
itemKey _ = " globalIdentifierMap "
2019-02-06 21:42:29 +03:00
2019-01-23 17:18:29 +03:00
instance Store . StoreItem [ PackageVersions ] where
toByteString = Serialize . encode
fromByteString = Serialize . decode
type KeyArgs [ PackageVersions ] = Proxy [ PackageVersions ]
itemKey _ = " packageVersions "
findTopLevelExpressions :: ( Ord k ) => IVM . IntervalMap k v -> [ ( Interval k , v ) ]
findTopLevelExpressions =
L . foldl'
( \ topLevel interval ->
case topLevel of
[] -> [ interval ]
topLevelIntervals @ ( currentTopLevelInterval : rest )
| subsumes ( fst currentTopLevelInterval ) ( fst interval ) -> topLevelIntervals
| subsumes ( fst interval ) ( fst currentTopLevelInterval ) ->
interval : rest
2019-08-21 13:03:31 +03:00
| otherwise -> interval : topLevelIntervals )
2019-01-23 17:18:29 +03:00
[] .
IVM . assocs
splitIntervalMap ::
( Show k , Ord k )
=> IVM . IntervalMap k v
-> ( IVM . IntervalMap k BS . ByteString , [ ( BS . ByteString , IVM . IntervalMap k v ) ] )
splitIntervalMap ivmap =
let topLevelExprs = findTopLevelExpressions ivmap
in L . foldl'
( \ ( index , ivMaps ) ( interval , _ ) ->
let topLevelExpressionKey = BSC . pack $ show interval
in ( IVM . insert interval topLevelExpressionKey index
, ( topLevelExpressionKey , IVM . within ivmap interval ) : ivMaps ) )
( IVM . empty , [] )
topLevelExprs
createStore :: FilePath -> ServerConfig -> IO ()
createStore storePath config = do
packageDirectories <- findDirectories ( configPackagesPath config )
Store . createStore storePath $ \ fileHandle -> do
2019-02-06 21:42:29 +03:00
( errors , packageMap' , packagePathMap' , packageVersions' , globalReferenceMap' , globalIdentifiers' , index'' ) <-
2019-01-23 17:18:29 +03:00
foldM
2019-02-06 21:42:29 +03:00
( \ ( errors , packageMap , packagePathMap , packageVersions , globalReferenceMap , globalIdentifiers , index ) path -> do
2019-01-23 17:18:29 +03:00
eitherPackageInfo <- loadPackageInfo config path
case eitherPackageInfo of
Right ( packageInfo , packagePath ) -> do
let packageId =
HCE . id
( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo )
addPackageInfo :: StateT Store . State IO ()
addPackageInfo = do
Store . add
( HCE . moduleNameMap packageInfo )
( packageId
, Proxy :: Proxy ( HM . HashMap HCE . HaskellModuleName ( HM . HashMap HCE . ComponentId HCE . HaskellModulePath ) ) )
addExternalIdInfo packageId packageInfo
mapM_
( \ ( extId , occs ) ->
Store . add
occs
( packageId
, extId
, Proxy :: Proxy ( S . Set HCE . IdentifierSrcSpan ) ) )
( HM . toList $ HCE . externalIdOccMap packageInfo )
mapM_
( \ ( modulePath , moduleInfo ) -> do
addExpressionInfo
packageId
modulePath
( HCE . exprInfoMap
( moduleInfo :: HCE . CompactModuleInfo ) )
Store . add
( HCE . definitionSiteMap
( moduleInfo :: HCE . CompactModuleInfo ) )
( packageId
, modulePath
, Proxy :: Proxy HCE . DefinitionSiteMap )
Store . add
( HCE . source ( moduleInfo :: HCE . CompactModuleInfo ) )
( packageId
, modulePath
, Proxy :: Proxy ( V . Vector T . Text ) ) ) .
HM . toList $
HCE . moduleMap packageInfo
index' <- Store . writeValues fileHandle index addPackageInfo
print $ T . unpack ( HCE . packageIdToText packageId )
return $
force
( errors
, let packageVersion = HCE . version packageId
val = M . singleton packageVersion packageId
in HM . insertWith
M . union
( PackageName $ HCE . packageName packageInfo )
val
packageMap
, let key = PackageId $ HCE . packageIdToText packageId
in HM . insert key packagePath packagePathMap
, ( \ ( HCE . PackageId name version ) -> ( name , [ version ] ) )
packageId :
packageVersions
, let references =
HM . map
( \ spans ->
S . singleton
( GlobalReferences
( S . size spans )
( HCE . packageIdToText packageId ) ) ) .
HCE . externalIdOccMap $
packageInfo
in HM . unionWith S . union references globalReferenceMap
2019-02-06 21:42:29 +03:00
, globalIdentifiers ++
filter
isExportedId
( trieValues $ HCE . externalIdInfoMap packageInfo )
2019-01-23 17:18:29 +03:00
, index' )
Left ( errorMessage , path' ) ->
return $
force
( ( errorMessage , path' ) : errors
, packageMap
, packagePathMap
, packageVersions
, globalReferenceMap
2019-02-06 21:42:29 +03:00
, globalIdentifiers
2019-01-23 17:18:29 +03:00
, index ) )
2019-02-06 21:42:29 +03:00
( [] , HM . empty , HM . empty , [] , HM . empty , [] , M . empty )
2019-01-23 17:18:29 +03:00
packageDirectories
let versions =
L . sortOn ( T . toLower . ( name :: PackageVersions -> T . Text ) ) .
map ( \ ( name , vers ) -> PackageVersions name ( L . sortOn Down vers ) ) .
HM . toList . HM . fromListWith ( ++ ) $
packageVersions'
indexFinal <-
Store . writeValues fileHandle index'' $ do
Store . add packagePathMap' ( Proxy :: Proxy PackagePathMap )
Store . add versions ( Proxy :: Proxy [ PackageVersions ] )
Store . add globalReferenceMap' ( Proxy :: Proxy GlobalReferenceMap )
2019-02-06 21:42:29 +03:00
let globalIdentifierMap =
L . foldl'
( \ trie exportedId @ ( HCE . ExternalIdentifierInfo HCE . IdentifierInfo { HCE . demangledOccName = name } ) ->
HCE . insertToTrie S . insert ( T . unpack name ) exportedId trie )
HCE . emptyTrie
globalIdentifiers'
Store . add
( GlobalIdentifierMapWrapper globalIdentifierMap )
( Proxy :: Proxy GlobalIdentifierMapWrapper )
2019-01-23 17:18:29 +03:00
Store . add
packageMap'
( Proxy :: Proxy ( HM . HashMap PackageName ( M . Map Version HCE . PackageId ) ) )
unless ( null errors ) $ do
putStrLn " Package loading errors : "
mapM_ ( \ ( err , path ) -> putStrLn $ path ++ " : " ++ err ) errors
return indexFinal
addExpressionInfo ::
( Show k
, Ord k
, Store . StoreItem ( IVM . IntervalMap k v )
, Store . StoreItem ( IVM . IntervalMap k BSC . ByteString )
, Store . KeyArgs ( IVM . IntervalMap k BSC . ByteString ) ~ ( a
, b
, Proxy ( IVM . IntervalMap ( Int
, Int ) BSC . ByteString ) )
, Store . KeyArgs ( IVM . IntervalMap k v ) ~ ( a
, b
, BSC . ByteString
, Proxy HCE . ExpressionInfoMap )
)
=> a
-> b
-> IVM . IntervalMap k v
-> StateT Store . State IO ()
addExpressionInfo packageId modulePath ivMap = do
let ( index , ivMaps ) = splitIntervalMap ivMap
Store . add
index
( packageId
, modulePath
, Proxy :: Proxy ( IVM . IntervalMap ( Int , Int ) BS . ByteString ) )
mapM_
( \ ( topLevelExprKey , ivMap' ) ->
Store . add
ivMap'
( packageId
, modulePath
, topLevelExprKey
, Proxy :: Proxy HCE . ExpressionInfoMap ) )
ivMaps
addExternalIdInfo ::
HCE . PackageId
-> HCE . PackageInfo HCE . CompactModuleInfo
-> StateT Store . State IO ()
addExternalIdInfo packageId packageInfo = do
let addTrieValues ::
HCE . Trie Char HCE . ExternalIdentifierInfo
-> String
-> StateT Store . State IO ()
addTrieValues trie name =
let len = L . length name
in Store . add
( let ids =
S . toAscList $
HCE . match
name
( trie :: HCE . Trie Char HCE . ExternalIdentifierInfo )
( exactMatches , rest ) =
L . span
( \ ( HCE . ExternalIdentifierInfo HCE . IdentifierInfo { .. } ) ->
T . length demangledOccName == len )
ids
maxIds = 10
exactMatchesCount = L . length exactMatches
in if exactMatchesCount >= maxIds
then exactMatches
else exactMatches ++
L . take ( maxIds - exactMatchesCount ) rest )
( packageId , name , Proxy :: Proxy [ HCE . ExternalIdentifierInfo ] )
let fullTrie = HCE . externalIdInfoMap packageInfo
mapM_
( \ ( firstLetter , trie ) -> do
mapM_
( \ ( secondLetter , trie' ) -> do
mapM_
( \ ( thirdLetter , trie'' ) -> do
mapM_
( \ ( fourthLetter , trie''' ) ->
Store . add
trie'''
( packageId
, [ firstLetter , secondLetter , thirdLetter , fourthLetter ]
, Proxy :: Proxy ( HCE . Trie Char HCE . ExternalIdentifierInfo ) ) )
( HM . toList . HCE . children $ trie'' )
addTrieValues fullTrie [ firstLetter , secondLetter , thirdLetter ] )
( HM . toList . HCE . children $ trie' )
addTrieValues fullTrie [ firstLetter , secondLetter ] )
( HM . toList . HCE . children $ trie )
addTrieValues fullTrie [ firstLetter ] )
( HM . toList . HCE . children $ fullTrie )
findDirectories :: PackagesPath -> IO [ FilePath ]
findDirectories p =
2019-03-26 16:45:25 +03:00
fmap ( pathPackages p <> ) packagesInPackageDir
where
packagesInPackageDir :: IO [ FilePath ]
packagesInPackageDir =
case pathDirWithPackages p of
Nothing -> return []
Just dir ->
find ( depth ==? 0 ) ( fileType ==? Directory &&? filePath /=? dir ) dir
2019-01-23 17:18:29 +03:00
2018-10-02 13:17:04 +03:00
loadPackages ::
2018-11-16 16:19:03 +03:00
ServerConfig
2019-01-23 17:18:29 +03:00
-> Maybe Store . Store
-> IO ( Maybe ( PackageMap
, PackagePathMap
, [ PackageVersions ]
2019-02-06 21:42:29 +03:00
, GlobalReferenceMap
, GlobalIdentifierMap ) )
2019-01-23 17:18:29 +03:00
loadPackages _config mbStore
| ( Just store ) <- mbStore = do
let eitherPackagePathMap =
Store . lookup ( Proxy :: Proxy PackagePathMap ) store
eitherGlobalReferenceMap =
Store . lookup ( Proxy :: Proxy GlobalReferenceMap ) store
2019-02-06 21:42:29 +03:00
eitherGlobalIdentifierMap =
getGlobalIdentifierMap <$>
Store . lookup ( Proxy :: Proxy GlobalIdentifierMapWrapper ) store
2019-01-23 17:18:29 +03:00
eitherPackageVersions =
Store . lookup ( Proxy :: Proxy [ PackageVersions ] ) store
eitherPackageMap =
Store . lookup
( Proxy :: Proxy ( HM . HashMap PackageName ( M . Map Version HCE . PackageId ) ) )
store
2019-02-06 21:42:29 +03:00
case ( , , , , ) <$> ( PackageMapStore store <$> eitherPackageMap ) <*>
2019-01-23 17:18:29 +03:00
eitherPackagePathMap <*>
eitherPackageVersions <*>
2019-02-06 21:42:29 +03:00
eitherGlobalReferenceMap <*>
eitherGlobalIdentifierMap of
2019-01-23 17:18:29 +03:00
Right res -> return $ Just res
2019-05-17 18:43:42 +03:00
Left _ -> do
2019-01-23 17:18:29 +03:00
putStrLn " Store lookup errors : "
let ignoreRight :: Either a b -> Either a ()
ignoreRight = second ( const () )
print $
lefts
[ ignoreRight eitherGlobalReferenceMap
, ignoreRight eitherPackageMap
, ignoreRight eitherPackageVersions
2019-02-06 21:42:29 +03:00
, ignoreRight eitherGlobalIdentifierMap
2019-01-23 17:18:29 +03:00
]
2019-08-21 13:03:31 +03:00
return Nothing
2019-01-23 17:18:29 +03:00
loadPackages config _ = do
packageDirectories <- findDirectories ( configPackagesPath config )
2018-10-02 13:17:04 +03:00
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 =
2019-01-23 17:18:29 +03:00
PackageMap $
2018-10-02 13:17:04 +03:00
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
2018-11-16 16:19:03 +03:00
globalReferenceMap =
L . foldl'
( \ hMap ( packageInfo , _path ) ->
let references =
HM . map
( \ spans ->
S . singleton
( GlobalReferences
( S . size spans )
( HCE . packageIdToText packageId ) ) ) .
HCE . externalIdOccMap $
packageInfo
packageId =
HCE . id
( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo )
in HM . unionWith S . union references hMap )
HM . empty
loadedPackages
2019-02-06 21:42:29 +03:00
globalIdentifierMap =
L . foldl'
( \ trie ( packageInfo , _path ) ->
let exportedIds :: [ HCE . ExternalIdentifierInfo ]
exportedIds =
filter isExportedId $
trieValues $ HCE . externalIdInfoMap packageInfo
in L . foldl
2019-05-17 18:43:42 +03:00
( \ trie' exportedId @ ( HCE . ExternalIdentifierInfo HCE . IdentifierInfo { HCE . demangledOccName = name } ) ->
2019-02-06 21:42:29 +03:00
HCE . insertToTrie
S . insert
( T . unpack name )
exportedId
trie' )
trie
exportedIds )
HCE . emptyTrie
loadedPackages
2018-10-02 13:17:04 +03:00
packageMapCompacted <- ghcCompact packageMap
packagePathMapCompacted <- ghcCompact packagePathMap
packageVersionsCompacted <- ghcCompact packageVersions
2018-11-16 16:19:03 +03:00
globalReferenceMapCompacted <- ghcCompact globalReferenceMap
2019-02-06 21:42:29 +03:00
globalIdentifierMapCompacted <- ghcCompact globalIdentifierMap
2018-10-02 13:17:04 +03:00
return . Just $
2018-11-16 16:19:03 +03:00
( packageMapCompacted
, packagePathMapCompacted
, packageVersionsCompacted
2019-02-06 21:42:29 +03:00
, globalReferenceMapCompacted
2019-08-21 13:03:31 +03:00
, globalIdentifierMapCompacted
2019-02-06 21:42:29 +03:00
)
2018-10-02 13:17:04 +03:00
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 )
2019-02-06 21:42:29 +03:00
trieValues :: HCE . Trie k v -> [ v ]
trieValues ( HCE . Trie values children ) =
S . toList values ++ concatMap trieValues ( HM . elems children )
isExportedId :: HCE . ExternalIdentifierInfo -> Bool
isExportedId ( HCE . ExternalIdentifierInfo HCE . IdentifierInfo { isExported } ) =
isExported
2018-11-16 16:19:03 +03:00
ghcCompact :: forall a . a -> IO a
2018-10-02 13:17:04 +03:00
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 ->
2018-12-13 18:31:39 +03:00
if not enableExpressionInfo
then modInfo { HCE . exprInfoMap = IVM . empty }
else modInfo )
2018-10-02 13:17:04 +03:00
, 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
2019-02-08 00:34:54 +03:00
:<|> GetDefinitionSite
2018-10-02 13:17:04 +03:00
:<|> GetExpressions
:<|> GetReferences
:<|> GetIdentifiers
2018-11-16 16:19:03 +03:00
:<|> GetGlobalReferences
2019-02-06 21:42:29 +03:00
:<|> GetGlobalIdentifiers
2019-08-21 13:03:31 +03:00
:<|> GetHoogleDocs
2018-10-02 13:17:04 +03:00
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
2018-11-16 16:19:03 +03:00
:> Capture " externalId " HCE . ExternalId
2018-10-02 13:17:04 +03:00
:> 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 ] )
2018-11-16 16:19:03 +03:00
type GetGlobalReferences = " api " :> " globalReferences "
2019-08-21 13:03:31 +03:00
:> Capture " externalId " HCE . ExternalId
2018-11-16 16:19:03 +03:00
:> Get '[JSON] [ GlobalReferences ]
2019-02-06 21:42:29 +03:00
type GetGlobalIdentifiers = " api " :> " globalIdentifiers "
:> Capture " query " T . Text
:> QueryParam " page " Int
:> QueryParam " per_page " Int
:> Get '[JSON] ( Headers '[Header "Link" T.Text,Header "X-Total-Count" Int]
2019-02-20 18:58:57 +03:00
[ HCE . ExternalIdentifierInfo ] )
type GetHoogleDocs = " api " :> " hoogleDocs "
:> Capture " packageId " PackageId
:> Capture " moduleName " HCE . HaskellModuleName
:> Capture " entity " HoogleItemSort
:> Capture " name " T . Text
2019-08-21 13:03:31 +03:00
:> Get '[JSON] T . Text
2019-02-06 21:42:29 +03:00
2018-10-02 13:17:04 +03:00
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
2019-02-20 18:58:57 +03:00
instance FromHttpApiData HoogleItemSort where
parseQueryParam " Val " = Right Val
parseQueryParam " Typ " = Right Typ
parseQueryParam val = Left $ T . append " Incorrect HoogleItemSort : " val
2018-10-02 13:17:04 +03:00
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
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
instance ToHttpApiData PackageId where
toUrlPiece ( PackageId p ) = p
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
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
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
instance FromHttpApiData PackageId where
parseQueryParam = Right . PackageId
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
--------------------------------------------------------------------------------
-- Request handlers
--------------------------------------------------------------------------------
data Environment = Environment
{ envLogger :: ! LoggerSet
, envPackageMap :: ! PackageMap
, envPackageVersions :: ! AllPackages
2018-11-16 16:19:03 +03:00
, envGlobalReferenceMap :: ! GlobalReferenceMap
2019-02-06 21:42:29 +03:00
, envGlobalIdentifierMap :: ! GlobalIdentifierMap
2018-10-02 13:17:04 +03:00
, 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
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
getExpressions ::
2019-01-23 17:18:29 +03:00
PackageId
2018-10-02 13:17:04 +03:00
-> 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 "
2019-01-23 17:18:29 +03:00
else withPackageInfo packageId $ \ packageInfo' -> do
maxPerPage <- asks ( configMaxPerPage . envConfig )
let requestedInterval =
IVM . ClosedInterval
( startLine , startColumn )
( endLine , endColumn )
findInterval ::
HCE . ExpressionInfoMap -> ReaderT Environment IO [ Expression ]
findInterval exprInfoMap =
return .
map ( uncurry Expression ) .
L . take maxPerPage . IVM . toList . IVM . within exprInfoMap $
requestedInterval
in case packageInfo' of
PackageInfo packageInfo ->
withModuleInfo packageInfo modulePath $ \ modInfo -> do
let exprInfoMap =
HCE . exprInfoMap ( modInfo :: HCE . CompactModuleInfo )
findInterval exprInfoMap
PackageInfoStore pId store -> do
let topLevelExprKey =
( pId
, modulePath
, Proxy :: Proxy ( IVM . IntervalMap ( Int , Int ) BS . ByteString ) )
eitherTopLevelExprMap =
Store . lookup topLevelExprKey store
case eitherTopLevelExprMap of
Right topLevelExprMap ->
case map snd . IVM . toList $
IVM . intersecting topLevelExprMap requestedInterval of
exprKey : _ -> do
let key =
( pId
, modulePath
, exprKey
, Proxy :: Proxy HCE . ExpressionInfoMap )
eitherExprMap = Store . lookup key store
case eitherExprMap of
Right exprMap -> findInterval exprMap
Left e -> error500 $ BSL . fromStrict $ BSC . pack e
_ -> return []
Left e -> error500 $ BSL . fromStrict $ BSC . pack e
2018-10-02 13:17:04 +03:00
getDefinitionSite ::
PackageId
-> HCE . ComponentId
-> HCE . HaskellModuleName
-> HCE . LocatableEntity
-> T . Text
-> ReaderT Environment IO HCE . DefinitionSite
2019-02-08 00:34:54 +03:00
getDefinitionSite packageId componentId modName entity name' =
2019-01-23 17:18:29 +03:00
withPackageInfo packageId $ \ packageInfo' ->
withModulePath packageInfo' componentId modName $ \ modPath ->
let findDefSite ::
HCE . PackageId
-> HCE . DefinitionSiteMap
-> ReaderT Environment IO HCE . DefinitionSite
findDefSite pId defSiteMap =
case entity of
HCE . Mod ->
return $
HCE . DefinitionSite
( HCE . ExactLocation pId modPath modName 1 1 1 1 )
Nothing
_ -> do
let mbDefinitionSite =
2019-02-08 00:34:54 +03:00
let name = fixDots name'
in case entity of
2019-01-23 17:18:29 +03:00
HCE . Typ ->
HM . lookup ( HCE . OccName name ) $
HCE . types ( defSiteMap :: HCE . DefinitionSiteMap )
HCE . Val ->
HM . lookup ( HCE . OccName name ) $
HCE . values ( defSiteMap :: HCE . DefinitionSiteMap )
HCE . Inst ->
HM . lookup name $
HCE . instances ( defSiteMap :: HCE . DefinitionSiteMap )
_ -> Nothing
case mbDefinitionSite of
Just definitionSite -> return definitionSite
Nothing ->
error404 $
BSL . concat
[ toLazyBS . T . pack $ show entity
, " "
2019-02-08 00:34:54 +03:00
, toLazyBS name'
2019-01-23 17:18:29 +03:00
, " "
, " not found in module "
, toLazyBS $ HCE . getHaskellModulePath modPath
]
in case packageInfo' of
PackageInfo packageInfo ->
let pId =
HCE . id
( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo )
in case HM . lookup
modPath
( HCE . moduleMap
( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo ) ) of
Just HCE . CompactModuleInfo { definitionSiteMap = defSiteMap } ->
findDefSite pId defSiteMap
Nothing ->
error404 $
BSL . concat
[ " Module "
, toLazyBS $ HCE . getHaskellModulePath modPath
, " is not found in package "
, toLazyBS $ HCE . packageIdToText pId
]
PackageInfoStore pId store -> do
let eitherDefinitionSiteMap =
Store . lookup
( pId , modPath , Proxy :: Proxy HCE . DefinitionSiteMap )
store
case eitherDefinitionSiteMap of
Right definitionSiteMap -> findDefSite pId definitionSiteMap
Left e -> error500 ( BSL . fromStrict $ BSC . pack e )
2019-02-08 00:34:54 +03:00
-- | "." and ".." is a special case because of the Path Segment Normalization:
-- https://tools.ietf.org/html/rfc3986#section-6.2.2.3
-- The segments “..” and “.” can be removed from a URL by a browser.
-- https://stackoverflow.com/questions/3856693/a-url-resource-that-is-a-dot-2e
fixDots :: T . Text -> T . Text
fixDots " . " = " . "
fixDots " .. " = " .. "
fixDots t = t
2018-10-02 13:17:04 +03:00
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 )
2019-06-09 17:18:38 +03:00
addPaginationHeaders ::
forall a b .
T . Text
-> Paginated a
-> Int
-> Natural
-> Natural
-> b
-> Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] b
addPaginationHeaders url items totalCount page perPage =
addHeader linkHeader . addHeader totalCount
where
linkHeader :: T . Text
linkHeader = buildLinkHeader url items page perPage
2018-11-16 16:19:03 +03:00
getGlobalReferences ::
HCE . ExternalId -> ReaderT Environment IO [ GlobalReferences ]
getGlobalReferences externalId = do
refMap <- asks envGlobalReferenceMap
2019-08-21 13:03:31 +03:00
return $ maybe [] S . toDescList ( HM . lookup externalId refMap )
2018-10-02 13:17:04 +03:00
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 =
2019-01-23 17:18:29 +03:00
withPackageInfo packageId $ \ packageInfo' ->
let mkRefsWithSource ::
Maybe [ HCE . IdentifierSrcSpan ]
-> ReaderT Environment IO ( Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] [ SourceFile ] )
mkRefsWithSource mbReferences =
case mbReferences of
Just references -> do
( paginatedReferences , page , perPage , totalCount ) <-
paginateItems mbPage mbPerPage references
let url =
T . append " / " $
toUrlPiece $
safeLink
( Proxy :: Proxy API )
( Proxy :: Proxy GetReferences )
packageId
externalId
Nothing
Nothing
refModulePath :: ReferenceWithSource -> HCE . HaskellModulePath
refModulePath =
( HCE . modulePath :: HCE . IdentifierSrcSpan -> HCE . HaskellModulePath ) .
idSrcSpan
return $
2019-06-09 17:18:38 +03:00
addPaginationHeaders url paginatedReferences totalCount page perPage $
2019-01-23 17:18:29 +03:00
concatMap
( \ refs ->
case refs of
ref : _ ->
let path =
HCE . getHaskellModulePath .
( HCE . modulePath :: HCE . IdentifierSrcSpan -> HCE . HaskellModulePath ) .
idSrcSpan $
ref
in [ SourceFile path refs ]
_ -> [] ) $
groupWith refModulePath $
mapMaybe
( mkReferenceWithSource packageInfo' )
( L . groupBy ( \ span1 span2 -> HCE . line span1 == HCE . line span2 ) $
paginatedItems paginatedReferences )
Nothing ->
error404 $
BSL . concat
[ " Cannot find references to "
, toLazyBS $ HCE . getExternalId externalId
]
in case packageInfo' of
PackageInfo packageInfo ->
2019-08-21 13:03:31 +03:00
mkRefsWithSource $ S . toList <$> HM . lookup externalId ( HCE . externalIdOccMap packageInfo )
2019-01-23 17:18:29 +03:00
PackageInfoStore pId store -> do
let eitherOccurrences =
Store . lookup
( pId
, externalId
, Proxy :: Proxy ( S . Set HCE . IdentifierSrcSpan ) )
store
case eitherOccurrences of
Right occurrences ->
mkRefsWithSource ( Just $ S . toList occurrences )
Left e -> error500 $ BSL . fromStrict $ BSC . pack e
2018-10-02 13:17:04 +03:00
mkReferenceWithSource ::
2019-01-23 17:18:29 +03:00
PackageInfo -> [ HCE . IdentifierSrcSpan ] -> Maybe ReferenceWithSource
mkReferenceWithSource packageInfo' spans @ ( srcSpan : _ ) =
let mkRef :: Maybe ( V . Vector T . Text ) -> Maybe ReferenceWithSource
mkRef mbSource =
case mbSource of
Just source ->
let sourceCodeHtml =
buildHtmlCodeSnippet
source
( HCE . line ( srcSpan :: HCE . IdentifierSrcSpan ) )
( map
( \ HCE . IdentifierSrcSpan { .. } -> ( startColumn , endColumn ) )
spans )
in Just $ ReferenceWithSource sourceCodeHtml srcSpan
_ -> Just $ ReferenceWithSource " " srcSpan
in case packageInfo' of
PackageInfo packageInfo -> do
let mbSource =
( HCE . source :: HCE . CompactModuleInfo -> V . Vector T . Text ) <$>
HM . lookup
( HCE . modulePath ( srcSpan :: HCE . IdentifierSrcSpan ) )
( HCE . moduleMap
( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo ) )
mkRef mbSource
PackageInfoStore packageId store -> do
let eitherSourceCode =
Store . lookup
( packageId
, HCE . modulePath ( srcSpan :: HCE . IdentifierSrcSpan )
, Proxy :: Proxy ( V . Vector T . Text ) )
store
case eitherSourceCode of
Right source -> mkRef ( Just source )
Left _ -> mkRef Nothing
2018-10-25 01:30:30 +03:00
mkReferenceWithSource _ _ = Nothing
buildHtmlCodeSnippet :: V . Vector T . Text -> Int -> [ ( Int , Int ) ] -> T . Text
buildHtmlCodeSnippet sourceLines lineNumber positions =
2018-10-02 13:17:04 +03:00
toStrict $
renderHtml $ do
mkLineNumber ( lineNumber - 1 ) >>
Html . toHtml
( T . append ( fromMaybe " " $ ( V .!? ) sourceLines ( lineNumber - 2 ) ) " \ n " )
mkLineNumber lineNumber >>
2018-10-25 01:30:30 +03:00
highlightIdentifiers
2018-10-02 13:17:04 +03:00
( 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 ++ " " )
2018-10-25 01:30:30 +03:00
highlightIdentifiers :: T . Text -> Html . Html
highlightIdentifiers line =
mapM_
( \ ( text , _ , mbId ) ->
case mbId of
Just _ -> Html . b ( Html . toHtml text )
Nothing -> Html . toHtml text ) $
2018-11-16 16:19:03 +03:00
HCE . tokenize line ( map ( , () ) positions )
2018-10-25 01:30:30 +03:00
2018-10-02 13:17:04 +03:00
findIdentifiers ::
PackageId
-> T . Text
-> Maybe Int
-> Maybe Int
2019-01-23 17:18:29 +03:00
-> ReaderT Environment IO ( Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] [ HCE . ExternalIdentifierInfo ] )
2019-06-09 17:18:38 +03:00
findIdentifiers packageId query' mbPage mbPerPage =
2019-01-23 17:18:29 +03:00
withPackageInfo packageId $ \ packageInfo' ->
2019-02-08 00:34:54 +03:00
let query = fixDots query'
respond identifiers = do
2019-01-23 17:18:29 +03:00
( paginatedIdentifiers , page , perPage , totalCount ) <-
paginateItems mbPage mbPerPage identifiers
let url =
T . append " / " $
toUrlPiece $
safeLink
( Proxy :: Proxy API )
( Proxy :: Proxy GetIdentifiers )
packageId
2019-02-08 00:34:54 +03:00
query'
2019-01-23 17:18:29 +03:00
Nothing
Nothing
2019-06-09 17:18:38 +03:00
return .
addPaginationHeaders
url
paginatedIdentifiers
totalCount
page
perPage .
paginatedItems $
paginatedIdentifiers
2019-01-23 17:18:29 +03:00
in case packageInfo' of
PackageInfo packageInfo -> do
let identifiers
| not $ T . null query =
S . toList $
HCE . match
( T . unpack query )
( HCE . externalIdInfoMap packageInfo )
| otherwise = []
respond identifiers
PackageInfoStore pId store ->
let findIds :: T . Text -> [ HCE . ExternalIdentifierInfo ]
findIds q =
let eitherIdInfo =
Store . lookup
( pId
, T . unpack q
, Proxy :: Proxy [ HCE . ExternalIdentifierInfo ] )
store
in case eitherIdInfo of
Right ids -> ids
Left _ -> []
in case T . length query of
0 -> respond []
1 -> respond $ findIds query
2 -> respond $ findIds query
3 -> respond $ findIds query
_ ->
let eitherIdInfoMap =
Store . lookup
( pId
, T . unpack $ T . take 4 query
, Proxy :: Proxy ( HCE . Trie Char HCE . ExternalIdentifierInfo ) )
store
in case eitherIdInfoMap of
Right trie ->
respond $
S . toList $
HCE . match ( T . unpack $ T . drop 4 query ) trie
2019-08-21 13:03:31 +03:00
Left _ -> respond []
2019-02-06 21:42:29 +03:00
findGlobalIdentifiers ::
T . Text
-> Maybe Int
-> Maybe Int
-> ReaderT Environment IO ( Headers '[ Header "Link" T.Text, Header "X-Total-Count" Int] [ HCE . ExternalIdentifierInfo ] )
2019-02-08 00:34:54 +03:00
findGlobalIdentifiers query' mbPage mbPerPage = do
let query = fixDots query'
2019-02-06 21:42:29 +03:00
globalIdentifierMap <- asks envGlobalIdentifierMap
let maxItems = 500
let identifiers
| T . length query > 0 =
L . take maxItems $
S . toList $ HCE . match ( T . unpack query ) globalIdentifierMap
| otherwise = []
( paginatedIdentifiers , page , perPage , totalCount ) <-
paginateItems mbPage mbPerPage identifiers
let url =
T . append " / " $
toUrlPiece $
safeLink
( Proxy :: Proxy API )
( Proxy :: Proxy GetGlobalIdentifiers )
2019-02-08 00:34:54 +03:00
query'
2019-02-06 21:42:29 +03:00
Nothing
Nothing
2019-06-09 17:18:38 +03:00
return .
addPaginationHeaders url paginatedIdentifiers totalCount page perPage .
paginatedItems $
paginatedIdentifiers
2018-10-02 13:17:04 +03:00
2019-02-20 18:58:57 +03:00
data HoogleResultItem = HoogleResultItem
{ sort :: HoogleItemSort
, moduleName :: T . Text
, htmlDocs :: T . Text
} deriving ( Show , Eq )
data HoogleItemSort
= Val
| Typ
deriving ( Show , Eq )
valueToHoogleResultItem :: A . Value -> Maybe HoogleResultItem
valueToHoogleResultItem value =
let mbHtmlDocs = value ^? AL . key " docs " . AL . _String
mbModuleName = value ^? AL . key " module " . AL . key " name " . AL . _String
urlToSort :: T . Text -> Maybe HoogleItemSort
urlToSort url
| T . isInfixOf " #v " url = Just Val
urlToSort url
| T . isInfixOf " #t " url = Just Typ
urlToSort _ = Nothing
mbResultSort = value ^? AL . key " url " . AL . _String >>= urlToSort
2019-08-21 13:03:31 +03:00
in HoogleResultItem <$> mbResultSort <*> mbModuleName <*> mbHtmlDocs
2019-02-20 18:58:57 +03:00
hoogleApiHost :: String
hoogleApiHost = " https://hoogle.haskell.org/ "
getHoogleDocs ::
PackageId
-> HCE . HaskellModuleName
-> HoogleItemSort
-> T . Text
-> ReaderT Environment IO T . Text
getHoogleDocs packageId ( HCE . HaskellModuleName moduleName ) itemSort name
| Just ( packageName , _mbVersion ) <- parsePackageId packageId = do
useHoogle <- asks ( configUseHoogleApi . envConfig )
unless useHoogle $ error404 " Hoogle API is disabled "
let hoogleQuery =
T . unpack name ++
" is:exact package: " ++ T . unpack ( getPackageName packageName )
2019-08-21 13:03:31 +03:00
url = hoogleApiHost ++ " ?hoogle= " ++ encode hoogleQuery ++ " &mode=json "
2019-02-20 18:58:57 +03:00
error502 e =
throwServantError $
err502 { errBody = BSL . fromStrict $ BSC . pack $ show e }
response <- liftIO $ handleSync error502 ( Wreq . get url )
let body = response ^. Wreq . responseBody
case A . decode body of
Just ( value :: A . Value ) ->
case value of
A . Array vector ->
let items = mapMaybe valueToHoogleResultItem $ V . toList vector
findItem :: Bool -> [ HoogleResultItem ] -> Maybe HoogleResultItem
findItem exactModuleMatch =
L . find
( \ HoogleResultItem { sort = s , moduleName = m } ->
s == itemSort && ( exactModuleMatch || m == moduleName ) )
in case findItem True items <|> findItem False items of
Just item -> return $ htmlDocs item
_ -> error404 " "
_ ->
error500 $
BSL . append " Unexpected JSON response from hoogle.haskell.org " body
Nothing ->
error500 $
BSL . append " Unexpected response from hoogle.haskell.org: " body
getHoogleDocs packageId _ _ _ =
error404 $
BSL . append " Incorrect package id: " ( toLazyBS $ getPackageId packageId )
2018-11-16 16:19:03 +03:00
paginateItems ::
Maybe Int
-> Maybe Int
-> [ a ]
-> ReaderT Environment IO ( Paginated a , Natural , Natural , Int )
paginateItems mbPage mbPerPage items = do
( page , perPage ) <- initializePagination mbPage mbPerPage
let totalCount = L . length items
pagination <- mkPagination perPage page
paginated <-
paginate
pagination
( fromIntegral totalCount )
( \ offset limit -> return . L . take limit . L . drop offset $ items )
return ( paginated , page , perPage , totalCount )
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
error404 :: BSL . ByteString -> ReaderT Environment IO a
error404 body = throwServantError $ err404 { errBody = body }
2019-01-23 17:18:29 +03:00
error500 :: BSL . ByteString -> ReaderT Environment IO a
error500 body = throwServantError $ err500 { errBody = body }
2018-10-02 13:17:04 +03:00
toLazyBS :: T . Text -> BSL . ByteString
toLazyBS = BSL . fromStrict . TE . encodeUtf8
2019-01-23 17:18:29 +03:00
data PackageInfo
= PackageInfo ( HCE . PackageInfo HCE . CompactModuleInfo )
| PackageInfoStore HCE . PackageId
Store . Store
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
withPackageInfo ::
PackageId
2019-01-23 17:18:29 +03:00
-> ( PackageInfo -> ReaderT Environment IO a )
2018-10-02 13:17:04 +03:00
-> ReaderT Environment IO a
withPackageInfo packageId action
| Just ( packageName , mbVersion ) <- parsePackageId packageId = do
packageMap <- asks envPackageMap
2019-01-23 17:18:29 +03:00
let findPackage ::
( Hashable k , Eq k , Ord k1 )
=> k
-> Maybe k1
-> HM . HashMap k ( M . Map k1 v )
-> Maybe v
findPackage name mbVer pMap =
HM . lookup name pMap >>=
2018-10-02 13:17:04 +03:00
( \ packages ->
let findLastVersion :: M . Map k v -> Maybe v
findLastVersion = fmap ( snd . fst ) . L . uncons . M . toDescList
2019-01-23 17:18:29 +03:00
in case mbVer of
2018-10-02 13:17:04 +03:00
Just version ->
M . lookup version packages <|> findLastVersion packages
Nothing -> findLastVersion packages )
2019-01-23 17:18:29 +03:00
mbPackageInfo =
case packageMap of
PackageMap pMap ->
PackageInfo <$> findPackage packageName mbVersion pMap
PackageMapStore store pMap ->
case findPackage packageName mbVersion pMap of
Just pId -> Just $ PackageInfoStore pId store
Nothing -> Nothing
2018-10-02 13:17:04 +03:00
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 ::
2019-01-23 17:18:29 +03:00
PackageInfo
2018-10-02 13:17:04 +03:00
-> HCE . ComponentId
-> HCE . HaskellModuleName
-> ( HCE . HaskellModulePath -> ReaderT Environment IO a )
-> ReaderT Environment IO a
2019-01-23 17:18:29 +03:00
withModulePath packageInfo' componentId moduleName action =
case packageInfo' of
PackageInfo packageInfo ->
case HM . lookup
( ghcPrimHack packageInfo' moduleName )
( HCE . moduleNameMap packageInfo ) of
Just modulePathMap ->
case HM . lookup componentId modulePathMap of
Just modulePath -> action modulePath
2018-10-02 13:17:04 +03:00
Nothing ->
2019-01-23 17:18:29 +03:00
case HM . lookup ( HCE . ComponentId " lib " ) modulePathMap of
Just path -> action path
Nothing -> notFoundInComponent
Nothing -> notFoundInPackage ( HCE . id ( packageInfo :: HCE . PackageInfo HCE . CompactModuleInfo ) )
PackageInfoStore packageId store -> do
let eitherModNameMap =
Store . lookup
( packageId
, Proxy :: Proxy ( HM . HashMap HCE . HaskellModuleName ( HM . HashMap HCE . ComponentId HCE . HaskellModulePath ) ) )
store
case eitherModNameMap of
Right modNameMap ->
2019-08-21 13:03:31 +03:00
case HM . lookup ( ghcPrimHack packageInfo' moduleName ) modNameMap of
2019-01-23 17:18:29 +03:00
Just componentMap -> case HM . lookup componentId componentMap of
Just modulePath -> action modulePath
Nothing -> case HM . lookup ( HCE . ComponentId " lib " ) componentMap of
Just modulePath -> action modulePath
Nothing -> notFoundInComponent
Nothing -> notFoundInPackage packageId
Left e -> error500 ( BSL . fromStrict $ BSC . pack e )
where
notFoundInComponent =
error404 $
BSL . concat
[ " Module "
, toLazyBS $ HCE . getHaskellModuleName moduleName
, " is not found in component "
, toLazyBS $ HCE . getComponentId componentId
]
notFoundInPackage packageId =
2018-10-02 13:17:04 +03:00
error404 $
BSL . concat
[ " Module "
, toLazyBS $ HCE . getHaskellModuleName moduleName
, " is not found in package "
2019-01-23 17:18:29 +03:00
, toLazyBS $ HCE . packageIdToText packageId
2018-10-02 13:17:04 +03:00
]
-- | Workaround for :
-- https://github.com/ghc/ghc/blob/ghc-8.2.2-release/compiler/main/Finder.hs#L310-L315
2019-01-23 17:18:29 +03:00
ghcPrimHack :: PackageInfo -> HCE . HaskellModuleName -> HCE . HaskellModuleName
ghcPrimHack packageInfo' modName @ ( HCE . HaskellModuleName name ) =
case packageInfo' of
PackageInfo packageInfo
| HCE . packageName packageInfo == " ghc-prim " && name == " GHC.Prim " ->
HCE . HaskellModuleName " GHC.Prim_ "
| otherwise -> modName
PackageInfoStore ( HCE . PackageId packageName _ ) _
| packageName == " ghc-prim " && name == " GHC.Prim " ->
HCE . HaskellModuleName " GHC.Prim_ "
| otherwise -> modName
2019-08-21 13:03:31 +03:00
2018-10-02 13:17:04 +03:00
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 =
2019-01-23 17:18:29 +03:00
maybe
[]
( map T . strip . T . splitOn " , " . TE . decodeUtf8 )
( lookup " Accept-Encoding " ( requestHeaders req ) )
2018-10-02 13:17:04 +03:00
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
2019-08-21 13:03:31 +03:00
_ -> callback fileNotFound
2018-10-02 13:17:04 +03:00
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 " )
2018-11-07 18:31:43 +03:00
Nothing -> do
let path = T . unpack $ T . intercalate " / " $ pathInfo req
if path == " "
then callback $ sendEmbeddedFile " index.html " indexHtml
else case HM . lookup path staticAssets of
Just bs -> callback $ sendEmbeddedFile path bs
Nothing -> callback $ sendEmbeddedFile " index.html " indexHtml
staticAssets :: HM . HashMap FilePath BS . ByteString
staticAssets = HM . fromList $ ( embedDir " javascript/release " )
indexHtml :: BS . ByteString
indexHtml = $ ( embedFile " javascript/release/index.html " )
2018-10-02 13:17:04 +03:00
sendFile :: FilePath -> Response
sendFile path =
responseFile
status200
[ ( hContentType , defaultMimeLookup $ T . pack $ takeFileName path ) ]
path
Nothing
2018-11-07 18:31:43 +03:00
sendEmbeddedFile :: FilePath -> BS . ByteString -> Response
sendEmbeddedFile path bs =
responseLBS
status200
[ ( hContentType , defaultMimeLookup $ T . pack $ takeFileName path ) ]
2019-08-21 13:03:31 +03:00
( BSL . fromStrict bs )
2018-11-07 18:31:43 +03:00
2018-10-02 13:17:04 +03:00
fileNotFound :: Response
fileNotFound =
responseLBS status404 [ ( " Content-Type " , " text/plain " ) ] " Not found "
2019-08-21 12:59:18 +03:00
# if MIN_VERSION_GLASGOW_HASKELL ( 8 , 6 , 5 , 0 )
throwServantError :: ( MonadIO m ) => ServerError -> m a
# else
2018-10-02 13:17:04 +03:00
throwServantError :: ( MonadIO m ) => ServantErr -> m a
2019-08-21 13:12:17 +03:00
# endif
2019-08-21 13:03:31 +03:00
throwServantError = liftIO . throwIO
2018-10-02 13:17:04 +03:00
server :: Environment -> ServerT API Handler
server env =
hoistServer
( Proxy :: Proxy API )
toServantHandler
( getAllPackages :<|>
2019-08-21 13:03:31 +03:00
getDefinitionSite :<|>
2018-10-02 13:17:04 +03:00
getExpressions :<|>
getReferences :<|>
2018-11-16 16:19:03 +03:00
findIdentifiers :<|>
2019-02-06 21:42:29 +03:00
getGlobalReferences :<|>
2019-02-20 18:58:57 +03:00
findGlobalIdentifiers :<|>
getHoogleDocs )
2018-10-02 13:17:04 +03:00
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
2019-03-26 17:07:04 +03:00
let addDefaultPath :: ServerConfig -> ServerConfig
addDefaultPath config =
if configPackagesPath config == PackagesPath Nothing []
then config { configPackagesPath = PackagesPath Nothing [ " . " ] }
else config
2018-10-02 13:17:04 +03:00
config <-
2019-03-26 17:07:04 +03:00
addDefaultPath <$>
2018-10-02 13:17:04 +03:00
execParser
( Options . Applicative . info
( configParser <**> helper )
( fullDesc <>
progDesc
2019-01-23 17:18:29 +03:00
" haskell-code-server provides an HTTP API for Haskell Code Explorer " ) )
2018-10-02 13:17:04 +03:00
print config
2019-01-23 17:18:29 +03:00
mbStore <-
let loadStore :: FilePath -> Store . ReadMode -> IO ( Maybe Store . Store )
loadStore path readOrMmap = do
eitherStore <- Store . load path readOrMmap
case eitherStore of
Right store -> return $ Just store
Left e -> putStrLn e >> exitFailure
in case configStore config of
Just ( UseStore path ) -> loadStore path Store . ReadEntireFile
Just ( UseStoreMmap path ) -> loadStore path Store . MemoryMapFile
Just ( CreateStore path ) -> do
createStore path config
exitSuccess
Nothing -> return Nothing
packages <- loadPackages config mbStore
2018-10-02 13:17:04 +03:00
case packages of
2019-02-06 21:42:29 +03:00
Just ( packageMap , packagePathMap , packageVersions , globalReferenceMap , globalIdentifierMap ) -> do
2018-10-02 13:17:04 +03:00
loggerSet <-
case configLog config of
HCE . ToFile logfile -> newFileLoggerSet defaultBufSize logfile
HCE . StdOut -> newStdoutLoggerSet defaultBufSize
loggerMiddleware <-
liftIO $
mkRequestLogger
2019-03-26 17:07:04 +03:00
def { outputFormat = Detailed True , destination = Logger loggerSet }
2018-10-02 13:17:04 +03:00
let staticFilePrefix = configStaticFilesUrlPrefix config
mbJsDistPath = configJsDistDirectory config
environment =
Environment
loggerSet
packageMap
( AllPackages . A . encode $ packageVersions )
2018-11-16 16:19:03 +03:00
globalReferenceMap
2019-02-06 21:42:29 +03:00
globalIdentifierMap
2018-10-02 13:17:04 +03:00
config
static =
if configServeStaticFiles config
then staticMiddleware staticFilePrefix packagePathMap mbJsDistPath
else id
run
( configPort config )
( loggerMiddleware . static $ application environment )
Nothing -> putStrLn " No packages found. "