mv **.hs src/

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"