Program compiles but without auth, uri parsing, or json error reporting

2014-12-06 17:42:19 -08:00
parent ae9fe506be
commit dcbecf085f
2 changed files with 87 additions and 91 deletions
@@ -2,97 +2,86 @@

 module Middleware where

-import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
-import Data.Maybe (fromMaybe)
+--import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
+-- import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
-import Data.Pool(withResource, Pool)
+-- import Data.Pool(withResource, Pool)

-import Database.PostgreSQL.Simple
+import qualified Hasql as H
 import Data.String.Conversions(cs)
-import qualified Data.ByteString.Char8 as BS
-import Control.Exception (catchJust, bracket_)
+--import qualified Data.ByteString.Char8 as BS
+import Control.Exception (catchJust)

-import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
-  hLocation)
-import Network.HTTP.Types.Status (status400, status401, status404, status301)
+import Network.HTTP.Types.Header (hLocation, hContentType)
+import Network.HTTP.Types.Status (status400, status301)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
-                   rawQueryString, isSecure, requestMethod, Request)
+                   rawQueryString, isSecure)
 import Network.URI (URI(..), parseURI)

-import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
-import Codec.Binary.Base64.String (decode)
+-- import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
+-- import Codec.Binary.Base64.String (decode)

 import Debug.Trace

-data Environment = Test | Production deriving (Eq)
+-- data Environment = Test | Production deriving (Eq)

-withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
-withDBConnection pool app req respond =
-  withResource pool (\c -> app c req respond)
+-- safeAction :: Request -> Bool
+-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod

-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

-inTransaction :: Environment -> (Connection -> Application) ->
-                 Connection -> Application
-inTransaction env app conn req respond =
-  if env == Production && safeAction req
-    then go
-    else withTransaction conn go
-  where go = app conn req respond
+-- 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

-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
+--  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 conn u p
+--           _ -> return MalformedAuth
+--       _ -> return NoCredentials

-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 conn u p
-          _ -> return MalformedAuth
-      _ -> return NoCredentials
-
-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)
-      ]
-    ]
+-- 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 $ if sqlState err == "42P01"
-       then responseLBS status404 [] ""
-       else responseLBS status400 [(hContentType, "application/json")] (encode 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 :: SqlError -> Maybe SqlError
+    isPgException :: H.Error -> Maybe H.Error
    isPgException x = Just (traceShow x x)