165 lines
3.8 KiB
Haskell
165 lines
3.8 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Model.Auth where
|
|
|
|
import GHC.Generics
|
|
|
|
import Control.Arrow ((<<<))
|
|
|
|
import Control.Monad (void)
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import Control.Monad.Reader (ask)
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
import Data.Profunctor.Product (p3)
|
|
|
|
import qualified Database.PostgreSQL.Simple as PGS
|
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Set as S
|
|
|
|
import Data.Time.Calendar (Day)
|
|
import Data.Time.Clock
|
|
|
|
import Data.ByteString (ByteString)
|
|
import Data.ByteString.Random
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
import Opaleye
|
|
import qualified Opaleye.Constant as C
|
|
|
|
-- internal imports
|
|
|
|
import Types.Auth
|
|
import Types.Reader
|
|
|
|
import Model.User
|
|
|
|
initToken :: PGS.Query
|
|
initToken = "create table if not exists \"token\" (token_string bytea not null primary key, token_user integer not null, token_expiry timestamptz not null)"
|
|
|
|
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"
|
|
)
|
|
)
|
|
|
|
getUserAuthInfo
|
|
:: Int
|
|
-> MateHandler AuthInfo
|
|
getUserAuthInfo ident = do
|
|
conn <- rsConnection <$> ask
|
|
users <- liftIO $ runSelect conn (
|
|
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
|
|
uid .== C.constant ident) <<< queryTable userTable
|
|
) :: MateHandler
|
|
[ ( Int
|
|
, Text
|
|
, Int
|
|
, Day
|
|
, Maybe Text
|
|
, Maybe Int
|
|
, ByteString
|
|
, Maybe ByteString
|
|
, Maybe Int
|
|
)
|
|
]
|
|
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) ->
|
|
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
|
|
)
|
|
users
|
|
|
|
generateToken
|
|
:: Ticket
|
|
-> AuthHash
|
|
-> MateHandler AuthResult
|
|
generateToken (Ticket _ ident exp) (AuthHash hash) = do
|
|
conn <- rsConnection <$> ask
|
|
users <- liftIO $ runSelect conn (
|
|
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
|
|
uid .== C.constant ident) <<< queryTable userTable
|
|
) :: MateHandler
|
|
[ ( Int
|
|
, Text
|
|
, Int
|
|
, Day
|
|
, Maybe Text
|
|
, Maybe Int
|
|
, ByteString
|
|
, Maybe ByteString
|
|
, Maybe Int
|
|
)
|
|
]
|
|
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)
|
|
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
|
void $ liftIO $ runInsert_ conn (insertToken token)
|
|
return $ Granted (AuthToken $ tokenString token)
|
|
else
|
|
return Denied
|
|
|
|
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
|
|
}
|
|
|
|
newTicket :: Int -> MateHandler AuthTicket
|
|
newTicket ident = do
|
|
store <- rsTicketStore <$> ask
|
|
rand <- liftIO $ random 23
|
|
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
|
|
let ticket = Ticket
|
|
{ ticketId = AuthTicket rand
|
|
, ticketUser = ident
|
|
, ticketExpiry = later
|
|
}
|
|
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
|
|
return (AuthTicket rand)
|
|
|
|
processAuthRequest
|
|
:: AuthRequest
|
|
-> MateHandler AuthResult
|
|
processAuthRequest (AuthRequest aticket hash) = do
|
|
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
|
|
let mticket = S.filter (\st -> ticketId st == aticket) store
|
|
case S.toList mticket of
|
|
[ticket] -> do
|
|
now <- liftIO $ getCurrentTime
|
|
if now > ticketExpiry ticket
|
|
then
|
|
return Denied
|
|
else
|
|
generateToken ticket hash
|
|
_ -> return Denied
|