2019-07-18 12:57:16 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
2019-04-21 15:27:15 +00:00
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Model.Auth where
|
|
|
|
|
2019-05-16 02:07:20 +00:00
|
|
|
import Servant
|
2019-05-13 20:50:24 +00:00
|
|
|
|
2019-04-21 15:27:15 +00:00
|
|
|
import Control.Arrow ((<<<))
|
|
|
|
|
2019-05-09 14:53:19 +00:00
|
|
|
import Control.Monad (void)
|
|
|
|
|
2019-05-06 21:41:05 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
|
|
|
import Control.Monad.Reader (ask)
|
|
|
|
|
2019-09-07 00:48:16 +00:00
|
|
|
import Control.Concurrent (threadDelay)
|
2019-05-17 16:37:35 +00:00
|
|
|
|
2019-05-08 23:24:58 +00:00
|
|
|
import Control.Concurrent.STM
|
|
|
|
|
2019-09-14 21:03:04 +00:00
|
|
|
import Data.Profunctor.Product (p4)
|
2019-04-21 15:27:15 +00:00
|
|
|
|
|
|
|
import qualified Database.PostgreSQL.Simple as PGS
|
|
|
|
|
2019-05-17 16:37:35 +00:00
|
|
|
import Data.Int (Int64)
|
|
|
|
|
2019-09-14 21:03:04 +00:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import Data.Text.Encoding
|
2019-04-21 15:27:15 +00:00
|
|
|
|
2019-05-08 23:24:58 +00:00
|
|
|
import qualified Data.Set as S
|
2019-05-06 21:41:05 +00:00
|
|
|
|
2019-04-21 15:27:15 +00:00
|
|
|
import Data.Time.Calendar (Day)
|
2019-05-08 23:24:58 +00:00
|
|
|
import Data.Time.Clock
|
2019-04-21 15:27:15 +00:00
|
|
|
|
|
|
|
import Data.ByteString (ByteString)
|
2019-05-06 21:41:05 +00:00
|
|
|
import Data.ByteString.Random
|
2019-04-21 15:27:15 +00:00
|
|
|
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
|
2019-05-24 19:02:13 +00:00
|
|
|
import Opaleye hiding (null)
|
2019-04-21 15:27:15 +00:00
|
|
|
import qualified Opaleye.Constant as C
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types.Auth
|
2019-05-06 21:41:05 +00:00
|
|
|
import Types.Reader
|
2019-04-21 15:27:15 +00:00
|
|
|
|
|
|
|
import Model.User
|
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-04-21 15:27:15 +00:00
|
|
|
initToken :: PGS.Query
|
2019-07-21 14:05:05 +00:00
|
|
|
initToken = mconcat
|
2019-08-10 09:41:57 +00:00
|
|
|
[ "CREATE TABLE IF NOT EXISTS \"token\" ("
|
2019-09-14 21:03:04 +00:00
|
|
|
, "token_string TEXT NOT NULL PRIMARY KEY,"
|
2019-08-10 09:41:57 +00:00
|
|
|
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
|
2019-09-14 21:03:04 +00:00
|
|
|
, "token_expiry TIMESTAMPTZ NOT NULL,"
|
|
|
|
, "token_method INT NOT NULL"
|
2019-07-21 13:02:59 +00:00
|
|
|
, ")"
|
|
|
|
]
|
2019-04-21 15:27:15 +00:00
|
|
|
|
|
|
|
tokenTable :: Table
|
2019-09-14 21:03:04 +00:00
|
|
|
( Field SqlText
|
2019-04-21 15:27:15 +00:00
|
|
|
, Field SqlInt4
|
|
|
|
, Field SqlTimestamptz
|
2019-09-14 21:03:04 +00:00
|
|
|
, Field SqlInt4
|
2019-04-21 15:27:15 +00:00
|
|
|
)
|
2019-09-14 21:03:04 +00:00
|
|
|
( Field SqlText
|
2019-04-21 15:27:15 +00:00
|
|
|
, Field SqlInt4
|
|
|
|
, Field SqlTimestamptz
|
2019-09-14 21:03:04 +00:00
|
|
|
, Field SqlInt4
|
2019-04-21 15:27:15 +00:00
|
|
|
)
|
|
|
|
tokenTable = table "token" (
|
2019-09-14 21:03:04 +00:00
|
|
|
p4
|
|
|
|
( tableField "token_string"
|
|
|
|
, tableField "token_user"
|
|
|
|
, tableField "token_expiry"
|
|
|
|
, tableField "token_method"
|
2019-04-21 15:27:15 +00:00
|
|
|
)
|
2019-09-14 21:03:04 +00:00
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
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_payload TEXT"
|
|
|
|
, ")"
|
|
|
|
]
|
|
|
|
|
|
|
|
authDataTable :: Table
|
|
|
|
( Maybe (Field SqlInt4)
|
|
|
|
, Field SqlInt4
|
|
|
|
, Field SqlInt4
|
|
|
|
, FieldNullable SqlText
|
|
|
|
)
|
|
|
|
( Field SqlInt4
|
|
|
|
, Field SqlInt4
|
|
|
|
, Field SqlInt4
|
|
|
|
, FieldNullable SqlText
|
|
|
|
)
|
|
|
|
authDataTable = table "auth_data" (
|
|
|
|
p4
|
|
|
|
( tableField "auth_data_id"
|
|
|
|
, tableField "auth_data_user"
|
|
|
|
, tableField "auth_data_method"
|
|
|
|
, tableField "auth_data_payload"
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
2019-04-21 15:27:15 +00:00
|
|
|
|
2019-09-07 00:48:16 +00:00
|
|
|
delayTime :: Int
|
|
|
|
delayTime = 1 * 10 ^ (6 :: Int)
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-04-21 15:27:15 +00:00
|
|
|
getUserAuthInfo
|
2019-05-09 14:53:19 +00:00
|
|
|
:: Int
|
2019-09-14 21:03:04 +00:00
|
|
|
-> AuthMethod
|
|
|
|
-> MateHandler (Maybe AuthInfo)
|
|
|
|
getUserAuthInfo uid method = do
|
2019-05-08 23:24:58 +00:00
|
|
|
conn <- rsConnection <$> ask
|
2019-09-14 21:03:04 +00:00
|
|
|
authdata <- liftIO $ do
|
2019-09-07 00:48:16 +00:00
|
|
|
void $ threadDelay delayTime
|
2019-05-17 16:37:35 +00:00
|
|
|
runSelect conn (
|
2019-09-14 21:03:04 +00:00
|
|
|
keepWhen (\(_, duid, dmethod, _) ->
|
|
|
|
duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
|
|
|
|
<<< queryTable authDataTable
|
2019-05-17 16:37:35 +00:00
|
|
|
) :: IO
|
|
|
|
[ ( Int
|
|
|
|
, Int
|
2019-09-14 21:03:04 +00:00
|
|
|
, Int
|
|
|
|
, Maybe T.Text
|
2019-05-17 16:37:35 +00:00
|
|
|
)
|
|
|
|
]
|
2019-09-14 21:03:04 +00:00
|
|
|
if null authdata
|
|
|
|
then
|
|
|
|
return Nothing
|
2019-05-24 19:02:13 +00:00
|
|
|
else
|
2019-09-14 21:03:04 +00:00
|
|
|
Just <$> head <$> mapM (\(_, _, _, payload) ->
|
|
|
|
AuthInfo payload <$> newTicket uid method
|
2019-05-24 19:02:13 +00:00
|
|
|
)
|
2019-09-14 21:03:04 +00:00
|
|
|
authdata
|
2019-05-06 21:41:05 +00:00
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-05-13 20:50:24 +00:00
|
|
|
validateToken
|
2019-09-14 21:03:04 +00:00
|
|
|
:: ByteString
|
|
|
|
-> PGS.Connection
|
2019-05-13 20:50:24 +00:00
|
|
|
-> Handler (Maybe Int)
|
2019-09-14 21:03:04 +00:00
|
|
|
validateToken header conn = do
|
2019-05-13 20:50:24 +00:00
|
|
|
tokens <- liftIO $ runSelect conn (
|
2019-09-14 21:03:04 +00:00
|
|
|
keepWhen (\(tstr, _, _, _) ->
|
|
|
|
tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable
|
2019-05-13 20:50:24 +00:00
|
|
|
) :: Handler
|
2019-09-14 21:03:04 +00:00
|
|
|
[ ( T.Text
|
2019-05-13 20:50:24 +00:00
|
|
|
, Int
|
|
|
|
, UTCTime
|
2019-09-14 21:03:04 +00:00
|
|
|
, Int
|
2019-05-13 20:50:24 +00:00
|
|
|
)
|
|
|
|
]
|
|
|
|
case tokens of
|
2019-09-14 21:03:04 +00:00
|
|
|
[(_, uid, stamp, method)] -> do
|
2019-05-13 20:50:24 +00:00
|
|
|
now <- liftIO $ getCurrentTime
|
|
|
|
if diffUTCTime stamp now > 0
|
|
|
|
then return $ Just uid
|
2019-05-17 16:37:35 +00:00
|
|
|
else do
|
2019-09-14 21:03:04 +00:00
|
|
|
void $ deleteToken (decodeUtf8 header) conn
|
2019-09-07 00:48:16 +00:00
|
|
|
liftIO $ threadDelay delayTime
|
2019-05-17 16:37:35 +00:00
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Your token expired!"
|
|
|
|
}
|
|
|
|
_ -> do
|
2019-09-07 00:48:16 +00:00
|
|
|
liftIO $ threadDelay delayTime
|
2019-05-16 02:07:20 +00:00
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "No valid token found!"
|
|
|
|
}
|
2019-05-13 20:50:24 +00:00
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-05-09 14:53:19 +00:00
|
|
|
generateToken
|
2019-05-08 23:24:58 +00:00
|
|
|
:: Ticket
|
2019-09-14 21:03:04 +00:00
|
|
|
-> AuthResponse
|
2019-05-09 14:53:19 +00:00
|
|
|
-> MateHandler AuthResult
|
2019-09-14 21:03:04 +00:00
|
|
|
generateToken (Ticket _ tuid _ method) (AuthResponse hash) = do
|
2019-05-08 23:24:58 +00:00
|
|
|
conn <- rsConnection <$> ask
|
2019-09-14 21:03:04 +00:00
|
|
|
authData <- liftIO $ runSelect conn (
|
|
|
|
keepWhen (\(_, auid, _, _) ->
|
|
|
|
auid .== C.constant tuid) <<< queryTable authDataTable
|
2019-05-08 23:24:58 +00:00
|
|
|
) :: MateHandler
|
|
|
|
[ ( Int
|
|
|
|
, Int
|
2019-09-14 21:03:04 +00:00
|
|
|
, Int
|
|
|
|
, Maybe T.Text
|
2019-05-08 23:24:58 +00:00
|
|
|
)
|
|
|
|
]
|
2019-09-14 21:03:04 +00:00
|
|
|
let userHash = head $ map (\(_, _, _, payload) -> payload) authData
|
2019-05-09 14:53:19 +00:00
|
|
|
if userHash == Nothing || userHash == Just hash
|
|
|
|
then do
|
|
|
|
token <- liftIO $ Token
|
2019-09-14 21:03:04 +00:00
|
|
|
<$> (decodeUtf8 <$> random 23)
|
|
|
|
<*> pure tuid
|
2019-05-10 12:10:11 +00:00
|
|
|
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
2019-09-14 21:03:04 +00:00
|
|
|
<*> pure method
|
2019-07-28 09:55:22 +00:00
|
|
|
void $ insertToken token conn
|
2019-05-09 14:53:19 +00:00
|
|
|
return $ Granted (AuthToken $ tokenString token)
|
|
|
|
else
|
|
|
|
return Denied
|
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-05-09 14:53:19 +00:00
|
|
|
insertToken
|
|
|
|
:: Token
|
2019-07-28 09:55:22 +00:00
|
|
|
-> PGS.Connection
|
2019-09-14 21:03:04 +00:00
|
|
|
-> MateHandler T.Text
|
|
|
|
insertToken (Token tString tUser tExpiry tMethod) conn =
|
2019-07-28 09:55:22 +00:00
|
|
|
fmap head $ liftIO $ runInsert_ conn $ Insert
|
|
|
|
{ iTable = tokenTable
|
|
|
|
, iRows =
|
|
|
|
[
|
|
|
|
( C.constant tString
|
|
|
|
, C.constant tUser
|
|
|
|
, C.constant tExpiry
|
2019-09-14 21:03:04 +00:00
|
|
|
, C.constant (fromEnum tMethod)
|
2019-07-28 09:55:22 +00:00
|
|
|
)
|
|
|
|
]
|
2019-09-14 21:03:04 +00:00
|
|
|
, iReturning = rReturning (\(ident, _, _, _) -> ident)
|
2019-07-28 09:55:22 +00:00
|
|
|
, iOnConflict = Nothing
|
|
|
|
}
|
2019-05-08 23:24:58 +00:00
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-05-17 16:37:35 +00:00
|
|
|
deleteToken
|
2019-09-14 21:03:04 +00:00
|
|
|
:: T.Text
|
2019-07-28 09:55:22 +00:00
|
|
|
-> PGS.Connection
|
|
|
|
-> Handler Int64
|
|
|
|
deleteToken tstr conn =
|
|
|
|
liftIO $ runDelete_ conn $ Delete
|
|
|
|
{ dTable = tokenTable
|
2019-09-14 21:03:04 +00:00
|
|
|
, dWhere = (\(rtstr, _, _, _) -> rtstr .== C.constant tstr)
|
2019-07-28 09:55:22 +00:00
|
|
|
, dReturning = rCount
|
|
|
|
}
|
2019-05-17 16:37:35 +00:00
|
|
|
|
2019-07-18 14:09:59 +00:00
|
|
|
|
|
|
|
deleteTokenByUserId
|
|
|
|
:: Int
|
2019-07-28 09:55:22 +00:00
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int64
|
|
|
|
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
|
2019-07-18 14:09:59 +00:00
|
|
|
{ dTable = tokenTable
|
2019-09-14 21:03:04 +00:00
|
|
|
, dWhere = (\(_, rid, _, _) -> rid .== C.constant uid)
|
2019-07-18 14:09:59 +00:00
|
|
|
, dReturning = rCount
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2019-09-14 21:03:04 +00:00
|
|
|
newTicket :: Int -> AuthMethod -> MateHandler AuthTicket
|
|
|
|
newTicket ident method = do
|
2019-05-06 21:41:05 +00:00
|
|
|
store <- rsTicketStore <$> ask
|
2019-09-14 21:03:04 +00:00
|
|
|
rand <- liftIO $ (decodeUtf8 <$> random 23)
|
2019-05-10 12:10:11 +00:00
|
|
|
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
|
2019-05-08 23:24:58 +00:00
|
|
|
let ticket = Ticket
|
|
|
|
{ ticketId = AuthTicket rand
|
2019-05-09 14:53:19 +00:00
|
|
|
, ticketUser = ident
|
2019-05-06 21:41:05 +00:00
|
|
|
, ticketExpiry = later
|
2019-09-14 21:03:04 +00:00
|
|
|
, ticketMethod = method
|
2019-05-06 21:41:05 +00:00
|
|
|
}
|
2019-05-08 23:24:58 +00:00
|
|
|
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
|
|
|
|
return (AuthTicket rand)
|
|
|
|
|
2019-07-18 14:10:18 +00:00
|
|
|
|
2019-05-08 23:24:58 +00:00
|
|
|
processAuthRequest
|
|
|
|
:: AuthRequest
|
|
|
|
-> MateHandler AuthResult
|
|
|
|
processAuthRequest (AuthRequest aticket hash) = do
|
2019-05-09 14:53:19 +00:00
|
|
|
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
|
2019-05-08 23:24:58 +00:00
|
|
|
let mticket = S.filter (\st -> ticketId st == aticket) store
|
2019-05-09 14:53:19 +00:00
|
|
|
case S.toList mticket of
|
2019-05-10 12:10:11 +00:00
|
|
|
[ticket] -> do
|
|
|
|
now <- liftIO $ getCurrentTime
|
2019-09-07 00:48:16 +00:00
|
|
|
liftIO $ threadDelay delayTime
|
2019-05-10 12:10:11 +00:00
|
|
|
if now > ticketExpiry ticket
|
|
|
|
then
|
2019-07-18 12:57:16 +00:00
|
|
|
#if defined(DEVELOP)
|
|
|
|
do
|
2019-09-14 21:03:04 +00:00
|
|
|
mockticket <- Ticket <$>
|
|
|
|
pure aticket <*>
|
|
|
|
pure 1 <*>
|
|
|
|
liftIO getCurrentTime <*>
|
|
|
|
pure PrimaryPass
|
2019-07-18 12:57:16 +00:00
|
|
|
generateToken mockticket hash
|
|
|
|
#else
|
2019-05-10 12:10:11 +00:00
|
|
|
return Denied
|
2019-07-18 12:57:16 +00:00
|
|
|
#endif
|
2019-05-10 12:10:11 +00:00
|
|
|
else
|
|
|
|
generateToken ticket hash
|
2019-05-17 16:37:35 +00:00
|
|
|
_ -> do
|
2019-09-07 00:48:16 +00:00
|
|
|
liftIO $ threadDelay delayTime
|
2019-07-18 12:57:16 +00:00
|
|
|
#if defined(DEVELOP)
|
|
|
|
do
|
2019-09-14 21:03:04 +00:00
|
|
|
mockticket <- Ticket <$>
|
|
|
|
pure aticket <*>
|
|
|
|
pure 1 <*>
|
|
|
|
liftIO getCurrentTime <*>
|
|
|
|
pure PrimaryPass
|
2019-07-18 12:57:16 +00:00
|
|
|
generateToken mockticket hash
|
|
|
|
#else
|
2019-05-17 16:37:35 +00:00
|
|
|
return Denied
|
2019-07-18 12:57:16 +00:00
|
|
|
#endif
|
2019-07-18 14:09:59 +00:00
|
|
|
|
|
|
|
processLogout
|
|
|
|
:: Int
|
|
|
|
-> MateHandler ()
|
|
|
|
processLogout uid = do
|
|
|
|
conn <- rsConnection <$> ask
|
2019-07-28 09:55:22 +00:00
|
|
|
void $ deleteTokenByUserId uid conn
|