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
@@ -3,17 +3,16 @@ module Main where
 import Paths_dbapi (version)

 import App
-import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
-  redirectInsecure, withDBConnection, Environment(..))
+--import Auth
+import Middleware

 import Control.Monad (unless)
-import Control.Exception(bracket)
 import Data.String.Conversions (cs)
+import Network.Wai
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Static (staticPolicy, only)
-import Data.Pool(createPool, destroyAllResources)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
 import qualified Hasql as H
@@ -25,26 +24,34 @@ import Config (AppConfig(..), argParser, corsPolicy)
 main :: IO ()
 main = do
  conf <- execParser (info (helper <*> argParser) describe)
-  bracket
-    (createPool (connectPostgreSQL $ cs (configDbUri conf))
-      close 1 600 (configPool conf))
-    destroyAllResources
-    (\pool -> do
-      let port = configPort conf
+  let port = configPort conf

-      unless (configSecure conf) $
-        putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
+  unless (configSecure conf) $
+    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"

-      Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-      let settings = setPort port
-                   . setServerName (cs $ "dbapi/" <> prettyVersion)
-                   $ defaultSettings
-      runSettings settings $ (if configSecure conf then redirectInsecure else id)
+  Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
+
+
+  let pgSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres"
+
+  sessSettings <- maybe (fail "Improper session settings") return $
+                    H.sessionSettings 6 30
+
+  let settings = setPort port
+               . setServerName (cs $ "dbapi/" <> prettyVersion)
+               $ defaultSettings
+      middle =
+        (if configSecure conf then redirectInsecure else id)
        . gzip def . cors corsPolicy . clientErrors
-        . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-        . withDBConnection pool . inTransaction Production
-        . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app
-      )
+        . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in
+
+    runSettings settings $ middle (runApp pgSettings sessSettings)
+ --     . authenticated (cs $ configAnonRole conf) $ app
+
  where
    describe = progDesc "create a REST API to an existing Postgres database"
    prettyVersion = intercalate "." $ map show $ versionBranch version
+
+runApp :: H.Postgres -> H.SessionSettings -> Application
+runApp pg sess req respond =
+  respond =<< H.session pg sess (app req)
@@ -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)