<commit_before>{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Distribution.Server (
    -- * Server control
    Server(..),
    ServerEnv(..),
    initialise,
    run,
    shutdown,
    checkpoint,

    -- * Server configuration
    ListenOn(..),
    ServerConfig(..),
    defaultServerConfig,
    hasSavedState,

    -- * Server state
    serverState,
    initState,

    -- * Temporary server while loading data
    setUpTemp,
    tearDownTemp
 ) where

import Distribution.Server.Framework
import qualified Distribution.Server.Framework.BackupRestore as Import
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Framework.Auth as Auth
import Distribution.Server.Framework.Templating (TemplatesMode(NormalMode))
import Distribution.Server.Framework.AuthTypes (PasswdPlain(..))

import Distribution.Server.Framework.Feature as Feature
import qualified Distribution.Server.Features as Features
import Distribution.Server.Features.Users

import qualified Distribution.Server.Users.Types as Users
import qualified Distribution.Server.Users.Users as Users
import qualified Distribution.Server.Users.Group as Group

import Distribution.Text
import Distribution.Verbosity as Verbosity

import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import Control.Concurrent
import Network.URI (URI(..), URIAuth(URIAuth), nullURI)
import Network.BSD (getHostName)
import Data.List (foldl', nubBy)
import Data.Int  (Int64)
import Control.Arrow (second)
import Data.Function (on)
import qualified System.Log.Logger as HsLogger

import Paths_hackage_server (getDataDir)


data ListenOn = ListenOn {
  loPortNum :: Int,
  loIP :: String
} deriving (Show)

data ServerConfig = ServerConfig {
  confVerbosity :: Verbosity,
  confHostUri   :: URI,
  confListenOn  :: ListenOn,
  confStateDir  :: FilePath,
  confStaticDir :: FilePath,
  confTmpDir    :: FilePath,
  confCacheDelay:: Int
} deriving (Show)

confDbStateDir, confBlobStoreDir,
  confStaticFilesDir, confTemplatesDir :: ServerConfig -> FilePath
confDbStateDir   config = confStateDir config </> "db"
confBlobStoreDir config = confStateDir config </> "blobs"
confStaticFilesDir config = confStaticDir config </> "static"
confTemplatesDir   config = confStaticDir config </> "templates"

defaultServerConfig :: IO ServerConfig
defaultServerConfig = do
  hostName <- getHostName
  dataDir  <- getDataDir
  let portnum = 8080 :: Int
  return ServerConfig {
    confVerbosity = Verbosity.normal,
    confHostUri   = nullURI {
                      uriScheme    = "http:",
                      uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
                    },
    confListenOn  = ListenOn {
                        loPortNum = 8080,
                        loIP = "0.0.0.0"
                    },
    confStateDir  = "state",
    confStaticDir = dataDir,
    confTmpDir    = "state" </> "tmp",
    confCacheDelay= 0
  }

data Server = Server {
  serverFeatures    :: [HackageFeature],
  serverUserFeature :: UserFeature,
  serverListenOn    :: ListenOn,
  serverEnv         :: ServerEnv
}

-- | If we made a server instance from this 'ServerConfig', would we find some
-- existing saved state or would it be a totally clean instance with no
-- existing state.
--
hasSavedState :: ServerConfig -> IO Bool
hasSavedState = doesDirectoryExist . confDbStateDir

-- | Make a server instance from the server configuration.
--
-- This does not yet run the server (see 'run') but it does setup the server
-- state system, making it possible to import data, and initializes the
-- features.
--
-- Note: the server instance must eventually be 'shutdown' or you'll end up
-- with stale lock files.
--
initialise :: ServerConfig -> IO Server
initialise config@(ServerConfig verbosity hostURI listenOn
                                    stateDir _ tmpDir
                                    cacheDelay) = do
    createDirectoryIfMissing False stateDir
    let blobStoreDir  = confBlobStoreDir   config
        staticDir     = confStaticFilesDir config
        templatesDir  = confTemplatesDir   config

    store   <- BlobStorage.open blobStoreDir

    let env = ServerEnv {
            serverStaticDir     = staticDir,
            serverTemplatesDir  = templatesDir,
            serverTemplatesMode = NormalMode,
            serverStateDir      = stateDir,
            serverBlobStore     = store,
            serverTmpDir        = tmpDir,
            serverCacheDelay    = cacheDelay * 1000000, --microseconds
            serverBaseURI       = hostURI,
            serverVerbosity     = verbosity
         }
    -- do feature initialization
    (features, userFeature) <- Features.initHackageFeatures env

    return Server {
        serverFeatures    = features,
        serverUserFeature = userFeature,
        serverListenOn    = listenOn,
        serverEnv         = env
    }

-- | Actually run the server, i.e. start accepting client http connections.
--
run :: Server -> IO ()
run server = do
    -- We already check this in Main, so we expect this check to always
    -- succeed, but just in case...
    let staticDir = serverStaticDir (serverEnv server)
    exists <- doesDirectoryExist staticDir
    when (not exists) $ fail $ "The static files directory " ++ staticDir ++ " does not exist."

    runServer listenOn $ do

      handlePutPostQuotas

      setLogging

      fakeBrowserHttpMethods (impl server)

  where
    listenOn = serverListenOn server

    -- HS6 - Quotas should be configurable as well. Also there are places in
    -- the code that want to work with the request body directly but maybe
    -- fail if the request body has already been consumed. The body will only
    -- be consumed if it is a POST/PUT request *and* the content-type is
    -- multipart/form-data. If this does happen, you should get a clear error
    -- message saying what happened.
    handlePutPostQuotas = decodeBody bodyPolicy
      where
        tmpdir = serverTmpDir (serverEnv server)
        quota  = 10 ^ (6 :: Int64)
        bodyPolicy = defaultBodyPolicy tmpdir quota quota quota

    setLogging =
        liftIO $ HsLogger.updateGlobalLogger
                   "Happstack.Server"
                   (adjustLogLevel (serverVerbosity (serverEnv server)))
      where
        adjustLogLevel v
          | v == Verbosity.normal    = HsLogger.setLevel HsLogger.WARNING
          | v == Verbosity.verbose   = HsLogger.setLevel HsLogger.INFO
          | v == Verbosity.deafening = HsLogger.setLevel HsLogger.DEBUG
          | otherwise                = id

    -- This is a cunning hack to solve the problem that current web browsers
    -- (non-HTML5 forms) do not support PUT, DELETE, etc, they only support GET
    -- and POST. We don't want to compromise the design of the whole server
    -- just because of browsers not supporting HTTP properly, so we allow<commit_msg>adjusting upload limit as per suggestion in ticket https://github.com/haskell/hackage-server/issues/53<commit_after>{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Distribution.Server (
    -- * Server control
    Server(..),
    ServerEnv(..),
    initialise,
    run,
    shutdown,
    checkpoint,

    -- * Server configuration
    ListenOn(..),
    ServerConfig(..),
    defaultServerConfig,
    hasSavedState,

    -- * Server state
    serverState,
    initState,

    -- * Temporary server while loading data
    setUpTemp,
    tearDownTemp
 ) where

import Distribution.Server.Framework
import qualified Distribution.Server.Framework.BackupRestore as Import
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Framework.Auth as Auth
import Distribution.Server.Framework.Templating (TemplatesMode(NormalMode))
import Distribution.Server.Framework.AuthTypes (PasswdPlain(..))

import Distribution.Server.Framework.Feature as Feature
import qualified Distribution.Server.Features as Features
import Distribution.Server.Features.Users

import qualified Distribution.Server.Users.Types as Users
import qualified Distribution.Server.Users.Users as Users
import qualified Distribution.Server.Users.Group as Group

import Distribution.Text
import Distribution.Verbosity as Verbosity

import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import Control.Concurrent
import Network.URI (URI(..), URIAuth(URIAuth), nullURI)
import Network.BSD (getHostName)
import Data.List (foldl', nubBy)
import Data.Int  (Int64)
import Control.Arrow (second)
import Data.Function (on)
import qualified System.Log.Logger as HsLogger

import Paths_hackage_server (getDataDir)


data ListenOn = ListenOn {
  loPortNum :: Int,
  loIP :: String
} deriving (Show)

data ServerConfig = ServerConfig {
  confVerbosity :: Verbosity,
  confHostUri   :: URI,
  confListenOn  :: ListenOn,
  confStateDir  :: FilePath,
  confStaticDir :: FilePath,
  confTmpDir    :: FilePath,
  confCacheDelay:: Int
} deriving (Show)

confDbStateDir, confBlobStoreDir,
  confStaticFilesDir, confTemplatesDir :: ServerConfig -> FilePath
confDbStateDir   config = confStateDir config </> "db"
confBlobStoreDir config = confStateDir config </> "blobs"
confStaticFilesDir config = confStaticDir config </> "static"
confTemplatesDir   config = confStaticDir config </> "templates"

defaultServerConfig :: IO ServerConfig
defaultServerConfig = do
  hostName <- getHostName
  dataDir  <- getDataDir
  let portnum = 8080 :: Int
  return ServerConfig {
    confVerbosity = Verbosity.normal,
    confHostUri   = nullURI {
                      uriScheme    = "http:",
                      uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
                    },
    confListenOn  = ListenOn {
                        loPortNum = 8080,
                        loIP = "0.0.0.0"
                    },
    confStateDir  = "state",
    confStaticDir = dataDir,
    confTmpDir    = "state" </> "tmp",
    confCacheDelay= 0
  }

data Server = Server {
  serverFeatures    :: [HackageFeature],
  serverUserFeature :: UserFeature,
  serverListenOn    :: ListenOn,
  serverEnv         :: ServerEnv
}

-- | If we made a server instance from this 'ServerConfig', would we find some
-- existing saved state or would it be a totally clean instance with no
-- existing state.
--
hasSavedState :: ServerConfig -> IO Bool
hasSavedState = doesDirectoryExist . confDbStateDir

-- | Make a server instance from the server configuration.
--
-- This does not yet run the server (see 'run') but it does setup the server
-- state system, making it possible to import data, and initializes the
-- features.
--
-- Note: the server instance must eventually be 'shutdown' or you'll end up
-- with stale lock files.
--
initialise :: ServerConfig -> IO Server
initialise config@(ServerConfig verbosity hostURI listenOn
                                    stateDir _ tmpDir
                                    cacheDelay) = do
    createDirectoryIfMissing False stateDir
    let blobStoreDir  = confBlobStoreDir   config
        staticDir     = confStaticFilesDir config
        templatesDir  = confTemplatesDir   config

    store   <- BlobStorage.open blobStoreDir

    let env = ServerEnv {
            serverStaticDir     = staticDir,
            serverTemplatesDir  = templatesDir,
            serverTemplatesMode = NormalMode,
            serverStateDir      = stateDir,
            serverBlobStore     = store,
            serverTmpDir        = tmpDir,
            serverCacheDelay    = cacheDelay * 1000000, --microseconds
            serverBaseURI       = hostURI,
            serverVerbosity     = verbosity
         }
    -- do feature initialization
    (features, userFeature) <- Features.initHackageFeatures env

    return Server {
        serverFeatures    = features,
        serverUserFeature = userFeature,
        serverListenOn    = listenOn,
        serverEnv         = env
    }

-- | Actually run the server, i.e. start accepting client http connections.
--
run :: Server -> IO ()
run server = do
    -- We already check this in Main, so we expect this check to always
    -- succeed, but just in case...
    let staticDir = serverStaticDir (serverEnv server)
    exists <- doesDirectoryExist staticDir
    when (not exists) $ fail $ "The static files directory " ++ staticDir ++ " does not exist."

    runServer listenOn $ do

      handlePutPostQuotas

      setLogging

      fakeBrowserHttpMethods (impl server)

  where
    listenOn = serverListenOn server

    -- HS6 - Quotas should be configurable as well. Also there are places in
    -- the code that want to work with the request body directly but maybe
    -- fail if the request body has already been consumed. The body will only
    -- be consumed if it is a POST/PUT request *and* the content-type is
    -- multipart/form-data. If this does happen, you should get a clear error
    -- message saying what happened.
    handlePutPostQuotas = decodeBody bodyPolicy
      where
        tmpdir = serverTmpDir (serverEnv server)
        quota  = 50 * (1024 ^ (2:: Int64))
                -- setting quota at 50mb, though perhaps should be configurable?
        bodyPolicy = defaultBodyPolicy tmpdir quota quota quota

    setLogging =
        liftIO $ HsLogger.updateGlobalLogger
                   "Happstack.Server"
                   (adjustLogLevel (serverVerbosity (serverEnv server)))
      where
        adjustLogLevel v
          | v == Verbosity.normal    = HsLogger.setLevel HsLogger.WARNING
          | v == Verbosity.verbose   = HsLogger.setLevel HsLogger.INFO
          | v == Verbosity.deafening = HsLogger.setLevel HsLogger.DEBUG
          | otherwise                = id

    -- This is a cunning hack to solve the problem that current web browsers
    -- (non-HTML5 forms) do not support PUT, DELETE, etc, they only support GET
    -- and POST. We don't want to compromise the design of the whole server
    -- just because of browsers not supporting HTTP properly, so we allow
{'fraction_non_alphanumeric': 0.07554984290202799, 'fraction_numerical': 0.004712939160239932, 'mean_word_length': 2.7089512711864407, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 21, 'https://': 1, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 2, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6236111', 'n_tokens_mistral': 3821, 'n_tokens_neox': 3672, 'n_words': 1231}