{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Model.Auth where import Servant import Control.Arrow 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 Control.Lens import Crypto.Error import Crypto.JWT import qualified Data.Aeson as A import Data.ByteString as B (ByteString, fromStrict) 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 import qualified Data.Set as S import Data.Time.Clock import Opaleye hiding (null) -- internal imports import Types.Auth import Types.Reader import Classes import Util.Crypto initToken :: PGS.Query initToken = mconcat [ "CREATE TABLE IF NOT EXISTS \"token\" (" , "token_id SERIAL PRIMARY KEY," , "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL," , "token_expiry TIMESTAMPTZ NOT NULL," , "token_method INT NOT NULL" , ")" ] tokenTable :: Table ( Maybe (Field SqlInt4) , Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 ) ( Field SqlInt4 , Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 ) tokenTable = table "token" ( p4 ( tableField "token_id" , tableField "token_user" , tableField "token_expiry" , tableField "token_method" ) ) initAuthData :: PGS.Query initAuthData = mconcat [ "CREATE TABLE IF NOT EXISTS \"auth_data\" (" , "auth_data_id SERIAL PRIMARY KEY," , "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_salt BYTEA NOT NULL" , ")" ] authDataTable :: Table ( Maybe (Field SqlInt4) , Field SqlInt4 , Field SqlInt4 , Field SqlText , Field SqlBytea , Field SqlBytea ) ( Field SqlInt4 , Field SqlInt4 , Field SqlInt4 , Field SqlText , Field SqlBytea , Field SqlBytea ) authDataTable = table "auth_data" ( 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" ) ) delayTime :: Int delayTime = 1 * 10 ^ (6 :: Int) selectAuthOverviews :: Int -- ^ User ID -> PGS.Connection -- ^ Connection Handler -> MateHandler [AuthOverview] selectAuthOverviews uid conn = do liftIO $ map fromDatabase <$> runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, _, _) <- selectTable authDataTable -< () restrict -< aduid .== toFields uid returnA -< (adid, aduid, adcomment, admethod) ) selectAuthOverviewById :: Int -- ^ Auth Data ID -> PGS.Connection -- ^ Connection Handler -> MateHandler AuthOverview selectAuthOverviewById aid conn = do liftIO $ fromDatabase . head <$> runSelect conn (limit 1 $ proc () -> do (adid, aduid, admethod, adcomment, _, _) <- selectTable authDataTable -< () restrict -< adid .== toFields aid returnA -< (adid, aduid, adcomment, admethod) ) getUserAuthInfo :: Int -> AuthMethod -> PGS.Connection -> MateHandler AuthInfo getUserAuthInfo uid method conn = do authdata <- liftIO $ do void $ threadDelay delayTime map fromDatabase <$> runSelect conn (proc () -> do (aid, auid, amethod, acomment, apayload, asalt) <- selectTable authDataTable -< () restrict -< auid .== toFields uid .&& amethod .== toFields (fromEnum method) returnA -< (aid, auid, amethod, acomment, apayload, asalt) ) :: IO [AuthData] if null authdata then -- generate mock AuthInfo liftIO $ do rand1 <- decodeUtf8 <$> randomString rand2 <- case method of ChallengeResponse -> Just . decodeUtf8 <$> randomString _ -> return Nothing return $ AuthInfo rand2 (AuthTicket rand1) else uncurry AuthInfo <$> newTicket uid method putUserAuthInfo :: Int -> AuthMethod -> T.Text -> B.ByteString -> B.ByteString -> PGS.Connection -> MateHandler Int putUserAuthInfo uid method comment salt payload conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = authDataTable , iRows = [ ( toFields (Nothing :: Maybe Int) , toFields uid , toFields (fromEnum method) , toFields comment , toFields payload , toFields salt ) ] , iReturning = rReturning (\(adid, _, _, _, _, _) -> adid) , iOnConflict = Nothing } deleteAuthDataById :: Int -> PGS.Connection -> MateHandler Int64 deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete { dTable = authDataTable , dWhere = \(aid, _, _, _, _, _) -> aid .== toFields adid , dReturning = rCount } validateToken :: ByteString -> JWK -> PGS.Connection -> Handler (Maybe (Int, AuthMethod)) validateToken authHeader key conn = do token <- either (error . show) id <$> liftIO (runJOSE $ do jwt <- (decodeCompact (fromStrict authHeader) :: JOSE JWTError IO SignedJWT) liftIO $ print jwt let chk = defaultJWTValidationSettings (const True) verifyJWT chk key jwt :: JOSE JWTError IO AuthResult ) tokens <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< () restrict -< toFields (authUser token) .== tUser .&& toFields (fromEnum $ authMethod token) .== tMethod returnA -< stuff ) case tokens of [Token tid uid stamp method] -> do now_ <- liftIO getCurrentTime if diffUTCTime stamp now_ > 0 then return $ Just (uid, method) else do void $ deleteToken tid conn liftIO $ threadDelay delayTime throwError $ err401 { errBody = "Your token expired!" } _ -> do liftIO $ threadDelay delayTime throwError $ err401 { errBody = "No valid token found!" } generateToken :: Int -> AuthMethod -> AuthResponse -> PGS.Connection -> MateHandler SignedJWT generateToken tuid method (AuthResponse response) conn = do authData <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do 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 authData SecondaryPass -> validatePass response authData ChallengeResponse -> validateChallengeResponse response userPayloads -- liftIO $ print (response : userPayloads) if authResult then do key <- asks rsJWTSecret issuedAt <- liftIO getCurrentTime let preToken = ( tuid , (addUTCTime (23*60) issuedAt) , method ) liftIO $ print $ A.encode key void $ insertToken preToken conn let result = AuthResult issuedAt tuid method -- (AuthToken $ tokenString token) signedJWT <- liftIO $ runJOSE (do algo <- (bestJWSAlg key :: JOSE JWTError IO Alg) signJWT key (newJWSHeader ((), algo)) result) return $ either (error "Signing JWT failed") id signedJWT else throwError err401 where 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 _ _ = throwError err501 { errBody = "Validation of challenge response authentication not yet implemented" } -- signJWT :: JWK -> AuthResult -> MateHandler (Either JWTError SignedJWT) -- signJWT key result = liftIO $ runExceptT $ do -- algo <- bestJWSAlg key -- signJWS (A.encode result) (Identity (newJWSHeader ((), algo), key)) insertToken :: (Int, UTCTime, AuthMethod) -> PGS.Connection -> MateHandler Int insertToken (tUser, tExpiry, tMethod) conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = tokenTable , iRows = [ ( toFields (Nothing :: Maybe Int) , toFields tUser , toFields tExpiry , toFields (fromEnum tMethod) ) ] , iReturning = rReturning (\(tid, _, _, _) -> tid) , iOnConflict = Nothing } deleteToken :: Int -> PGS.Connection -> Handler Int64 deleteToken dtid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(tid, _, _, _) -> tid .== toFields dtid , dReturning = rCount } deleteTokenByUserId :: Int -> PGS.Connection -> MateHandler Int64 deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(_, rid, _, _) -> rid .== toFields uid , dReturning = rCount } deleteOldTokens :: UTCTime -> PGS.Connection -> IO Int64 deleteOldTokens now_ conn = runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(_, _, expiry, _) -> expiry .< toFields now_ , dReturning = rCount } newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket ident method = do store <- asks rsTicketStore rand1 <- liftIO (decodeUtf8 <$> randomString) rand2 <- liftIO $ case method of ChallengeResponse -> Just . decodeUtf8 <$> randomString _ -> return Nothing later <- liftIO (addUTCTime 23 <$> getCurrentTime) let ticket = Ticket { ticketId = AuthTicket rand1 , ticketUser = ident , ticketExpiry = later , ticketMethod = (method, rand2) } liftIO $ atomically $ modifyTVar store (S.insert ticket) return (rand2, AuthTicket rand1) processAuthRequest :: AuthRequest -> PGS.Connection -> MateHandler SignedJWT processAuthRequest (AuthRequest user method pass) conn = do -- liftIO $ putStrLn "there is a ticket..." now_ <- liftIO getCurrentTime liftIO $ threadDelay delayTime -- liftIO $ putStrLn "...and it is valid" generateToken user method pass conn processLogout :: Int -> PGS.Connection -> MateHandler () processLogout uid conn = void $ deleteTokenByUserId uid conn