auth works now
This commit is contained in:
parent
818ee7421c
commit
48aba74b6d
6 changed files with 77 additions and 35 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue