{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} 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 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 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) -- 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_string BYTEA NOT NULL PRIMARY KEY," , "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL," , "token_expiry TIMESTAMPTZ NOT NULL," , "token_method INT NOT NULL" , ")" ] tokenTable :: Table ( Field SqlBytea , Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 ) ( Field SqlBytea , Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 ) tokenTable = table "token" ( p4 ( tableField "token_string" , 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 -> PGS.Connection -> Handler (Maybe (Int, AuthMethod)) validateToken header conn = do tokens <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< () restrict -< toFields header .== tstr returnA -< stuff ) case tokens of [Token _ uid stamp method] -> do now_ <- liftIO getCurrentTime if diffUTCTime stamp now_ > 0 then return $ Just (uid, method) else do void $ deleteToken header conn liftIO $ threadDelay delayTime throwError $ err401 { errBody = "Your token expired!" } _ -> do liftIO $ threadDelay delayTime throwError $ err401 { errBody = "No valid token found!" } generateToken :: Ticket -> AuthResponse -> PGS.Connection -> MateHandler AuthResult generateToken (Ticket _ 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 token <- liftIO $ Token <$> (decodeUtf8 <$> randomString) <*> pure tuid <*> (addUTCTime (23*60) <$> getCurrentTime) <*> pure method void $ insertToken token conn return $ Granted (AuthToken $ tokenString token) else return Denied 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 _ _ = error "Validation of challenge response authentication not yet implemented" insertToken :: Token -> PGS.Connection -> MateHandler ByteString insertToken (Token tString tUser tExpiry tMethod) conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = tokenTable , iRows = [ ( toFields (encodeUtf8 tString) , toFields tUser , toFields tExpiry , toFields (fromEnum tMethod) ) ] , iReturning = rReturning (\(ident, _, _, _) -> ident) , iOnConflict = Nothing } deleteToken :: ByteString -> PGS.Connection -> Handler Int64 deleteToken tstr conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr , 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 -> S.Set Ticket -> PGS.Connection -> MateHandler AuthResult processAuthRequest (AuthRequest aticket pass) store conn = do let mticket = S.filter (\st -> ticketId st == aticket) store case S.toList mticket of [ticket] -> do -- liftIO $ putStrLn "there is a ticket..." now_ <- liftIO getCurrentTime liftIO $ threadDelay delayTime if now_ > ticketExpiry ticket then return Denied else -- liftIO $ putStrLn "...and it is valid" generateToken ticket pass conn _ -> do liftIO $ threadDelay delayTime return Denied processLogout :: Int -> PGS.Connection -> MateHandler () processLogout uid conn = void $ deleteTokenByUserId uid conn