diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 6c15b4c..d8aa1dc 100644 --- a/src/Control/Auth.hs +++ b/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) diff --git a/src/Control/User.hs b/src/Control/User.hs index 6727244..292d9f9 100644 --- a/src/Control/User.hs +++ b/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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 38b80bd..a5a9b98 100644 --- a/src/Model/Auth.hs +++ b/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,17 +249,17 @@ 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 - ChallengeResponse -> validateChallengeResponse response userPayloads + authResult <- case method of + PrimaryPass -> validatePass response authData + SecondaryPass -> validatePass response authData + ChallengeResponse -> validateChallengeResponse response userPayloads -- liftIO $ print (response : userPayloads) if authResult then do @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 5dbd760..5b946ce 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -102,8 +102,8 @@ instance FromJSON AuthResponse data AuthRequest = AuthRequest - { authRequestTicket :: AuthTicket - , authRequestHash :: AuthResponse + { authRequestTicket :: AuthTicket + , 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 diff --git a/src/Types/User.hs b/src/Types/User.hs index 2d5d64b..2f4ead7 100644 --- a/src/Types/User.hs +++ b/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) diff --git a/src/Util/Crypto.hs b/src/Util/Crypto.hs index 02627ff..5b0d607 100644 --- a/src/Util/Crypto.hs +++ b/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