auth works now

src/Control/Auth.hs

@@ -72,11 +72,11 @@ authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload)
   if method == PrimaryPass
   then do
     salt <- liftIO randomString
-    let mhashstring = decodeUtf8 <$> hash defaultOptions (encodeUtf8 aspayload) salt 64
+    let mhashstring = hash defaultOptions (encodeUtf8 aspayload) salt 64
     case mhashstring of
       CryptoPassed hashstring -> do
         conn <- asks rsConnection
-        putUserAuthInfo uid asmethod ascomment hashstring conn
+        putUserAuthInfo uid asmethod ascomment salt hashstring conn
       CryptoFailed err -> do
         throwError $ err500
           { errBody = "Crypto Error: " <> fromString (show err)

src/Control/User.hs

@@ -9,6 +9,12 @@ import Control.Monad.Reader (asks)
 
 import Control.Monad.IO.Class (liftIO)
 
+import Crypto.Error
+
+import Data.String (fromString)
+
+import Data.Text.Encoding
+
 import Data.Time (getCurrentTime, utctDay)
 
 import Data.Maybe (fromMaybe)
@@ -22,15 +28,25 @@ import Text.Printf (printf)
 import Types
 import Model
 import Util
+import Util.Crypto
 
 userNew
   :: UserSubmit
   -> MateHandler Int
-userNew (UserSubmit ident email passhash) = do
+userNew (UserSubmit ident email pass) = do
   now <- liftIO getCurrentTime
   conn <- asks rsConnection
   uid <- insertUser ident email (utctDay now) conn
-  void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
+  salt <- liftIO randomString
+  let mpasshash = argon2 salt (encodeUtf8 pass)
+  case mpasshash of
+    CryptoPassed passhash -> do
+      liftIO $ print passhash
+      void $ putUserAuthInfo uid PrimaryPass "Initial password" salt passhash conn
+    CryptoFailed err ->
+      throwError $ err500
+        { errBody = "Crypto error: " <> fromString (show err)
+        }
   baseRoleId <- queryRoleIdByCapabilities
     (False, False, False, False, False, False, False, False, False, False)
     conn

src/Model/Auth.hs

@@ -2,25 +2,31 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Model.Auth where
 
 import Servant
 
 import Control.Arrow
 
-import Control.Monad (void)
+import Control.Monad (void, foldM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Reader (asks)
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM
 
-import Data.Profunctor.Product (p4, p5)
+import Crypto.Error
+
+import Data.Profunctor.Product (p4, p6)
 
 import qualified Database.PostgreSQL.Simple as PGS
 
 import Data.Int (Int64)
 
+import Data.String (fromString)
+
 import qualified Data.Text as T
 import Data.Text.Encoding
 
@@ -29,6 +35,7 @@ import qualified Data.Set as S
 import Data.Time.Clock
 
 import Data.ByteString as B (ByteString)
+import Data.ByteString.Base64 (encode)
 
 import Opaleye hiding (null)
 
@@ -77,7 +84,8 @@ initAuthData = mconcat
   , "auth_data_user    INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
   , "auth_data_method  INTEGER NOT NULL,"
   , "auth_data_comment TEXT    NOT NULL,"
-  , "auth_data_payload BYTEA   NOT NULL"
+  , "auth_data_payload BYTEA   NOT NULL,"
+  , "auth_data_salt    BYTEA   NOT NULL"
   , ")"
   ]
 
@@ -87,20 +95,23 @@ authDataTable :: Table
   , Field SqlInt4
   , Field SqlText
   , Field SqlBytea
+  , Field SqlBytea
   )
   ( Field SqlInt4
   , Field SqlInt4
   , Field SqlInt4
   , Field SqlText
   , Field SqlBytea
+  , Field SqlBytea
   )
 authDataTable = table "auth_data" (
-  p5
+  p6
     ( tableField "auth_data_id"
     , tableField "auth_data_user"
     , tableField "auth_data_method"
     , tableField "auth_data_comment"
     , tableField "auth_data_payload"
+    , tableField "auth_data_salt"
     )
   )
 
@@ -115,7 +126,7 @@ selectAuthOverviews
   -> MateHandler [AuthOverview]
 selectAuthOverviews uid conn = do
   liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
-    (adid, aduid, admethod, adcomment, _) <-
+    (adid, aduid, admethod, adcomment, _, _) <-
       selectTable authDataTable -< ()
     restrict -< aduid .== toFields uid
     returnA -< (adid, aduid, adcomment, admethod)
@@ -128,7 +139,7 @@ selectAuthOverviewById
   -> MateHandler AuthOverview
 selectAuthOverviewById aid conn = do
   liftIO $ fromDatabase . head <$> runSelect conn (limit 1 $ proc () -> do
-    (adid, aduid, admethod, adcomment, _) <-
+    (adid, aduid, admethod, adcomment, _, _) <-
       selectTable authDataTable -< ()
     restrict -< adid .== toFields aid
     returnA -< (adid, aduid, adcomment, admethod)
@@ -145,11 +156,11 @@ getUserAuthInfo uid method conn = do
     liftIO $ do
       void $ threadDelay delayTime
       map fromDatabase <$> runSelect conn (proc () -> do
-        (aid, auid, amethod, acomment, apayload) <-
+        (aid, auid, amethod, acomment, apayload, asalt) <-
           selectTable authDataTable -< ()
         restrict -<
           auid .== toFields uid .&& amethod .== toFields (fromEnum method)
-        returnA -< (aid, auid, amethod, acomment, apayload)
+        returnA -< (aid, auid, amethod, acomment, apayload, asalt)
         ) :: IO [AuthData]
   if null authdata
   then
@@ -168,10 +179,11 @@ putUserAuthInfo
   :: Int
   -> AuthMethod
   -> T.Text
-  -> T.Text
+  -> B.ByteString 
+  -> B.ByteString 
   -> PGS.Connection
   -> MateHandler Int
-putUserAuthInfo uid method comment payload conn =
+putUserAuthInfo uid method comment salt payload conn =
   fmap head $ liftIO $ runInsert_ conn $ Insert
     { iTable = authDataTable
     , iRows =
@@ -180,10 +192,11 @@ putUserAuthInfo uid method comment payload conn =
       , toFields uid
       , toFields (fromEnum method)
       , toFields comment
-      , toFields (encodeUtf8 payload)
+      , toFields payload
+      , toFields salt
       )
       ]
-    , iReturning = rReturning (\(adid, _, _, _, _) -> adid)
+    , iReturning = rReturning (\(adid, _, _, _, _, _) -> adid)
     , iOnConflict = Nothing
     }
 
@@ -194,7 +207,7 @@ deleteAuthDataById
   -> MateHandler Int64
 deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
   { dTable     = authDataTable
-  , dWhere     = \(aid, _, _, _, _) -> aid .== toFields adid
+  , dWhere     = \(aid, _, _, _, _, _) -> aid .== toFields adid
   , dReturning = rCount
   }
 
@@ -236,16 +249,16 @@ generateToken
 generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   authData <- liftIO $ map fromDatabase <$> runSelect conn (
     proc () -> do
-      stuff@(_, auid, amethod, _, _) <- selectTable authDataTable -< ()
+      stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
       restrict -< (auid .== toFields tuid .&& amethod .== toFields (fromEnum method))
       returnA -< stuff
     ) :: MateHandler [AuthData]
   let userPayloads = map
         authDataPayload
         authData
-      authResult = case method of
+  authResult <- case method of
-        PrimaryPass       -> validatePass response userPayloads
+    PrimaryPass       -> validatePass response authData
-        SecondaryPass     -> validatePass response userPayloads
+    SecondaryPass     -> validatePass response authData
     ChallengeResponse -> validateChallengeResponse response userPayloads
   -- liftIO $ print (response : userPayloads)
   if authResult
@@ -260,8 +273,19 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   else
     return Denied
   where
-    validatePass =
+    validatePass resp =
-      elem
+      foldM
+        (\acc AuthData{..} ->
+          let mresponseHash = argon2 (encodeUtf8 authDataSalt) (encodeUtf8 resp)
+          in  case mresponseHash of
+            CryptoPassed responseHash ->
+              return $ acc || responseHash == encodeUtf8 authDataPayload
+            CryptoFailed err ->
+              throwError $ err500
+                { errBody = "Crypto error: " <> fromString (show err)
+                }
+          )
+        False
     validateChallengeResponse _ _ =
       error "Validation of challenge response authentication not yet implemented"
 
@@ -343,7 +367,7 @@ processAuthRequest
   -> S.Set Ticket
   -> PGS.Connection
   -> MateHandler AuthResult
-processAuthRequest (AuthRequest aticket hash) store conn = do
+processAuthRequest (AuthRequest aticket pass) store conn = do
   let mticket = S.filter (\st -> ticketId st == aticket) store
   case S.toList mticket of
     [ticket] -> do
@@ -355,7 +379,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
         return Denied
       else
         -- liftIO $ putStrLn "...and it is valid"
-        generateToken ticket hash conn
+        generateToken ticket pass conn
     _        -> do
       liftIO $ threadDelay delayTime
       return Denied

src/Types/Auth.hs

@@ -103,7 +103,7 @@ instance FromJSON AuthResponse
 
 data AuthRequest = AuthRequest
   { authRequestTicket   :: AuthTicket
-  , authRequestHash   :: AuthResponse
+  , authRequestPassword :: AuthResponse
   }
   deriving (Show, Generic)
 
@@ -178,6 +178,7 @@ data AuthData = AuthData
   , authDataMethod  :: AuthMethod
   , authDataComment :: T.Text
   , authDataPayload :: T.Text
+  , authDataSalt    :: T.Text
   }
   deriving (Show)
 
@@ -190,10 +191,10 @@ data AuthData = AuthData
 
 instance FromDatabase AuthData where
 
-  type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString)
+  type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString, ByteString)
 
-  fromDatabase (id_, usr, method, comm, payload) =
+  fromDatabase (id_, usr, method, comm, payload, salt) =
-    AuthData id_ usr (toEnum method) comm (decodeUtf8 payload)
+    AuthData id_ usr (toEnum method) comm (decodeUtf8 payload) (decodeUtf8 salt)
 
 
 data AuthOverview = AuthOverview

src/Types/User.hs

@@ -40,7 +40,7 @@ instance FromDatabase User where
   type OutTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int)
 
   fromDatabase  (id_, ident, bal, ts, email, ava) =
-    (User id_ ident bal ts email ava)
+    User id_ ident bal ts email ava
 
 
 data UserSummary = UserSummary
@@ -59,7 +59,7 @@ instance FromJSON UserSummary
 data UserSubmit = UserSubmit
   { userSubmitIdent    :: T.Text
   , userSubmitEmail    :: Maybe T.Text
-  , userSubmitPassHash :: T.Text
+  , userSubmitPassword :: T.Text
   }
   deriving (Generic, Show)
 

src/Util/Crypto.hs

@@ -4,11 +4,12 @@ import Crypto.KDF.Argon2
 import Crypto.Error (CryptoFailable)
 
 import qualified Data.ByteString as BS
+import Data.ByteString.Base64
 
 import System.Random.Stateful (uniformByteStringM, newIOGenM, mkStdGen)
 
 randomString :: IO BS.ByteString
-randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)
+randomString = encode <$> (uniformByteStringM 32 =<< newIOGenM (mkStdGen 23))
 
 argon2 :: BS.ByteString -> BS.ByteString -> CryptoFailable BS.ByteString
-argon2 salt payload = hash defaultOptions payload salt 64
+argon2 salt payload = encode <$> hash defaultOptions payload (decodeLenient salt) 64