diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/CGroup.hs | 53 | ||||
| -rw-r--r-- | src/CGroup/Types.hs | 51 | ||||
| -rw-r--r-- | src/Main.hs | 275 | ||||
| -rw-r--r-- | src/Main/Config.hs | 29 | ||||
| -rw-r--r-- | src/Main/Util.hs | 157 |
5 files changed, 565 insertions, 0 deletions
diff --git a/src/CGroup.hs b/src/CGroup.hs new file mode 100644 index 0000000..11b54cd --- /dev/null +++ b/src/CGroup.hs @@ -0,0 +1,53 @@ +-- | +-- Module: CGroup +-- Copyright: (c) 2014 Tomislav Viljetić +-- License: BSD3 +-- Maintainer: Tomislav Viljetić <tomislav@viljetic.de> +-- +-- Basic cgroup virtual filesystem operations. +-- + +module CGroup + ( module CGroup.Types + , createCGroup + , classifyTask + , listTasks + ) where + +import CGroup.Types +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 +import Data.Set (Set) +import qualified Data.Set as Set +import System.Directory (createDirectory) +import System.FilePath ((</>)) +import System.IO.Streams.Attoparsec (parseFromStream) +import System.IO.Streams.File (withFileAsInput) + + +-- | Create a new cgroup. +createCGroup :: CGroup -> IO () +createCGroup = + createDirectory . cgroupPath + + +-- | Places a task into a cgroup. +classifyTask :: ProcessID -> CGroup -> IO () +classifyTask pid g = + writeFile (tasksFile g) (show pid) + + +-- | Retrieve the tasks of a cgroup. +listTasks :: CGroup -> IO (Set ProcessID) +listTasks g = + withFileAsInput (tasksFile g) $ parseFromStream tasksParser + + +tasksFile :: CGroup -> FilePath +tasksFile = + (</> "tasks") . cgroupPath + + +tasksParser :: Parser (Set ProcessID) +tasksParser = + Set.fromList <$> many' (decimal <* endOfLine) <* endOfInput <?> "tasks" diff --git a/src/CGroup/Types.hs b/src/CGroup/Types.hs new file mode 100644 index 0000000..98422f3 --- /dev/null +++ b/src/CGroup/Types.hs @@ -0,0 +1,51 @@ +-- | +-- Module: CGroup.Types +-- Copyright: (c) 2014 Tomislav Viljetić +-- License: BSD3 +-- Maintainer: Tomislav Viljetić <tomislav@viljetic.de> +-- + +module CGroup.Types + ( + -- * CGroup + CGroup + , cgroup + , cgroupPath + -- * Other types + , ProcessID + ) where + +import Data.Monoid +import qualified System.FilePath as FP + + +-- | A 'CGroup' is defined by two 'FilePath's, a mount point and a cgroup +-- name. The mount point specifies where the cgroup hierarchy is mounted. +-- The cgroup name is a directory, relative to the mount point. +data CGroup = CGroup { mountPoint, cgroupName :: FilePath } + deriving Show + + +-- | Smart constructor. Takes a mount point and a cgroup name. +-- It will return 'Nothing' if the cgroup could point outside the mount point, +-- i.e. if the cgroup name is an absolute path, or contains @".."@. +cgroup :: FilePath -> FilePath -> Maybe CGroup +cgroup mp0 cgn0 + | ".." `elem` parts = Nothing + | FP.isAbsolute cgn = Nothing + | otherwise = Just CGroup { mountPoint = mp, cgroupName = cgn } + where + mp = normaliseMountPoint mp0 + cgn = normaliseCGroupName cgn0 + parts = FP.splitDirectories cgn + normaliseMountPoint = FP.addTrailingPathSeparator . FP.normalise + normaliseCGroupName = FP.dropTrailingPathSeparator . FP.normalise + + +-- | Path of a cgroup's tasks file. +cgroupPath :: CGroup -> FilePath +cgroupPath CGroup { mountPoint = mp, cgroupName = cgn } = + mp <> cgn + + +type ProcessID = Int diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..3a41de4 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Main/Config.hs b/src/Main/Config.hs new file mode 100644 index 0000000..47c12ba --- /dev/null +++ b/src/Main/Config.hs @@ -0,0 +1,29 @@ +-- | +-- Module: Main.Config +-- Copyright: (c) 2014 Tomislav Viljetić +-- License: BSD3 +-- Maintainer: Tomislav Viljetić <tomislav@viljetic.de> +-- + + +module Main.Config (Config(..), defaultConfig) where + +import Network.Wai.Handler.Warp (Port) + + +data Config = Config + { cgroupRoot :: FilePath + , httpPort :: Port + } + + +-- | +-- +-- > cgroupRoot = "/sys/fs/cgroup" +-- > httpPort = 8001 +-- +defaultConfig :: Config +defaultConfig = Config + { cgroupRoot = "/sys/fs/cgroup" + , httpPort = 8001 + } diff --git a/src/Main/Util.hs b/src/Main/Util.hs new file mode 100644 index 0000000..b02f80c --- /dev/null +++ b/src/Main/Util.hs @@ -0,0 +1,157 @@ +-- | +-- Module: Main.Util +-- Copyright: (c) 2014 Tomislav Viljetić +-- License: BSD3 +-- Maintainer: Tomislav Viljetić <tomislav@viljetic.de> +-- +-- Grab bag of utilities used by "Main". This module is used to keep +-- "Main" as application-focused as possible. +-- + +{-# LANGUAGE OverloadedStrings #-} + + +module Main.Util + ( + -- * Data.List utilities + splitLast, + -- * Network.Wai utilities + pathInfoString, + handleMethod, + okJSON, + noContent, + badRequest, + badRequest', + forbidden, + notFound, + notAllowed, + conflict, + conflict', + internalServerError, + internalServerError', + ) where + +import Data.Aeson (encode, ToJSON) +import Data.Monoid +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.Text.Lazy as LT +import Network.HTTP.Types +import Network.Wai +import Safe + + + +splitLast :: [a] -> ([a], a) +splitLast xs = + (init xs, last xs) + + +-- | Like 'pathInfo', but returns 'String's instead. +pathInfoString :: Request -> [String] +pathInfoString = map T.unpack . pathInfo + + +-- | Route a request based on it's method. +-- If no application is associated with the request's method, +-- then 'notAllowed' is used. +handleMethod :: [(Method, Application)] -> Application +handleMethod apps req respond = + app req respond + where + app = lookupJustDef (notAllowed allow) (requestMethod req) apps + allow = map fst apps + + +okJSON :: ToJSON a => a -> Application +okJSON = respondJSON [] ok200 + + +noContent :: Application +noContent = respondEmpty [] noContent204 + + +badRequest :: Application +badRequest = respondEmpty [] badRequest400 + + +badRequest' :: LT.Text -> Application +badRequest' = respondText [] badRequest400 + + +forbidden :: Application +forbidden = respondEmpty [] forbidden403 + + +notFound :: Application +notFound = respondEmpty [] notFound404 + + +notAllowed :: [Method] -> Application +notAllowed allow = + respondEmpty [(hAllow, BS8.intercalate ", " allow)] methodNotAllowed405 + + +conflict :: Application +conflict = + respondEmpty [] conflict409 + + +conflict' :: BS.ByteString -> Application +conflict' msg = + respondEmpty [] status + where + status = mkStatus 409 $ "Conflict (" <> msg <> ")" + + +internalServerError :: Application +internalServerError = + respondEmpty [] internalServerError500 + + +internalServerError' :: BS.ByteString -> Application +internalServerError' msg = + respondEmpty [] status + where + status = mkStatus 500 $ "Internal Server Error (" <> msg <> ")" + + + +-- XXX currently it's not always possible to send a truly empty response. +-- because 'Network.Wai.Handler.Warp.Response.hasBody' only discriminates +-- by status code and request method. This means that empty responses may +-- contain superfluous headers like @Transfer-Encoding@. This behavior +-- should not cause any problems, though. +respondEmpty :: ResponseHeaders -> Status -> Application +respondEmpty extraHeaders status = + respondLBS status extraHeaders "" + + +respondJSON :: ToJSON a => ResponseHeaders -> Status -> a -> Application +respondJSON extraHeaders status = + respondLBS status headers . encode + where + headers = (hContentType, "application/json") : extraHeaders + + +respondText :: ResponseHeaders -> Status -> LT.Text -> Application +respondText extraHeaders status = + respondLBS status headers . LT.encodeUtf8 + where + headers = (hContentType, "text/plain; charset=utf-8") : extraHeaders + + + +respondLBS :: Status -> ResponseHeaders -> LBS.ByteString -> Application +respondLBS status headers bs _req respond = + respond $ responseLBS status headers bs + + + +-- | HTTP Header names, missing from 'Network.HTTP.Types.Header'. + +hAllow :: HeaderName +hAllow = "Allow" |