mateamt/src/Model/Auth.hs
2019-05-10 14:10:11 +02:00

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