diff options
author | tv <tv@shackspace.de> | 2014-11-04 00:00:40 +0100 |
---|---|---|
committer | tv <tv@shackspace.de> | 2014-11-04 00:00:40 +0100 |
commit | a1aa9ddd72dfdec47399f29319f821f542906365 (patch) | |
tree | b235d966ff561a649fb873072d5edd5969c082a6 /Main | |
parent | 0f447cd62836a5f5b29b8e14263fde89f446f52b (diff) |
mv **.hs src/
Diffstat (limited to 'Main')
-rw-r--r-- | Main/Config.hs | 29 | ||||
-rw-r--r-- | Main/Util.hs | 157 |
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" |