From a1aa9ddd72dfdec47399f29319f821f542906365 Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 4 Nov 2014 00:00:40 +0100 Subject: mv **.hs src/ --- CGroup.hs | 53 ---------- CGroup/Types.hs | 51 ---------- Main.hs | 275 ---------------------------------------------------- Main/Config.hs | 29 ------ Main/Util.hs | 157 ------------------------------ cgroup-server.cabal | 2 +- src/CGroup.hs | 53 ++++++++++ src/CGroup/Types.hs | 51 ++++++++++ src/Main.hs | 275 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Main/Config.hs | 29 ++++++ src/Main/Util.hs | 157 ++++++++++++++++++++++++++++++ 11 files changed, 566 insertions(+), 566 deletions(-) delete mode 100644 CGroup.hs delete mode 100644 CGroup/Types.hs delete mode 100644 Main.hs delete mode 100644 Main/Config.hs delete mode 100644 Main/Util.hs 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 diff --git a/CGroup.hs b/CGroup.hs deleted file mode 100644 index 11b54cd..0000000 --- a/CGroup.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- Module: CGroup --- Copyright: (c) 2014 Tomislav Viljetić --- License: BSD3 --- Maintainer: Tomislav Viljetić --- --- 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/CGroup/Types.hs b/CGroup/Types.hs deleted file mode 100644 index 98422f3..0000000 --- a/CGroup/Types.hs +++ /dev/null @@ -1,51 +0,0 @@ --- | --- Module: CGroup.Types --- Copyright: (c) 2014 Tomislav Viljetić --- License: BSD3 --- Maintainer: Tomislav Viljetić --- - -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/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 diff --git a/Main/Config.hs b/Main/Config.hs deleted file mode 100644 index 47c12ba..0000000 --- a/Main/Config.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | --- Module: Main.Config --- Copyright: (c) 2014 Tomislav Viljetić --- License: BSD3 --- Maintainer: Tomislav Viljetić --- - - -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/Main/Util.hs b/Main/Util.hs deleted file mode 100644 index b02f80c..0000000 --- a/Main/Util.hs +++ /dev/null @@ -1,157 +0,0 @@ --- | --- Module: Main.Util --- Copyright: (c) 2014 Tomislav Viljetić --- License: BSD3 --- Maintainer: Tomislav Viljetić --- --- 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" diff --git a/cgroup-server.cabal b/cgroup-server.cabal index 8977394..cada88e 100644 --- a/cgroup-server.cabal +++ b/cgroup-server.cabal @@ -28,6 +28,6 @@ executable cgroup-server , text >=1.1 && <1.2 , wai >=3.0 && <3.1 , warp >=3.0 && <3.1 - -- hs-source-dirs: + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall 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ć +-- +-- 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ć +-- + +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ć +-- +-- 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ć +-- + + +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ć +-- +-- 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