From a1aa9ddd72dfdec47399f29319f821f542906365 Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 4 Nov 2014 00:00:40 +0100 Subject: mv **.hs src/ --- Main.hs | 275 ---------------------------------------------------------------- 1 file changed, 275 deletions(-) delete mode 100644 Main.hs (limited to 'Main.hs') diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 3a41de4..0000000 --- a/Main.hs +++ /dev/null @@ -1,275 +0,0 @@ --- | --- Module: Main --- Copyright: (c) 2014 Tomislav Viljetić --- License: BSD3 --- Maintainer: Tomislav Viljetić --- --- An 'Application' that provides a HTTP API to manage cgroups. --- --- The API documentation isn't formalized, but examples can be found in the --- description of the resources handlers ('putCGroupH', 'postTasksH', and --- 'getTasksH'). The examples only contain HTTP headers that are relevant to --- the handlers. A real request may require further headers (such as @Host@) --- to be effective. In addition the HTTP version is omitted in both, the --- request line and the status line. --- - -{-# LANGUAGE OverloadedStrings #-} - - -module Main - ( - -- * Run the application - main, - start, - - -- * Resource - Resource(..), - requestResource, - resourceHandler, - - -- ** Resource Handler - cgroupH, - tasksH, - - -- *** CGroup Handler - putCGroupH, - - -- *** Task File Handler - postTasksH, - getTasksH, - - ) where - -import CGroup -import Control.Applicative -import Control.Exception -import Data.Attoparsec.ByteString.Char8 (decimal, endOfInput, parseOnly) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import Data.List (isInfixOf) -import Main.Config -import Main.Util -import Network.Wai.Handler.Warp (run) -import Network.Wai -import System.FilePath -import System.IO.Error - - --- | The sum of all resources known by the application. --- This type is used to route a 'Request' to a resource handler --- 'Application'. -data Resource - = CGroupR CGroup - -- ^ A cgroup. - | TasksR CGroup - -- ^ A cgroup's tasks file. - - --- | Run the application with the default configuration. --- This calls 'start' with 'defaultConfig'. -main :: IO () -main = start defaultConfig - - --- | Run the application with the given configuration. -start :: Config -> IO () -start c = - run (httpPort c) $ \req -> - resourceHandler (requestResource c req) req - - --- | Determine which request is requested. -requestResource :: Config -> Request -> Maybe Resource --- TODO Config should contain a list of all filenames that cannot be used as --- cgroup name. This implies new error modes -requestResource c req = - if length parts > 1 - then case splitLast parts of - (initparts, "tasks") -> - TasksR <$> toCGroup initparts - _ -> - CGroupR <$> toCGroup parts - else Nothing - where - parts = pathInfoString req - toCGroup (phead:ptail) = cgroup (toMountPoint phead) (joinPath ptail) - toCGroup _ = error "App.route.toCGroup: empty list" - toMountPoint = (cgroupRoot c ) - - --- | Return the resource handler for a specific resource. -resourceHandler :: Maybe Resource -> Application -resourceHandler r = case r of - Just (CGroupR g) -> cgroupH g - Just (TasksR g) -> tasksH g - Nothing -> notFound - - -cgroupH :: CGroup -> Application -cgroupH g = - handleMethod - [ ("PUT", putCGroupH g) - ] - -tasksH :: CGroup -> Application -tasksH g = - handleMethod - [ ("GET", getTasksH g) - , ("POST", postTasksH g) - ] - - --- | Create a new cgroup. --- --- __Example:__ --- (Create a new cgroup @users\/alice@ in the hierarchy @cpu@.) --- --- > PUT /cpu/users/alice HTTP/1.1 --- --- --- If the request was successful, then the server will respond with: --- --- > HTTP/1.1 204 No Content --- --- The request may fail with: --- --- * @403 Forbidden@ --- The servers has no permission to create the cgroup. --- --- * @404 Not Found@ --- Either the hierarchy @cpu@ or, when creating a subcgroup, --- the cgroup @users@ does not exist. --- --- * @409 Conflict@ --- The cgroup already exists. --- --- * @500 Internal Server Error@ --- Calling 'System.Directory.createDirectory' failed for any other reason. --- -putCGroupH :: CGroup -> Application -putCGroupH g req respond = do - x <- try $ createCGroup g - either failure success x req respond - where - success () = noContent - failure e - | isPermissionError e = forbidden - | isAlreadyExistsError e = conflict - | isDoesNotExistError e = notFound - | otherwise = internalServerError' $ BS8.pack $ show e - - --- | Place a process into a cgroup. --- --- __Example:__ --- (Move process @1337@ to cgroup @users\/alice@ of the hierarchy @cpu@.) --- --- > POST /cpu/users/alice/tasks HTTP/1.1 --- > --- > 1337 --- --- --- If the request was successful, then the server will respond with: --- --- > HTTP/1.1 204 No Content --- --- --- The request may fail with: --- --- * @400 Bad Request@ --- The request body does not contain a decimal representation of a PID. --- --- * @403 Forbidden@ --- The servers has no permission to open the tasks file for writing. --- --- * @404 Not Found@ --- The cgroup doesn't exist. --- --- * @409 Conflict (Cannot Move Process)@ --- The servers has no permission to move the process @1337@ to the cgroup. --- --- * @409 Conflict (No Such Process)@ --- The process @1337@ doesn't exist. --- --- * @500 Internal Server Error@ --- Calling 'System.IO.writeFile' failed for any other reason. --- -postTasksH :: CGroup -> Application -postTasksH g req respond = do - b <- LBS.toStrict <$> strictRequestBody req - case parseOnly (decimal <* endOfInput) b of - Left _ -> - badRequest req respond - Right pid -> do - x <- try $ classifyTask pid g - either failure success x req respond - where - success () = noContent - - -- XXX string-typed exception handler - -- - -- We're analyzing the error string to tell if there's a problem with - -- - -- * the task (Conflict; Cannot Move Process, No Such Process) - -- * the cgroup (Forbidden, NotFound) - -- - -- TODO replace stringly-typed exceptions with real type. - -- In 'classifyTask', replace 'writeFile' by explicit calls to 'openFile' - -- and 'hClose' in order tell apart the error cases. - failure e - | isPermissionError e = - if isOpenFileError e - then forbidden - else conflict' "Cannot Move Process" - | isDoesNotExistError e = - if isOpenFileError e - then notFound - else conflict' "No Such Process" - | otherwise = - internalServerError' $ BS8.pack $ show e - where - isOpenFileError :: IOError -> Bool - isOpenFileError = - isInfixOf "openFile" . show - - --- | List the tasks (PIDs) for a given cgroup. --- --- --- __Example:__ --- (Retrieve all tasks of cgroup @users\/alice@ of the hierarchy @cpu@.) --- --- > GET /cpu/alice/tasks HTTP/1.1 --- --- --- If the request was successful, then the server will respond with: --- --- > HTTP/1.1 200 OK --- > Content-Type: application/json --- > --- > [1337] --- --- --- The request may fail with: --- --- * @403 Forbidden@ --- If the server has no permission to read to the tasks file: --- --- * @404 Not Found@ --- If the cgroup doesn't exist: --- --- * @500 Internal Server Error@ --- Calling 'System.IO.Streams.File.withFileAsInput' failed for any other --- reason. --- -getTasksH :: CGroup -> Application -getTasksH g req respond = do - x <- try $ listTasks g - either failure success x req respond - where - success = okJSON - failure e - | isPermissionError e = forbidden - | isDoesNotExistError e = notFound - | otherwise = internalServerError' $ BS8.pack $ show e -- cgit v1.2.3