mateamt/src/Model/Auth.hs

96 lines
2.1 KiB
Haskell
Raw Normal View History

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