From a1aa9ddd72dfdec47399f29319f821f542906365 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Tue, 4 Nov 2014 00:00:40 +0100
Subject: mv **.hs src/
---
src/CGroup.hs | 53 ++++++++++
src/CGroup/Types.hs | 51 ++++++++++
src/Main.hs | 275 ++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Main/Config.hs | 29 ++++++
src/Main/Util.hs | 157 ++++++++++++++++++++++++++++++
5 files changed, 565 insertions(+)
create mode 100644 src/CGroup.hs
create mode 100644 src/CGroup/Types.hs
create mode 100644 src/Main.hs
create mode 100644 src/Main/Config.hs
create mode 100644 src/Main/Util.hs
(limited to 'src')
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"
--
cgit v1.2.3