2019-04-21 15:27:15 +00:00
{- # LANGUAGE DeriveGeneric # -}
{- # LANGUAGE OverloadedStrings # -}
module Model.Auth where
import GHC.Generics
import Control.Arrow ( ( <<< ) )
2019-05-06 21:41:05 +00:00
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Reader ( ask )
2019-04-21 15:27:15 +00:00
import Data.Profunctor.Product ( p3 )
import qualified Database.PostgreSQL.Simple as PGS
import Data.Text ( Text )
2019-05-06 21:41:05 +00:00
import Data.Fixed ( Fixed ( .. ) )
2019-04-21 15:27:15 +00:00
import Data.Time.Calendar ( Day )
2019-05-06 21:41:05 +00:00
import Data.Time.Clock ( secondsToNominalDiffTime )
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
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
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
:: PGS . Connection
-> Int
2019-05-06 21:41:05 +00:00
-> MateHandler AuthInfo
2019-04-21 15:27:15 +00:00
getUserAuthInfo conn id = do
2019-05-06 21:41:05 +00:00
users <- liftIO $ runSelect conn (
2019-04-21 15:27:15 +00:00
keepWhen ( \ ( uid , _ , _ , _ , _ , _ , _ , _ , _ ) ->
uid .== C . constant id ) <<< queryTable userTable
) :: IO
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
2019-05-06 21:41:05 +00:00
head <$> mapM ( \ ( i1 , i2 , i3 , i4 , i5 , i6 , i7 , i8 , i9 ) ->
AuthInfo ( AuthSalt i7 ) ( toEnum $ fromMaybe 0 i9 ) <$> newTicket id
2019-04-21 15:27:15 +00:00
)
users
2019-05-06 21:41:05 +00:00
newTicket :: Int -> MateHandler AuthTicket
newTicket id = do
store <- rsTicketStore <$> ask
rand <- liftIO $ random 23
later <- liftIO $ ( addUTCTime ( secondsToNominalDiffTime ( MkFixed 23 ) ) <$> getCurrentTime )
let ticket = AuthTicket
{ ticketId = rand
, ticketUser = id
, ticketExpiry = later
}
liftIO $ modifyTVar store ( \ s -> insert tocket store )
retur ticket