115 lines
3.9 KiB
Haskell
115 lines
3.9 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Middleware where
|
|
|
|
--import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Monoid (mconcat)
|
|
import Data.Text
|
|
-- import Data.Pool(withResource, Pool)
|
|
|
|
import qualified Hasql as H
|
|
import qualified Hasql.Postgres as H
|
|
import Data.String.Conversions(cs)
|
|
import Control.Exception (catchJust)
|
|
|
|
import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization)
|
|
import Network.HTTP.Types (RequestHeaders)
|
|
import Network.HTTP.Types.Status (status400, status401, status301)
|
|
import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
|
|
rawQueryString, isSecure, Request(..), Response)
|
|
import Network.URI (URI(..), parseURI)
|
|
|
|
import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
|
|
import Codec.Binary.Base64.String (decode)
|
|
|
|
import Debug.Trace
|
|
|
|
-- data Environment = Test | Production deriving (Eq)
|
|
|
|
-- safeAction :: Request -> Bool
|
|
-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
|
|
|
|
-- withSavepoint :: Environment -> (Connection -> Application) ->
|
|
-- Connection -> Application
|
|
-- withSavepoint env app conn req respond =
|
|
-- if env == Production && safeAction req
|
|
-- then go
|
|
-- else Database.PostgreSQL.Simple.withSavepoint conn go
|
|
-- where go = app conn req respond
|
|
|
|
authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) ->
|
|
Request -> H.Session H.Postgres IO Response
|
|
authenticated anon app req = do
|
|
attempt <- httpRequesterRole (requestHeaders req)
|
|
case attempt of
|
|
MalformedAuth ->
|
|
return $ responseLBS status400 [] "Malformed basic auth header"
|
|
LoginFailed ->
|
|
return $ responseLBS status401 [] "Invalid username or password"
|
|
LoginSuccess role -> runInRole role
|
|
NoCredentials -> runInRole anon
|
|
|
|
where
|
|
httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt
|
|
httpRequesterRole hdrs = do
|
|
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
|
case split (==' ') (cs auth) of
|
|
("Basic" : b64 : _) ->
|
|
case split (==':') (cs . decode . cs $ b64) of
|
|
(u:p:_) -> H.tx Nothing $ signInRole u p
|
|
_ -> return MalformedAuth
|
|
_ -> return NoCredentials
|
|
|
|
runInRole :: Text -> H.Session H.Postgres IO Response
|
|
runInRole r = do
|
|
H.tx Nothing $ setRole r
|
|
resp <- app req
|
|
H.tx Nothing resetRole
|
|
return resp
|
|
|
|
-- instance ToJSON SqlError where
|
|
-- toJSON t = object [
|
|
-- "error" .= object [
|
|
-- "message" .= (cs $ sqlErrorMsg t :: String)
|
|
-- , "detail" .= (cs $ sqlErrorDetail t :: String)
|
|
-- , "state" .= (cs $ sqlState t :: String)
|
|
-- , "hint" .= (cs $ sqlErrorHint t :: String)
|
|
-- ]
|
|
-- ]
|
|
|
|
clientErrors :: Application -> Application
|
|
clientErrors app req respond =
|
|
catchJust isPgException (app req respond) $ \err ->
|
|
respond $
|
|
responseLBS status400 [(hContentType, "application/json")] (cs $ show err)
|
|
-- if sqlState err == "42P01"
|
|
-- then responseLBS status404 [] ""
|
|
-- else responseLBS status400 [(hContentType, "application/json")] (encode err)
|
|
|
|
where
|
|
isPgException :: H.Error -> Maybe H.Error
|
|
isPgException x = Just (traceShow x x)
|
|
|
|
|
|
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
|