summaryrefslogtreecommitdiffstats
path: root/Main.hs
blob: 3a41de408300ca9ae0c2a4e0ae76e39c99d4f9b7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
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