starting serious auth implementation efforts
This commit is contained in:
parent
9a22594351
commit
2c4f949102
8 changed files with 187 additions and 199 deletions
|
|
@ -39,6 +39,7 @@ main = do
|
|||
void $ execute_ conn initUser
|
||||
void $ execute_ conn initProduct
|
||||
void $ execute_ conn initToken
|
||||
void $ execute_ conn initAuthData
|
||||
void $ execute_ conn initAmount
|
||||
void $ execute_ conn initJournal
|
||||
withStdoutLogger $ \ilog -> do
|
||||
|
|
@ -105,7 +106,7 @@ authHandler conn = mkAuthHandler handler
|
|||
let headers = requestHeaders req
|
||||
res <- case lookup "Authentication" headers of
|
||||
Just hh ->
|
||||
validateToken conn (fst $ decode hh)
|
||||
validateToken (fst $ decode hh) conn
|
||||
_ ->
|
||||
return Nothing
|
||||
return res
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import Servant.RawM
|
|||
import Types
|
||||
|
||||
type MateAPI =
|
||||
"auth" :> "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo
|
||||
"auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
|
||||
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
|
||||
:<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
|
||||
:> Delete '[JSON] ()
|
||||
|
|
|
|||
|
|
@ -8,9 +8,14 @@ import Servant
|
|||
import Types
|
||||
import Model
|
||||
|
||||
authGet :: Int -> MateHandler AuthInfo
|
||||
authGet uid =
|
||||
getUserAuthInfo uid
|
||||
authGet :: TicketRequest -> MateHandler AuthInfo
|
||||
authGet (TicketRequest uid method) = do
|
||||
mai <- getUserAuthInfo uid method
|
||||
case mai of
|
||||
Just ai -> (return ai :: MateHandler AuthInfo)
|
||||
Nothing -> throwError $ err404
|
||||
{ errBody = "No such user"
|
||||
}
|
||||
|
||||
authSend :: AuthRequest -> MateHandler AuthResult
|
||||
authSend = processAuthRequest
|
||||
|
|
|
|||
|
|
@ -11,8 +11,6 @@ import Control.Monad.IO.Class (liftIO)
|
|||
|
||||
import Data.Time (getCurrentTime, utctDay)
|
||||
|
||||
import Data.ByteString.Random (random)
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -25,9 +23,8 @@ import Model
|
|||
userNew :: UserSubmit -> MateHandler Int
|
||||
userNew us = do
|
||||
now <- liftIO $ getCurrentTime
|
||||
randSalt <- liftIO $ random 8
|
||||
conn <- rsConnection <$> ask
|
||||
insertUser us (utctDay now) randSalt conn
|
||||
insertUser us (utctDay now) conn
|
||||
|
||||
userGet :: Maybe Int -> Int -> MateHandler UserDetails
|
||||
userGet Nothing _ =
|
||||
|
|
|
|||
|
|
@ -17,13 +17,14 @@ import Control.Concurrent (threadDelay)
|
|||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import Data.Profunctor.Product (p3)
|
||||
import Data.Profunctor.Product (p4)
|
||||
|
||||
import qualified Database.PostgreSQL.Simple as PGS
|
||||
|
||||
import Data.Int (Int64)
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding
|
||||
|
||||
import qualified Data.Set as S
|
||||
|
||||
|
|
@ -49,86 +50,119 @@ import Model.User
|
|||
initToken :: PGS.Query
|
||||
initToken = mconcat
|
||||
[ "CREATE TABLE IF NOT EXISTS \"token\" ("
|
||||
, "token_string BYTEA NOT NULL PRIMARY KEY,"
|
||||
, "token_string TEXT NOT NULL PRIMARY KEY,"
|
||||
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
|
||||
, "token_expiry TIMESTAMPTZ NOT NULL"
|
||||
, "token_expiry TIMESTAMPTZ NOT NULL,"
|
||||
, "token_method INT NOT NULL"
|
||||
, ")"
|
||||
]
|
||||
|
||||
tokenTable :: Table
|
||||
( Field SqlBytea
|
||||
( Field SqlText
|
||||
, Field SqlInt4
|
||||
, Field SqlTimestamptz
|
||||
, Field SqlInt4
|
||||
)
|
||||
( Field SqlBytea
|
||||
( Field SqlText
|
||||
, Field SqlInt4
|
||||
, Field SqlTimestamptz
|
||||
, Field SqlInt4
|
||||
)
|
||||
tokenTable = table "token" (
|
||||
p3
|
||||
( tableField "token_string"
|
||||
, tableField "token_user"
|
||||
, tableField "token_expiry"
|
||||
)
|
||||
p4
|
||||
( tableField "token_string"
|
||||
, tableField "token_user"
|
||||
, tableField "token_expiry"
|
||||
, tableField "token_method"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
initAuthData :: PGS.Query
|
||||
initAuthData = mconcat
|
||||
[ "CREATE TABLE IF NOT EXISTS \"auth_data\" ("
|
||||
, "auth_data_id SERIAL PRIMARY KEY,"
|
||||
, "auth_data_user INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
|
||||
, "auth_data_method INTEGER NOT NULL,"
|
||||
, "auth_data_payload TEXT"
|
||||
, ")"
|
||||
]
|
||||
|
||||
authDataTable :: Table
|
||||
( Maybe (Field SqlInt4)
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlText
|
||||
)
|
||||
( Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlText
|
||||
)
|
||||
authDataTable = table "auth_data" (
|
||||
p4
|
||||
( tableField "auth_data_id"
|
||||
, tableField "auth_data_user"
|
||||
, tableField "auth_data_method"
|
||||
, tableField "auth_data_payload"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
delayTime :: Int
|
||||
delayTime = 1 * 10 ^ (6 :: Int)
|
||||
|
||||
getUserAuthInfo
|
||||
:: Int
|
||||
-> MateHandler AuthInfo
|
||||
getUserAuthInfo ident = do
|
||||
-> AuthMethod
|
||||
-> MateHandler (Maybe AuthInfo)
|
||||
getUserAuthInfo uid method = do
|
||||
conn <- rsConnection <$> ask
|
||||
users <- liftIO $ do
|
||||
authdata <- liftIO $ do
|
||||
void $ threadDelay delayTime
|
||||
runSelect conn (
|
||||
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
|
||||
uid .== C.constant ident) <<< queryTable userTable
|
||||
keepWhen (\(_, duid, dmethod, _) ->
|
||||
duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
|
||||
<<< queryTable authDataTable
|
||||
) :: IO
|
||||
[ ( Int
|
||||
, Text
|
||||
, Int
|
||||
, Day
|
||||
, Maybe Text
|
||||
, Maybe Int
|
||||
, ByteString
|
||||
, Maybe ByteString
|
||||
, Maybe Int
|
||||
, Int
|
||||
, Maybe T.Text
|
||||
)
|
||||
]
|
||||
if null users
|
||||
then throwError $ err404
|
||||
{ errBody = "No such user"
|
||||
}
|
||||
if null authdata
|
||||
then
|
||||
return Nothing
|
||||
else
|
||||
head <$> mapM (\(_, _, _, _, _, _, i7, _, i9) ->
|
||||
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
|
||||
Just <$> head <$> mapM (\(_, _, _, payload) ->
|
||||
AuthInfo payload <$> newTicket uid method
|
||||
)
|
||||
users
|
||||
authdata
|
||||
|
||||
|
||||
validateToken
|
||||
:: PGS.Connection
|
||||
-> ByteString
|
||||
:: ByteString
|
||||
-> PGS.Connection
|
||||
-> Handler (Maybe Int)
|
||||
validateToken conn header = do
|
||||
validateToken header conn = do
|
||||
tokens <- liftIO $ runSelect conn (
|
||||
keepWhen (\(tstr, _, _) ->
|
||||
tstr .== C.constant header) <<< queryTable tokenTable
|
||||
keepWhen (\(tstr, _, _, _) ->
|
||||
tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable
|
||||
) :: Handler
|
||||
[ ( ByteString
|
||||
[ ( T.Text
|
||||
, Int
|
||||
, UTCTime
|
||||
, Int
|
||||
)
|
||||
]
|
||||
case tokens of
|
||||
[(_, uid, stamp)] -> do
|
||||
[(_, uid, stamp, method)] -> do
|
||||
now <- liftIO $ getCurrentTime
|
||||
if diffUTCTime stamp now > 0
|
||||
then return $ Just uid
|
||||
else do
|
||||
void $ deleteToken header conn
|
||||
void $ deleteToken (decodeUtf8 header) conn
|
||||
liftIO $ threadDelay delayTime
|
||||
throwError $ err401
|
||||
{ errBody = "Your token expired!"
|
||||
|
|
@ -142,32 +176,28 @@ validateToken conn header = do
|
|||
|
||||
generateToken
|
||||
:: Ticket
|
||||
-> AuthHash
|
||||
-> AuthResponse
|
||||
-> MateHandler AuthResult
|
||||
generateToken (Ticket _ ident _) (AuthHash hash) = do
|
||||
generateToken (Ticket _ tuid _ method) (AuthResponse hash) = do
|
||||
conn <- rsConnection <$> ask
|
||||
users <- liftIO $ runSelect conn (
|
||||
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
|
||||
uid .== C.constant ident) <<< queryTable userTable
|
||||
authData <- liftIO $ runSelect conn (
|
||||
keepWhen (\(_, auid, _, _) ->
|
||||
auid .== C.constant tuid) <<< queryTable authDataTable
|
||||
) :: MateHandler
|
||||
[ ( Int
|
||||
, Text
|
||||
, Int
|
||||
, Day
|
||||
, Maybe Text
|
||||
, Maybe Int
|
||||
, ByteString
|
||||
, Maybe ByteString
|
||||
, Maybe Int
|
||||
, Int
|
||||
, Maybe T.Text
|
||||
)
|
||||
]
|
||||
let userHash = head $ map (\(_, _, _, _, _, _, _, i8, _) -> i8) users
|
||||
let userHash = head $ map (\(_, _, _, payload) -> payload) authData
|
||||
if userHash == Nothing || userHash == Just hash
|
||||
then do
|
||||
token <- liftIO $ Token
|
||||
<$> (random 23)
|
||||
<*> (pure ident)
|
||||
<$> (decodeUtf8 <$> random 23)
|
||||
<*> pure tuid
|
||||
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
||||
<*> pure method
|
||||
void $ insertToken token conn
|
||||
return $ Granted (AuthToken $ tokenString token)
|
||||
else
|
||||
|
|
@ -177,8 +207,8 @@ generateToken (Ticket _ ident _) (AuthHash hash) = do
|
|||
insertToken
|
||||
:: Token
|
||||
-> PGS.Connection
|
||||
-> MateHandler ByteString
|
||||
insertToken (Token tString tUser tExpiry) conn =
|
||||
-> MateHandler T.Text
|
||||
insertToken (Token tString tUser tExpiry tMethod) conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = tokenTable
|
||||
, iRows =
|
||||
|
|
@ -186,21 +216,22 @@ insertToken (Token tString tUser tExpiry) conn =
|
|||
( C.constant tString
|
||||
, C.constant tUser
|
||||
, C.constant tExpiry
|
||||
, C.constant (fromEnum tMethod)
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(ident, _, _) -> ident)
|
||||
, iReturning = rReturning (\(ident, _, _, _) -> ident)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
||||
deleteToken
|
||||
:: ByteString
|
||||
:: T.Text
|
||||
-> PGS.Connection
|
||||
-> Handler Int64
|
||||
deleteToken tstr conn =
|
||||
liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = tokenTable
|
||||
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
|
||||
, dWhere = (\(rtstr, _, _, _) -> rtstr .== C.constant tstr)
|
||||
, dReturning = rCount
|
||||
}
|
||||
|
||||
|
|
@ -211,20 +242,21 @@ deleteTokenByUserId
|
|||
-> MateHandler Int64
|
||||
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = tokenTable
|
||||
, dWhere = (\(_, rid, _) -> rid .== C.constant uid)
|
||||
, dWhere = (\(_, rid, _, _) -> rid .== C.constant uid)
|
||||
, dReturning = rCount
|
||||
}
|
||||
|
||||
|
||||
newTicket :: Int -> MateHandler AuthTicket
|
||||
newTicket ident = do
|
||||
newTicket :: Int -> AuthMethod -> MateHandler AuthTicket
|
||||
newTicket ident method = do
|
||||
store <- rsTicketStore <$> ask
|
||||
rand <- liftIO $ random 23
|
||||
rand <- liftIO $ (decodeUtf8 <$> random 23)
|
||||
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
|
||||
let ticket = Ticket
|
||||
{ ticketId = AuthTicket rand
|
||||
, ticketUser = ident
|
||||
, ticketExpiry = later
|
||||
, ticketMethod = method
|
||||
}
|
||||
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
|
||||
return (AuthTicket rand)
|
||||
|
|
@ -244,7 +276,11 @@ processAuthRequest (AuthRequest aticket hash) = do
|
|||
then
|
||||
#if defined(DEVELOP)
|
||||
do
|
||||
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
|
||||
mockticket <- Ticket <$>
|
||||
pure aticket <*>
|
||||
pure 1 <*>
|
||||
liftIO getCurrentTime <*>
|
||||
pure PrimaryPass
|
||||
generateToken mockticket hash
|
||||
#else
|
||||
return Denied
|
||||
|
|
@ -255,7 +291,11 @@ processAuthRequest (AuthRequest aticket hash) = do
|
|||
liftIO $ threadDelay delayTime
|
||||
#if defined(DEVELOP)
|
||||
do
|
||||
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime
|
||||
mockticket <- Ticket <$>
|
||||
pure aticket <*>
|
||||
pure 1 <*>
|
||||
liftIO getCurrentTime <*>
|
||||
pure PrimaryPass
|
||||
generateToken mockticket hash
|
||||
#else
|
||||
return Denied
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ import Data.Text as T hiding (head, foldl)
|
|||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.Profunctor.Product (p9)
|
||||
import Data.Profunctor.Product (p6)
|
||||
|
||||
import Data.ByteString hiding (head, foldl)
|
||||
|
||||
|
|
@ -35,10 +35,7 @@ initUser = mconcat
|
|||
, "user_balance INTEGER NOT NULL,"
|
||||
, "user_timestamp DATE NOT NULL,"
|
||||
, "user_email TEXT,"
|
||||
, "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE,"
|
||||
, "user_salt BYTEA NOT NULL,"
|
||||
, "user_hash BYTEA,"
|
||||
, "user_algo INTEGER"
|
||||
, "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE"
|
||||
, ")"
|
||||
]
|
||||
|
||||
|
|
@ -49,9 +46,6 @@ userTable :: Table
|
|||
, Field SqlDate
|
||||
, FieldNullable SqlText
|
||||
, FieldNullable SqlInt4
|
||||
, Field SqlBytea
|
||||
, FieldNullable SqlBytea
|
||||
, FieldNullable SqlInt4
|
||||
)
|
||||
( Field SqlInt4
|
||||
, Field SqlText
|
||||
|
|
@ -59,21 +53,15 @@ userTable :: Table
|
|||
, Field SqlDate
|
||||
, FieldNullable SqlText
|
||||
, FieldNullable SqlInt4
|
||||
, Field SqlBytea
|
||||
, FieldNullable SqlBytea
|
||||
, FieldNullable SqlInt4
|
||||
)
|
||||
userTable = table "user" (
|
||||
p9
|
||||
p6
|
||||
( tableField "user_id"
|
||||
, tableField "user_ident"
|
||||
, tableField "user_balance"
|
||||
, tableField "user_timestamp"
|
||||
, tableField "user_email"
|
||||
, tableField "user_avatar"
|
||||
, tableField "user_salt"
|
||||
, tableField "user_hash"
|
||||
, tableField "user_algo"
|
||||
)
|
||||
)
|
||||
|
||||
|
|
@ -85,10 +73,10 @@ userSelect ref conn = do
|
|||
today <- utctDay <$> (liftIO $ getCurrentTime)
|
||||
users <- liftIO $ runSelect conn (case ref of
|
||||
AllUsers -> selectTable userTable
|
||||
ActiveUsers -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
|
||||
ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
|
||||
ts .>= C.constant (addDays (-30) today)
|
||||
) <<< queryTable userTable
|
||||
OldUsers -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
|
||||
OldUsers -> keepWhen (\(_, _, _, ts, _, _) ->
|
||||
ts .<= C.constant (addDays (-30) today)
|
||||
) <<< queryTable userTable
|
||||
) :: MateHandler
|
||||
|
|
@ -98,14 +86,10 @@ userSelect ref conn = do
|
|||
, Day
|
||||
, Maybe Text
|
||||
, Maybe Int
|
||||
, ByteString
|
||||
, Maybe ByteString
|
||||
, Maybe Int
|
||||
)
|
||||
]
|
||||
mapM
|
||||
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
|
||||
-- User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
|
||||
(\(i1, i2, i3, i4, i5, i6) -> return $
|
||||
UserSummary i1 i2 i6
|
||||
)
|
||||
users
|
||||
|
|
@ -116,7 +100,7 @@ userDetailsSelect
|
|||
-> MateHandler UserDetails
|
||||
userDetailsSelect uid conn = do
|
||||
users <- liftIO $ runSelect conn (
|
||||
keepWhen (\(uuid, _, _, _, _, _, _, _, _) ->
|
||||
keepWhen (\(uuid, _, _, _, _, _) ->
|
||||
uuid .== C.constant uid
|
||||
) <<< queryTable userTable
|
||||
) :: MateHandler
|
||||
|
|
@ -126,14 +110,11 @@ userDetailsSelect uid conn = do
|
|||
, Day
|
||||
, Maybe Text
|
||||
, Maybe Int
|
||||
, ByteString
|
||||
, Maybe ByteString
|
||||
, Maybe Int
|
||||
)
|
||||
]
|
||||
head <$> mapM
|
||||
(\(i1, i2, i3, _, i5, i6, i7, _, i9) -> return $
|
||||
UserDetails i1 i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9)
|
||||
(\(i1, i2, i3, _, i5, i6) -> return $
|
||||
UserDetails i1 i2 i3 i5 i6
|
||||
)
|
||||
users
|
||||
|
||||
|
|
@ -144,7 +125,7 @@ userBalanceSelect
|
|||
-> MateHandler Int
|
||||
userBalanceSelect conn uid = do
|
||||
users <- liftIO $ runSelect conn (
|
||||
keepWhen (\(uuid, _, _, _, _, _, _, _, _) ->
|
||||
keepWhen (\(uuid, _, _, _, _, _) ->
|
||||
uuid .== C.constant uid
|
||||
) <<< queryTable userTable
|
||||
) :: MateHandler
|
||||
|
|
@ -154,13 +135,10 @@ userBalanceSelect conn uid = do
|
|||
, Day
|
||||
, Maybe Text
|
||||
, Maybe Int
|
||||
, ByteString
|
||||
, Maybe ByteString
|
||||
, Maybe Int
|
||||
)
|
||||
]
|
||||
head <$> mapM
|
||||
(\(_, _, i3, _, _, _, _, _, _) -> return $
|
||||
(\(_, _, i3, _, _, _) -> return $
|
||||
i3
|
||||
)
|
||||
users
|
||||
|
|
@ -169,10 +147,9 @@ userBalanceSelect conn uid = do
|
|||
insertUser
|
||||
:: UserSubmit
|
||||
-> Day
|
||||
-> ByteString
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
insertUser us now conn = fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = userTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
@ -182,12 +159,9 @@ insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
|
|||
, C.constant now
|
||||
, C.constant (userSubmitEmail us)
|
||||
, C.constant (Nothing :: Maybe Int)
|
||||
, C.constant randSalt
|
||||
, C.constant (Nothing :: Maybe ByteString)
|
||||
, C.constant (Nothing :: Maybe Int)
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(uid, _, _, _, _, _, _, _, _) -> uid)
|
||||
, iReturning = rReturning (\(uid, _, _, _, _, _) -> uid)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
|
@ -199,19 +173,16 @@ updateUserDetails
|
|||
-> MateHandler Int64
|
||||
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
|
||||
{ uTable = userTable
|
||||
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, _, _) ->
|
||||
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
|
||||
( id_
|
||||
, C.constant (userDetailsSubmitIdent uds)
|
||||
, i3
|
||||
, C.constant now
|
||||
, C.constant (userDetailsSubmitEmail uds)
|
||||
, C.constant (userDetailsSubmitAvatar uds)
|
||||
, i7
|
||||
, C.constant ((\(AuthHash h) -> h) <$> userDetailsSubmitHash uds)
|
||||
, C.constant (fromEnum <$> userDetailsSubmitAlgo uds)
|
||||
)
|
||||
)
|
||||
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
|
||||
, uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid)
|
||||
, uReturning = rCount
|
||||
}
|
||||
|
||||
|
|
@ -222,18 +193,15 @@ addToUserBalance
|
|||
-> MateHandler Int64
|
||||
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
|
||||
{ uTable = userTable
|
||||
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) ->
|
||||
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
|
||||
( id_
|
||||
, i2
|
||||
, i3 + C.constant amount
|
||||
, i4
|
||||
, i5
|
||||
, i6
|
||||
, i7
|
||||
, i8
|
||||
, i9
|
||||
)
|
||||
)
|
||||
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
|
||||
, uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid)
|
||||
, uReturning = rCount
|
||||
}
|
||||
|
|
|
|||
|
|
@ -7,22 +7,30 @@ import GHC.Generics
|
|||
|
||||
import Data.Aeson
|
||||
|
||||
import Data.ByteString
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Data.Time.Clock (UTCTime)
|
||||
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Control.Concurrent.STM.TVar (TVar)
|
||||
|
||||
-- internal imports
|
||||
|
||||
data TicketRequest = TicketRequest
|
||||
{ ticketRequestUser :: Int
|
||||
, ticketRequestMethod :: AuthMethod
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON TicketRequest where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON TicketRequest
|
||||
|
||||
|
||||
data AuthInfo = AuthInfo
|
||||
{ authSalt :: AuthSalt
|
||||
, authAlgorithm :: AuthAlgorithm
|
||||
{ authChallenge :: Maybe T.Text
|
||||
, authTicket :: AuthTicket
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
|
@ -33,59 +41,37 @@ instance ToJSON AuthInfo where
|
|||
instance FromJSON AuthInfo
|
||||
|
||||
|
||||
data AuthAlgorithm
|
||||
= SHA3_512
|
||||
deriving (Show, Read, Generic, Enum)
|
||||
data AuthMethod
|
||||
= PrimaryPass
|
||||
| SecondaryPass
|
||||
| ChallengeResponse
|
||||
deriving (Show, Generic, Enum, Eq, Ord)
|
||||
|
||||
instance ToJSON AuthAlgorithm where
|
||||
toJSON = toJSON . show
|
||||
instance ToJSON AuthMethod where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthAlgorithm where
|
||||
parseJSON j = read <$> parseJSON j
|
||||
instance FromJSON AuthMethod
|
||||
|
||||
|
||||
newtype AuthTicket = AuthTicket ByteString deriving (Show, Eq, Ord)
|
||||
newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
|
||||
|
||||
instance ToJSON AuthTicket where
|
||||
toJSON (AuthTicket bs) = (String . decodeUtf8 . B16.encode) bs
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthTicket where
|
||||
parseJSON = withText ""
|
||||
(\t -> do
|
||||
let enc = fst $ B16.decode $ encodeUtf8 t
|
||||
return (AuthTicket enc)
|
||||
)
|
||||
instance FromJSON AuthTicket
|
||||
|
||||
|
||||
newtype AuthSalt = AuthSalt ByteString deriving (Show)
|
||||
newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthSalt where
|
||||
toJSON (AuthSalt bs) = (String . decodeUtf8 . B16.encode) bs
|
||||
instance ToJSON AuthResponse where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthSalt where
|
||||
parseJSON = withText ""
|
||||
(\t -> do
|
||||
let enc = fst $ B16.decode $ encodeUtf8 t
|
||||
return (AuthSalt enc)
|
||||
)
|
||||
|
||||
|
||||
newtype AuthHash = AuthHash ByteString deriving (Show)
|
||||
|
||||
instance ToJSON AuthHash where
|
||||
toJSON (AuthHash bs) = (String . decodeUtf8 . B16.encode) bs
|
||||
|
||||
instance FromJSON AuthHash where
|
||||
parseJSON = withText ""
|
||||
(\t -> do
|
||||
let enc = fst $ B16.decode $ encodeUtf8 t
|
||||
return (AuthHash enc)
|
||||
)
|
||||
instance FromJSON AuthResponse
|
||||
|
||||
|
||||
data AuthRequest = AuthRequest
|
||||
{ authRequestTicket :: AuthTicket
|
||||
, authRequestHash :: AuthHash
|
||||
, authRequestHash :: AuthResponse
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
|
@ -108,29 +94,22 @@ instance ToJSON AuthResult where
|
|||
instance FromJSON AuthResult
|
||||
|
||||
|
||||
newtype AuthToken = AuthToken ByteString deriving (Show)
|
||||
newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthToken where
|
||||
toJSON (AuthToken bs) = (String . decodeUtf8 . B16.encode) bs
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthToken where
|
||||
parseJSON = withText ""
|
||||
(\t -> do
|
||||
let enc = fst $ B16.decode $ encodeUtf8 t
|
||||
return (AuthToken enc)
|
||||
)
|
||||
instance FromJSON AuthToken
|
||||
|
||||
|
||||
data Token = Token
|
||||
{ tokenString :: ByteString
|
||||
{ tokenString :: T.Text
|
||||
, tokenUser :: Int
|
||||
, tokenExpiry :: UTCTime
|
||||
, tokenMethod :: AuthMethod
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance ToJSON Token where
|
||||
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
|
||||
|
||||
|
||||
type TicketStore = TVar (S.Set Ticket)
|
||||
|
||||
|
|
@ -139,8 +118,18 @@ data Ticket = Ticket
|
|||
{ ticketId :: AuthTicket
|
||||
, ticketUser :: Int
|
||||
, ticketExpiry :: UTCTime
|
||||
, ticketMethod :: AuthMethod
|
||||
}
|
||||
deriving (Ord)
|
||||
deriving (Show, Ord)
|
||||
|
||||
instance Eq Ticket where
|
||||
(Ticket i1 _ _) == (Ticket i2 _ _) = i1 == i2
|
||||
(Ticket i1 _ _ _) == (Ticket i2 _ _ _) = i1 == i2
|
||||
|
||||
|
||||
data AuthData = AuthData
|
||||
{ authDataId :: Int
|
||||
, authDataUser :: Int
|
||||
, authDataMethod :: AuthMethod
|
||||
, authDataPayload :: Maybe T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
|
|
|||
|
|
@ -12,8 +12,6 @@ import qualified Data.Text as T
|
|||
|
||||
-- internal imports
|
||||
|
||||
import Types.Auth
|
||||
|
||||
data User
|
||||
= User
|
||||
{ userId :: Int
|
||||
|
|
@ -22,22 +20,12 @@ data User
|
|||
, userTimeStamp :: Day
|
||||
, userEmail :: Maybe T.Text
|
||||
, userAvatar :: Maybe Int
|
||||
, userSalt :: AuthSalt
|
||||
, userHash :: Maybe AuthHash
|
||||
, userAlgo :: Maybe Int
|
||||
-- , userSalt :: AuthSalt
|
||||
-- , userHash :: Maybe AuthHash
|
||||
-- , userAlgo :: Maybe Int
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance ToJSON User where
|
||||
toEncoding (User uid ident _ _ _ avatar _ _ _) =
|
||||
pairs
|
||||
( "userId" .= uid
|
||||
<> "userIdent" .= ident
|
||||
<> "userAvatar" .= avatar
|
||||
)
|
||||
|
||||
instance FromJSON User
|
||||
|
||||
|
||||
data UserSummary = UserSummary
|
||||
{ userSummaryId :: Int
|
||||
|
|
@ -71,8 +59,8 @@ data UserDetails = UserDetails
|
|||
, userDetailsBalance :: Int
|
||||
, userDetailsEmail :: Maybe T.Text
|
||||
, userDetailsAvatar :: Maybe Int
|
||||
, userDetailsSalt :: AuthSalt
|
||||
, userDetailsAlgo :: Maybe AuthAlgorithm
|
||||
-- , userDetailsSalt :: AuthSalt
|
||||
-- , userDetailsAlgo :: Maybe AuthAlgorithm
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
|
@ -86,8 +74,8 @@ data UserDetailsSubmit = UserDetailsSubmit
|
|||
{ userDetailsSubmitIdent :: T.Text
|
||||
, userDetailsSubmitEmail :: Maybe T.Text
|
||||
, userDetailsSubmitAvatar :: Maybe Int
|
||||
, userDetailsSubmitHash :: Maybe AuthHash
|
||||
, userDetailsSubmitAlgo :: Maybe AuthAlgorithm
|
||||
-- , userDetailsSubmitHash :: Maybe AuthHash
|
||||
-- , userDetailsSubmitAlgo :: Maybe AuthAlgorithm
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue