{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-} module Model.Auth where import Servant import Control.Arrow import Control.Monad (void) 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 qualified Database.PostgreSQL.Simple as PGS import Data.Int (Int64) 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.Random import qualified Data.ByteString.Base64 as B64 import Opaleye hiding (null) import qualified Opaleye.Constant as C -- internal imports import Types.Auth import Types.Reader import Classes initToken :: PGS.Query initToken = mconcat [ "CREATE TABLE IF NOT EXISTS \"token\" (" , "token_string TEXT 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 SqlText , Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 ) ( Field SqlText , 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" , ")" ] authDataTable :: Table ( Maybe (Field SqlInt4) , Field SqlInt4 , Field SqlInt4 , Field SqlText , Field SqlBytea ) ( Field SqlInt4 , Field SqlInt4 , Field SqlInt4 , Field SqlText , Field SqlBytea ) authDataTable = table "auth_data" ( p5 ( tableField "auth_data_id" , tableField "auth_data_user" , tableField "auth_data_method" , tableField "auth_data_comment" , tableField "auth_data_payload" ) ) delayTime :: Int delayTime = 1 * 10 ^ (6 :: Int) generateRandomText :: IO T.Text generateRandomText = decodeUtf8 . B64.encode <$> random 23 selectAuthOverviews :: Int -- ^ User ID -> PGS.Connection -- ^ Connection Handler -> MateHandler [AuthOverview] selectAuthOverviews uid conn = do liftIO $ map fromDatabase <$> head <$> runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, _) <- queryTable authDataTable -< () restrict -< aduid .== C.constant uid returnA -< (adid, adcomment, admethod) ) selectAuthOverviewById :: Int -- ^ Auth Data ID -> PGS.Connection -- ^ Connection Handler -> MateHandler AuthOverview selectAuthOverviews aid conn = do liftIO $ map fromDatabase <$> runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, _) <- queryTable authDataTable -< () restrict -< adid .== C.constant aid limit 1 returnA -< (adid, 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) <- queryTable authDataTable -< () restrict -< auid .== C.constant uid .&& amethod .== C.constant (fromEnum method) returnA -< (aid, auid, amethod, acomment, apayload) ) :: IO [AuthData] if null authdata then -- generate mock AuthInfo liftIO $ do rand1 <- generateRandomText rand2 <- case method of ChallengeResponse -> Just <$> generateRandomText _ -> return Nothing return $ AuthInfo rand2 (AuthTicket rand1) else uncurry AuthInfo <$> newTicket uid method putUserAuthInfo :: Int -> AuthMethod -> T.Text -> T.Text -> PGS.Connection -> MateHandler Int putUserAuthInfo uid method comment payload conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = authDataTable , iRows = [ ( C.constant (Nothing :: Maybe Int) , C.constant uid , C.constant (fromEnum method) , C.constant comment , C.constant (either error id $ B64.decode $ encodeUtf8 payload) ) ] , iReturning = rReturning (\(adid, _, _, _, _) -> adid) , iOnConflict = Nothing } deleteAuthDataById :: Int -> PGS.Connection -> MateHandler Int64 deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete { dTable = authDataTable , dWhere = \(aid, _, _, _, _) -> aid .== C.constant adid , dReturning = rCount } validateToken :: ByteString -> PGS.Connection -> Handler (Maybe (Int, AuthMethod)) validateToken header conn = do tokens <- liftIO $ map fromDatabase <$> runSelect conn ( keepWhen (\(tstr, _, _, _) -> tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable ) 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 (decodeUtf8 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 ( keepWhen (\(_, auid, amethod, _, _) -> auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) <<< queryTable authDataTable ) :: MateHandler [AuthData] let userPayloads = map authDataPayload authData authResult = case method of PrimaryPass -> validatePass response userPayloads SecondaryPass -> validatePass response userPayloads ChallengeResponse -> validateChallengeResponse response userPayloads -- liftIO $ print (response : userPayloads) if authResult then do token <- liftIO $ Token <$> generateRandomText <*> pure tuid <*> (addUTCTime (23*60) <$> getCurrentTime) <*> pure method void $ insertToken token conn return $ Granted (AuthToken $ tokenString token) else return Denied where validatePass = elem validateChallengeResponse _ _ = error "Validation of challenge response authentication not yet implemented" insertToken :: Token -> PGS.Connection -> MateHandler T.Text insertToken (Token tString tUser tExpiry tMethod) conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = tokenTable , iRows = [ ( C.constant tString , C.constant tUser , C.constant tExpiry , C.constant (fromEnum tMethod) ) ] , iReturning = rReturning (\(ident, _, _, _) -> ident) , iOnConflict = Nothing } deleteToken :: T.Text -> PGS.Connection -> Handler Int64 deleteToken tstr conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(rtstr, _, _, _) -> rtstr .== C.constant tstr , dReturning = rCount } deleteTokenByUserId :: Int -> PGS.Connection -> MateHandler Int64 deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(_, rid, _, _) -> rid .== C.constant uid , dReturning = rCount } deleteOldTokens :: UTCTime -> PGS.Connection -> IO Int64 deleteOldTokens now conn = runDelete_ conn $ Delete { dTable = tokenTable , dWhere = \(_, _, expiry, _) -> expiry .< C.constant now , dReturning = rCount } newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket ident method = do store <- asks rsTicketStore rand1 <- liftIO generateRandomText rand2 <- liftIO $ case method of ChallengeResponse -> Just <$> generateRandomText _ -> 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 hash) 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 hash conn _ -> do liftIO $ threadDelay delayTime return Denied processLogout :: Int -> PGS.Connection -> MateHandler () processLogout uid conn = void $ deleteTokenByUserId uid conn