nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

auth works now

Browse source
This commit is contained in:
nek0 2022-04-17 16:38:48 +02:00
parent 818ee7421c
commit 48aba74b6d
6 changed files with 77 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Control/Auth.hs
View file

@ -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)

20
src/Control/User.hs
View file

@ -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

66
src/Model/Auth.hs
View file

@ -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
PrimaryPass -> validatePass response userPayloads
SecondaryPass -> validatePass response userPayloads
authResult <- case method of
PrimaryPass -> validatePass response authData
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 =
elem
validatePass resp =
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

9
src/Types/Auth.hs
View file

@ -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) =
AuthData id_ usr (toEnum method) comm (decodeUtf8 payload)
fromDatabase (id_, usr, method, comm, payload, salt) =
AuthData id_ usr (toEnum method) comm (decodeUtf8 payload) (decodeUtf8 salt)
data AuthOverview = AuthOverview

4
src/Types/User.hs
View file

@ -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)

5
src/Util/Crypto.hs
View file

@ -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