Re-enable authentication

src/App.hs

@@ -96,7 +96,7 @@ app req =
         Nothing -> return $ responseLBS status400 [jsonH] $
           encode . object $ [("error", String "Failed to parse user.")]
         Just u -> do
-          _ <- liftIO $ addUser (cs $ userId u)
+          _ <- addUser (cs $ userId u)
             (cs $ userPass u) (cs $ userRole u)
           return $ responseLBS status201
             [ jsonH

src/Auth.hs

@@ -1,20 +1,23 @@
-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
 module Auth where
 
 import Data.Aeson
 import Control.Monad (mzero)
 import Control.Applicative ( (<*>), (<$>) )
+import Control.Monad.IO.Class (liftIO)
 import Crypto.BCrypt
 import Data.Text
+import Data.Monoid
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
 import Data.String.Conversions (cs)
+import PgQuery (pgFmtLit)
 
 data AuthUser = AuthUser {
     userId :: String
   , userPass :: String
   , userRole :: String
-  }
+  } deriving (Show)
 
 instance FromJSON AuthUser where
   parseJSON (Object v) = AuthUser <$>
@@ -42,17 +45,17 @@ checkPass :: Text -> Text -> Bool
 checkPass = (. cs) . validatePassword . cs
 
 setRole :: Text -> H.Tx H.Postgres s ()
-setRole role = H.unit $ [H.q| set role ?|] role
+setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True)
 
 resetRole :: H.Tx H.Postgres s ()
 resetRole = H.unit [H.q|reset role|]
 
-addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ())
+addUser :: Text -> Text -> Text -> H.Session H.Postgres IO ()
 addUser identity pass role = do
-  Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-  return $ H.unit $
+  Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
+  H.tx Nothing $ H.unit $
     [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
-      identity hashed role
+      identity (cs hashed :: Text) role
 
 signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt
 signInRole user pass = do

src/Main.hs

@@ -3,7 +3,6 @@ module Main where
 import Paths_dbapi (version)
 
 import App
---import Auth
 import Middleware
 
 import Control.Monad (unless)
@@ -50,7 +49,9 @@ main = do
   H.session pgSettings sessSettings $ do
     session' <- flip runReaderT <$> ask
     let runApp req respond =
-          respond =<< catchJust isSqlError (session' $ app req) sqlErrHandler
+          respond =<< catchJust isSqlError
+            (session' $ authenticated (cs $ configAnonRole conf) app req)
+            sqlErrHandler
 
     liftIO $ runSettings appSettings $ middle runApp
  --     . authenticated (cs $ configAnonRole conf) $ app

src/Middleware.hs

@@ -3,23 +3,25 @@
 module Middleware where
 
 --import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
--- import Data.Maybe (fromMaybe)
+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 qualified Data.ByteString.Char8 as BS
 import Control.Exception (catchJust)
 
-import Network.HTTP.Types.Header (hLocation, hContentType)
-import Network.HTTP.Types.Status (status400, status301)
+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)
+                   rawQueryString, isSecure, Request(..), Response)
 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
 
@@ -36,30 +38,35 @@ import Debug.Trace
 --     else Database.PostgreSQL.Simple.withSavepoint 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
+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 -> 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
+ 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 [

test/Feature/StructureSpec.hs

@@ -8,21 +8,17 @@ import Test.Hspec.Wai.JSON
 import SpecHelper
 
 import Network.HTTP.Types
-import Codec.Binary.Base64.String (encode)
-import Data.Monoid ((<>))
-import Data.String.Conversions (cs)
 
 spec :: Spec
 spec = around withApp $ do
-  let uName = "a user"
-      uPass = "nobody can ever know"
   describe "GET /" $
-    it "lists views in schema" $
-      request methodGet "/"
-        [("Authorization", "Basic "<>(uName<>":"<>uPass))] ""
+    it "lists views in schema" $ do
+      _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |]
+      let auth = authHeader "jdoe" "1234"
+
+      request methodGet "/" [auth] ""
         `shouldRespondWith` [json| [
-        {"schema":"1","name":"authors_only","insertable":true}
-        , {"schema":"1","name":"auto_incrementing_pk","insertable":true}
+          {"schema":"1","name":"auto_incrementing_pk","insertable":true}
         , {"schema":"1","name":"compound_pk","insertable":true}
         , {"schema":"1","name":"has_fk","insertable":true}
         , {"schema":"1","name":"items","insertable":true}
@@ -136,8 +132,7 @@ spec = around withApp $ do
       |]
 
     it "includes foreign key data" $
-      request methodOptions "/has_fk"
-        [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] ""
+      request methodOptions "/has_fk" [] ""
         `shouldRespondWith` [json|
       {
         "pkey": ["id"],

test/SpecHelper.hs

@@ -27,15 +27,16 @@ import Network.Wai.Middleware.Cors (cors)
 import System.Process (readProcess)
 
 import App (app, sqlErrHandler, isSqlError)
-import Config (corsPolicy)
+import Config (AppConfig(..), corsPolicy)
+import Middleware
 -- import Auth (addUser)
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
 isLeft _ = False
 
--- cfg :: AppConfig
--- cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
+cfg :: AppConfig
+cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
 
 testSettings :: SessionSettings
 testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
@@ -48,8 +49,9 @@ withApp perform =
   perform $ middle $ \req resp ->
     H.session pgSettings testSettings $ do
       session' <- flip runReaderT <$> ask
-      liftIO $ resp =<< catchJust isSqlError (session' $ app req)
-        sqlErrHandler
+      liftIO $ resp =<< catchJust isSqlError
+          (session' $ authenticated (cs $ configAnonRole cfg) app req)
+          sqlErrHandler
 
   where middle = cors corsPolicy