mateamt/src/Model/Auth.hs

270 lines
6.1 KiB
Haskell
Raw Normal View History

{-# 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-08 23:24:58 +00:00
import Control.Concurrent.STM
2019-04-21 15:27:15 +00:00
import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS
import Data.Int (Int64)
2019-04-21 15:27:15 +00:00
import Data.Text (Text)
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)
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\" ("
, "token_string BYTEA NOT NULL PRIMARY KEY,"
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
, "token_expiry TIMESTAMPTZ NOT NULL"
2019-07-21 13:02:59 +00:00
, ")"
]
2019-04-21 15:27:15 +00:00
tokenTable :: Table
( Field SqlBytea
, Field SqlInt4
, Field SqlTimestamptz
)
( Field SqlBytea
, Field SqlInt4
, Field SqlTimestamptz
)
tokenTable = table "token" (
p3
( tableField "token_string"
, tableField "token_user"
, tableField "token_expiry"
)
)
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-05-06 21:41:05 +00:00
-> MateHandler AuthInfo
2019-05-09 14:53:19 +00:00
getUserAuthInfo ident = do
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
users <- liftIO $ do
2019-09-07 00:48:16 +00:00
void $ threadDelay delayTime
runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant ident) <<< queryTable userTable
) :: IO
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
if null users
then throwError $ err404
{ errBody = "No such user"
}
else
2019-09-07 00:48:16 +00:00
head <$> mapM (\(_, _, _, _, _, _, i7, _, i9) ->
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
)
users
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
:: PGS.Connection
-> ByteString
-> Handler (Maybe Int)
validateToken conn header = do
tokens <- liftIO $ runSelect conn (
keepWhen (\(tstr, _, _) ->
tstr .== C.constant header) <<< queryTable tokenTable
) :: Handler
[ ( ByteString
, Int
, UTCTime
)
]
case tokens of
[(_, uid, stamp)] -> do
now <- liftIO $ getCurrentTime
if diffUTCTime stamp now > 0
then return $ Just uid
else do
2019-07-28 09:55:22 +00:00
void $ deleteToken header conn
2019-09-07 00:48:16 +00:00
liftIO $ threadDelay delayTime
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
-> AuthHash
2019-05-09 14:53:19 +00:00
-> MateHandler AuthResult
2019-09-07 00:48:16 +00:00
generateToken (Ticket _ ident _) (AuthHash hash) = do
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
2019-05-09 14:53:19 +00:00
uid .== C.constant ident) <<< queryTable userTable
2019-05-08 23:24:58 +00:00
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
2019-09-07 00:48:16 +00:00
let userHash = head $ map (\(_, _, _, _, _, _, _, i8, _) -> i8) users
2019-05-09 14:53:19 +00:00
if userHash == Nothing || userHash == Just hash
then do
token <- liftIO $ Token
<$> (random 23)
<*> (pure ident)
2019-05-10 12:10:11 +00:00
<*> (addUTCTime (23*60) <$> getCurrentTime)
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
-> MateHandler ByteString
insertToken (Token tString tUser tExpiry) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable
, iRows =
[
( C.constant tString
, C.constant tUser
, C.constant tExpiry
)
]
, iReturning = rReturning (\(ident, _, _) -> ident)
, iOnConflict = Nothing
}
2019-05-08 23:24:58 +00:00
2019-07-18 14:10:18 +00:00
deleteToken
:: ByteString
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> Handler Int64
deleteToken tstr conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount
}
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
, dWhere = (\(_, rid, _) -> rid .== C.constant uid)
, dReturning = rCount
}
2019-05-06 21:41:05 +00:00
newTicket :: Int -> MateHandler AuthTicket
2019-05-09 14:53:19 +00:00
newTicket ident = do
2019-05-06 21:41:05 +00:00
store <- rsTicketStore <$> ask
rand <- liftIO $ 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-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
#if defined(DEVELOP)
do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
generateToken mockticket hash
#else
2019-05-10 12:10:11 +00:00
return Denied
#endif
2019-05-10 12:10:11 +00:00
else
generateToken ticket hash
_ -> do
2019-09-07 00:48:16 +00:00
liftIO $ threadDelay delayTime
#if defined(DEVELOP)
do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
generateToken mockticket hash
#else
return Denied
#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