diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 275 |
1 files changed, 275 insertions, 0 deletions
@@ -0,0 +1,275 @@ +-- | +-- Module: Main +-- Copyright: (c) 2014 Tomislav Viljetić +-- License: BSD3 +-- Maintainer: Tomislav Viljetić <tomislav@viljetic.de> +-- +-- 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 |