hackage-server-0.5.0: Distribution/Server.hs
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Distribution.Server (
-- * Server control
Server(..),
ServerEnv(..),
initialise,
run,
shutdown,
checkpoint,
reloadDatafiles,
-- * Server configuration
ListenOn(..),
ServerConfig(..),
defaultServerConfig,
hasSavedState,
-- * Server state
serverState,
initState,
-- * Temporary server while loading data
setUpTemp,
tearDownTemp
) where
import Happstack.Server.SimpleHTTP
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.HtmlFormWrapper (htmlFormWrapperHack)
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 Control.Exception.Lifted as Lifted
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
mkServerEnv :: ServerConfig -> IO ServerEnv
mkServerEnv config@(ServerConfig verbosity hostURI _
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
}
return env
-- | 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 = do
env <- mkServerEnv config
-- do feature initialization
(features, userFeature) <- Features.initHackageFeatures env
return Server {
serverFeatures = features,
serverUserFeature = userFeature,
serverListenOn = confListenOn config,
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 HTML 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 HTML does not
-- support HTTP properly, so we allow browsers using HTML forms to do
-- PUT/DELETE etc by POSTing with special body parameters.
fakeBrowserHttpMethods part =
msum [ do method POST
htmlFormWrapperHack part
-- or just do things the normal way
, part
]
-- | Perform a clean shutdown of the server.
--
shutdown :: Server -> IO ()
shutdown server =
Features.shutdownAllFeatures (serverFeatures server)
--TODO: stop accepting incomming connections,
-- wait for connections to be processed.
-- | Write out a checkpoint of the server state. This makes recovery quicker
-- because fewer logged transactions have to be replayed.
--
checkpoint :: Server -> IO ()
checkpoint server =
Features.checkpointAllFeatures (serverFeatures server)
reloadDatafiles :: Server -> IO ()
reloadDatafiles server =
mapM_ Feature.featureReloadFiles (serverFeatures server)
-- | Return /one/ abstract state component per feature
serverState :: Server -> [(String, AbstractStateComponent)]
serverState server = [ (featureName feature, mconcat (featureState feature))
| feature <- serverFeatures server
]
-- An alternative to an import: starts the server off to a sane initial state.
-- To accomplish this, we import a 'null' tarball, finalizing immediately after initializing import
initState :: Server -> (String, String) -> IO ()
initState server (admin, pass) = do
let store = serverBlobStore (serverEnv server)
void . Import.importBlank store $ map (second abstractStateRestore) (serverState server)
-- create default admin user
let UserFeature{updateAddUser, adminGroup} = serverUserFeature server
muid <- case simpleParse admin of
Just uname -> do
let userAuth = Auth.newPasswdHash Auth.hackageRealm uname (PasswdPlain pass)
updateAddUser uname (Users.UserAuth userAuth)
Nothing -> fail "Couldn't parse admin name (should be alphanumeric)"
case muid of
Right uid -> Group.addUserList adminGroup uid
Left Users.ErrUserNameClash -> fail $ "Inconceivable!! failed to create admin user"
-- The top-level server part.
-- It collects resources from Distribution.Server.Features, collects
-- them into a path hierarchy, and serves them.
impl :: Server -> ServerPart Response
impl server = logExceptions $
runServerPartE $
handleErrorResponse (serveErrorResponse errHandlers Nothing) $
renderServerTree [] serverTree
`mplus`
fallbackNotFound
where
serverTree :: ServerTree (DynamicPath -> ServerPartE Response)
serverTree =
fmap (serveResource errHandlers)
-- ServerTree Resource
. foldl' (\acc res -> addServerNode (resourceLocation res) res acc) serverTreeEmpty
-- [Resource]
$ concatMap Feature.featureResources (serverFeatures server)
errHandlers = nubBy ((==) `on` fst)
. reverse
. (("txt", textErrorPage):)
. concatMap Feature.featureErrHandlers
$ serverFeatures server
-- This basic one be overridden in another feature but means even in a
-- minimal server we can provide content-negoticated text/plain errors
textErrorPage :: ErrorResponse -> ServerPartE Response
textErrorPage = return . toResponse
fallbackNotFound =
errNotFound "Page not found"
[MText "Sorry, it's just not here."]
logExceptions :: ServerPart Response -> ServerPart Response
logExceptions act = Lifted.catch act $ \e -> do
liftIO . lognotice verbosity $ "WARNING: Received exception: " ++ show e
Lifted.throwIO (e :: SomeException)
verbosity = serverVerbosity (serverEnv server)
data TempServer = TempServer ThreadId
setUpTemp :: ServerConfig -> Int -> IO TempServer
setUpTemp sconf secs = do
tid <- forkIO $ do
-- wait a certain amount of time before setting it up, because sometimes
-- happstack-state is very fast, and switching the servers has a time
-- cost to it
threadDelay $ secs*1000000
-- could likewise specify a mirror to redirect to for tarballs, and 503 for everything else
runServer listenOn $ (resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503)
return (TempServer tid)
where listenOn = confListenOn sconf
runServer :: (ToMessage a) => ListenOn -> ServerPartT IO a -> IO ()
runServer listenOn f
= do socket <- bindIPv4 (loIP listenOn) (loPortNum listenOn)
simpleHTTPWithSocket socket nullConf f
-- | Static 503 page, based on Happstack's 404 page.
html503 :: String
html503 =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" ++
"<html><head><title>503 Service Unavailable</title></head><body><h1>" ++
"503 Service Unavailable</h1><p>The server is undergoing maintenance" ++
"<br>It'll be back soon</p></body></html>"
tearDownTemp :: TempServer -> IO ()
tearDownTemp (TempServer tid) = do
killThread tid
-- give the server enough time to release the bind
threadDelay $ 1000000