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 GHC.Generics
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-05-17 16:37:35 +00:00
import Control.Concurrent ( threadDelay , forkIO )
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
2019-05-17 16:37:35 +00:00
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 )
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-05-24 19:02:13 +00:00
initToken = " 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-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-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
2019-05-17 16:37:35 +00:00
users <- liftIO $ do
void $ threadDelay $ 1 * 10 ^ 6
runSelect conn (
keepWhen ( \ ( uid , _ , _ , _ , _ , _ , _ , _ , _ ) ->
uid .== C . constant ident ) <<< queryTable userTable
) :: IO
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
2019-05-24 19:02:13 +00:00
if null users
then throwError $ err404
{ errBody = " No such user "
}
else
head <$> mapM ( \ ( i1 , i2 , i3 , i4 , i5 , i6 , i7 , i8 , 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
2019-05-17 16:37:35 +00:00
else do
liftIO $ do
void $ forkIO $ void $ runDelete_ conn ( deleteToken header )
threadDelay $ 1 * 10 ^ 6
throwError $ err401
{ errBody = " Your token expired! "
}
_ -> do
liftIO $ threadDelay $ 1 * 10 ^ 6
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
generateToken ( Ticket _ ident exp ) ( 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-05-09 14:53:19 +00:00
let userHash = head $ map ( \ ( i1 , i2 , i3 , i4 , i5 , i6 , i7 , i8 , i9 ) -> i8 ) users
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-05-09 14:53:19 +00:00
void $ liftIO $ runInsert_ conn ( insertToken token )
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
-> Insert [ ByteString ]
insertToken ( Token tString tUser tExpiry ) = 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
2019-05-17 16:37:35 +00:00
deleteToken
:: ByteString
-> Opaleye . Delete Int64
deleteToken tstr = Delete
{ dTable = tokenTable
, dWhere = ( \ ( rtstr , _ , _ ) -> rtstr .== C . constant tstr )
, dReturning = rCount
}
2019-07-18 14:09:59 +00:00
deleteTokenByUserId
:: Int
-> Opaleye . Delete Int64
deleteTokenByUserId uid = Delete
{ 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-05-17 16:37:35 +00:00
liftIO $ threadDelay $ 1 * 10 ^ 6
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
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
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
liftIO $ threadDelay $ 1 * 10 ^ 6
2019-07-18 12:57:16 +00:00
# if defined ( DEVELOP )
do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
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
liftIO $ void $ runDelete_ conn ( deleteTokenByUserId uid )