105 lines
3.5 KiB
Haskell
105 lines
3.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Middleware where
|
|
|
|
import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Monoid (mconcat)
|
|
|
|
import Database.HDBC (runRaw)
|
|
import Database.HDBC.PostgreSQL (Connection)
|
|
import Database.HDBC.Types (SqlError(..))
|
|
|
|
import Data.String.Conversions(cs)
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import Control.Exception (finally, throw, catchJust, catch, SomeException,
|
|
bracket_)
|
|
|
|
import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
|
|
hLocation)
|
|
import Network.HTTP.Types.Status (status400, status401, status301)
|
|
import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
|
|
rawQueryString, isSecure)
|
|
import Network.URI (URI(..), parseURI)
|
|
|
|
import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
|
|
import Codec.Binary.Base64.String (decode)
|
|
|
|
inTransaction :: (Connection -> Application) -> Connection -> Application
|
|
inTransaction app conn req respond =
|
|
finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
|
|
|
|
withSavepoint :: (Connection -> Application) -> Connection -> Application
|
|
withSavepoint app conn req respond = do
|
|
runRaw conn "savepoint req_sp"
|
|
catch (app conn req respond) (\e -> let _ = (e::SomeException) in
|
|
runRaw conn "rollback to savepoint req_sp" >> throw e)
|
|
|
|
authenticated :: BS.ByteString -> (Connection -> Application) ->
|
|
Connection -> Application
|
|
authenticated anon app conn req respond = do
|
|
attempt <- httpRequesterRole (requestHeaders req)
|
|
case attempt of
|
|
MalformedAuth ->
|
|
respond $ responseLBS status400 [] "Malformed basic auth header"
|
|
LoginFailed ->
|
|
respond $ responseLBS status401 [] "Invalid username or password"
|
|
LoginSuccess role ->
|
|
bracket_ (setRole conn role) (resetRole conn) $ app conn req respond
|
|
NoCredentials ->
|
|
bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond
|
|
|
|
where
|
|
httpRequesterRole :: RequestHeaders -> IO LoginAttempt
|
|
httpRequesterRole hdrs = do
|
|
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
|
case BS.split ' ' (cs auth) of
|
|
("Basic" : b64 : _) ->
|
|
case BS.split ':' $ cs (decode $ cs b64) of
|
|
(u:p:_) -> signInRole u p conn
|
|
_ -> return MalformedAuth
|
|
_ -> return NoCredentials
|
|
|
|
instance ToJSON SqlError where
|
|
toJSON t = object [
|
|
"error" .= object [
|
|
"code" .= seNativeError t
|
|
, "message" .= seErrorMsg t
|
|
, "state" .= seState t
|
|
]
|
|
]
|
|
|
|
clientErrors :: Application -> Application
|
|
clientErrors app req respond =
|
|
catchJust isPgException (app req respond) (
|
|
respond . responseLBS status400 [(hContentType, "application/json")]
|
|
. encode
|
|
)
|
|
|
|
where
|
|
isPgException :: SqlError -> Maybe SqlError
|
|
isPgException = Just
|
|
|
|
|
|
redirectInsecure :: Application -> Application
|
|
redirectInsecure app req respond = do
|
|
let hdrs = requestHeaders req
|
|
host = lookup "host" hdrs
|
|
uriM = parseURI . cs =<< mconcat [
|
|
Just "https://",
|
|
host,
|
|
Just $ rawPathInfo req,
|
|
Just $ rawQueryString req]
|
|
isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
|
|
|
|
if not (isSecure req || isHerokuSecure)
|
|
then case uriM of
|
|
Just uri ->
|
|
respond $ responseLBS status301 [
|
|
(hLocation, cs . show $ uri { uriScheme = "https:" })
|
|
] ""
|
|
Nothing ->
|
|
respond $ responseLBS status400 [] "SSL is required"
|
|
else app req respond
|