1 files changed, 157 insertions, 0 deletions
diff --git a/Main/Util.hs b/Main/Util.hs
new file mode 100644
index 0000000..b02f80c
--- /dev/null
+++ b/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"