summaryrefslogtreecommitdiffstats
path: root/Main
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-11-04 00:00:40 +0100
committertv <tv@shackspace.de>2014-11-04 00:00:40 +0100
commita1aa9ddd72dfdec47399f29319f821f542906365 (patch)
treeb235d966ff561a649fb873072d5edd5969c082a6 /Main
parent0f447cd62836a5f5b29b8e14263fde89f446f52b (diff)
mv **.hs src/
Diffstat (limited to 'Main')
-rw-r--r--Main/Config.hs29
-rw-r--r--Main/Util.hs157
2 files changed, 0 insertions, 186 deletions
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ć <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/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ć <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"