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

src/Main.hs

@@ -3,17 +3,16 @@ module Main where
 import Paths_dbapi (version)
 
 import App
-import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
+--import Auth
-  redirectInsecure, withDBConnection, Environment(..))
+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
+  let port = configPort conf
-    (createPool (connectPostgreSQL $ cs (configDbUri conf))
-      close 1 600 (configPool conf))
-    destroyAllResources
-    (\pool -> do
-      let port = configPort conf
 
-      unless (configSecure conf) $
+  unless (configSecure conf) $
-        putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
+    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
 
-      Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
+  Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-      let settings = setPort port
+
-                   . setServerName (cs $ "dbapi/" <> prettyVersion)
+
-                   $ defaultSettings
+  let pgSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres"
-      runSettings settings $ (if configSecure conf then redirectInsecure else id)
+
+  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")])
+        . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in
-        . withDBConnection pool . inTransaction Production
+
-        . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app
+    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)

src/Middleware.hs

@@ -2,97 +2,86 @@
 
 module Middleware where
 
-import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
+--import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
-import Data.Maybe (fromMaybe)
+-- 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 qualified Data.ByteString.Char8 as BS
-import Control.Exception (catchJust, bracket_)
+import Control.Exception (catchJust)
 
-import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
+import Network.HTTP.Types.Header (hLocation, hContentType)
-  hLocation)
+import Network.HTTP.Types.Status (status400, status301)
-import Network.HTTP.Types.Status (status400, status401, status404, 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 Auth (LoginAttempt(..), signInRole, setRole, resetRole)
-import Codec.Binary.Base64.String (decode)
+-- 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
+-- safeAction :: Request -> Bool
-withDBConnection pool app req respond =
+-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
-  withResource pool (\c -> app c req respond)
 
-safeAction :: Request -> Bool
+-- withSavepoint :: Environment -> (Connection -> Application) ->
-safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
+--                  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) ->
+-- authenticated :: BS.ByteString -> (Connection -> Application) ->
-                 Connection -> Application
+--                  Connection -> Application
-inTransaction env app conn req respond =
+-- authenticated anon app conn req respond = do
-  if env == Production && safeAction req
+--   attempt <- httpRequesterRole (requestHeaders req)
-    then go
+--   case attempt of
-    else withTransaction conn go
+--     MalformedAuth ->
-  where go = app conn req respond
+--       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) ->
+--  where
-                 Connection -> Application
+--    httpRequesterRole :: RequestHeaders -> IO LoginAttempt
-withSavepoint env app conn req respond =
+--    httpRequesterRole hdrs = do
-  if env == Production && safeAction req
+--     let auth = fromMaybe "" $ lookup hAuthorization hdrs
-    then go
+--     case BS.split ' ' (cs auth) of
-    else Database.PostgreSQL.Simple.withSavepoint conn go
+--       ("Basic" : b64 : _) ->
-  where go = app conn req respond
+--         case BS.split ':' $ cs (decode $ cs b64) of
+--           (u:p:_) -> signInRole conn u p
+--           _ -> return MalformedAuth
+--       _ -> return NoCredentials
 
-authenticated :: BS.ByteString -> (Connection -> Application) ->
+-- instance ToJSON SqlError where
-                 Connection -> Application
+--   toJSON t = object [
-authenticated anon app conn req respond = do
+--       "error" .= object [
-  attempt <- httpRequesterRole (requestHeaders req)
+--           "message" .= (cs $ sqlErrorMsg t :: String)
-  case attempt of
+--         , "detail"  .= (cs $ sqlErrorDetail t :: String)
-    MalformedAuth ->
+--         , "state"   .= (cs $ sqlState t :: String)
-      respond $ responseLBS status400 [] "Malformed basic auth header"
+--         , "hint"    .= (cs $ sqlErrorHint t :: String)
-    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)
-      ]
-    ]
 
 clientErrors :: Application -> Application
 clientErrors app req respond =
   catchJust isPgException (app req respond) $ \err ->
-    respond $ if sqlState err == "42P01"
+    respond $
-       then responseLBS status404 [] ""
+      responseLBS status400 [(hContentType, "application/json")] (cs $ show err)
-       else responseLBS status400 [(hContentType, "application/json")] (encode 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)