nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

starting serious auth implementation efforts

Browse source
This commit is contained in:
nek0 2019-09-14 23:03:04 +02:00
parent 9a22594351
commit 2c4f949102
8 changed files with 187 additions and 199 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/Main.hs
View file

@ -39,6 +39,7 @@ main = do
void $ execute_ conn initUser void $ execute_ conn initUser
void $ execute_ conn initProduct void $ execute_ conn initProduct
void $ execute_ conn initToken void $ execute_ conn initToken
void $ execute_ conn initAuthData
void $ execute_ conn initAmount void $ execute_ conn initAmount
void $ execute_ conn initJournal void $ execute_ conn initJournal
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
@ -105,7 +106,7 @@ authHandler conn = mkAuthHandler handler
let headers = requestHeaders req let headers = requestHeaders req
res <- case lookup "Authentication" headers of res <- case lookup "Authentication" headers of
Just hh -> Just hh ->
validateToken conn (fst $ decode hh) validateToken (fst $ decode hh) conn
_ -> _ ->
return Nothing return Nothing
return res return res

2
src/API.hs
View file

@ -18,7 +18,7 @@ import Servant.RawM
import Types import Types
type MateAPI = 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" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
:<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int :<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
:> Delete '[JSON] () :> Delete '[JSON] ()

11
src/Control/Auth.hs
View file

@ -8,9 +8,14 @@ import Servant
import Types import Types
import Model import Model
authGet :: Int -> MateHandler AuthInfo authGet :: TicketRequest -> MateHandler AuthInfo
authGet uid = authGet (TicketRequest uid method) = do
getUserAuthInfo uid 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 :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest authSend = processAuthRequest

5
src/Control/User.hs
View file

@ -11,8 +11,6 @@ import Control.Monad.IO.Class (liftIO)
import Data.Time (getCurrentTime, utctDay) import Data.Time (getCurrentTime, utctDay)
import Data.ByteString.Random (random)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text as T import qualified Data.Text as T
@ -25,9 +23,8 @@ import Model
userNew :: UserSubmit -> MateHandler Int userNew :: UserSubmit -> MateHandler Int
userNew us = do userNew us = do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
insertUser us (utctDay now) randSalt conn insertUser us (utctDay now) conn
userGet :: Maybe Int -> Int -> MateHandler UserDetails userGet :: Maybe Int -> Int -> MateHandler UserDetails
userGet Nothing _ = userGet Nothing _ =

160
src/Model/Auth.hs
View file

@ -17,13 +17,14 @@ import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.Profunctor.Product (p3) import Data.Profunctor.Product (p4)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import qualified Data.Text as T
import Data.Text.Encoding
import qualified Data.Set as S import qualified Data.Set as S
@ -49,86 +50,119 @@ import Model.User
initToken :: PGS.Query initToken :: PGS.Query
initToken = mconcat initToken = mconcat
[ "CREATE TABLE IF NOT EXISTS \"token\" (" [ "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_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 tokenTable :: Table
( Field SqlBytea ( Field SqlText
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4
) )
( Field SqlBytea ( Field SqlText
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4
) )
tokenTable = table "token" ( tokenTable = table "token" (
p3 p4
( tableField "token_string" ( tableField "token_string"
, tableField "token_user" , tableField "token_user"
, tableField "token_expiry" , 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 :: Int
delayTime = 1 * 10 ^ (6 :: Int) delayTime = 1 * 10 ^ (6 :: Int)
getUserAuthInfo getUserAuthInfo
:: Int :: Int
-> MateHandler AuthInfo -> AuthMethod
getUserAuthInfo ident = do -> MateHandler (Maybe AuthInfo)
getUserAuthInfo uid method = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
users <- liftIO $ do authdata <- liftIO $ do
void $ threadDelay delayTime void $ threadDelay delayTime
runSelect conn ( runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) -> keepWhen (\(_, duid, dmethod, _) ->
uid .== C.constant ident) <<< queryTable userTable duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
<<< queryTable authDataTable
) :: IO ) :: IO
[ ( Int [ ( Int
, Text
, Int , Int
, Day , Int
, Maybe Text , Maybe T.Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
) )
] ]
if null users if null authdata
then throwError $ err404 then
{ errBody = "No such user" return Nothing
}
else else
head <$> mapM (\(_, _, _, _, _, _, i7, _, i9) -> Just <$> head <$> mapM (\(_, _, _, payload) ->
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident AuthInfo payload <$> newTicket uid method
) )
users authdata
validateToken validateToken
:: PGS.Connection :: ByteString
-> ByteString -> PGS.Connection
-> Handler (Maybe Int) -> Handler (Maybe Int)
validateToken conn header = do validateToken header conn = do
tokens <- liftIO $ runSelect conn ( tokens <- liftIO $ runSelect conn (
keepWhen (\(tstr, _, _) -> keepWhen (\(tstr, _, _, _) ->
tstr .== C.constant header) <<< queryTable tokenTable tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable
) :: Handler ) :: Handler
[ ( ByteString [ ( T.Text
, Int , Int
, UTCTime , UTCTime
, Int
) )
] ]
case tokens of case tokens of
[(_, uid, stamp)] -> do [(_, uid, stamp, method)] -> do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
if diffUTCTime stamp now > 0 if diffUTCTime stamp now > 0
then return $ Just uid then return $ Just uid
else do else do
void $ deleteToken header conn void $ deleteToken (decodeUtf8 header) conn
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
throwError $ err401 throwError $ err401
{ errBody = "Your token expired!" { errBody = "Your token expired!"
@ -142,32 +176,28 @@ validateToken conn header = do
generateToken generateToken
:: Ticket :: Ticket
-> AuthHash -> AuthResponse
-> MateHandler AuthResult -> MateHandler AuthResult
generateToken (Ticket _ ident _) (AuthHash hash) = do generateToken (Ticket _ tuid _ method) (AuthResponse hash) = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn ( authData <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) -> keepWhen (\(_, auid, _, _) ->
uid .== C.constant ident) <<< queryTable userTable auid .== C.constant tuid) <<< queryTable authDataTable
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int
, Text
, Int , Int
, Day , Int
, Maybe Text , Maybe T.Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
) )
] ]
let userHash = head $ map (\(_, _, _, _, _, _, _, i8, _) -> i8) users let userHash = head $ map (\(_, _, _, payload) -> payload) authData
if userHash == Nothing || userHash == Just hash if userHash == Nothing || userHash == Just hash
then do then do
token <- liftIO $ Token token <- liftIO $ Token
<$> (random 23) <$> (decodeUtf8 <$> random 23)
<*> (pure ident) <*> pure tuid
<*> (addUTCTime (23*60) <$> getCurrentTime) <*> (addUTCTime (23*60) <$> getCurrentTime)
<*> pure method
void $ insertToken token conn void $ insertToken token conn
return $ Granted (AuthToken $ tokenString token) return $ Granted (AuthToken $ tokenString token)
else else
@ -177,8 +207,8 @@ generateToken (Ticket _ ident _) (AuthHash hash) = do
insertToken insertToken
:: Token :: Token
-> PGS.Connection -> PGS.Connection
-> MateHandler ByteString -> MateHandler T.Text
insertToken (Token tString tUser tExpiry) conn = insertToken (Token tString tUser tExpiry tMethod) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable { iTable = tokenTable
, iRows = , iRows =
@ -186,21 +216,22 @@ insertToken (Token tString tUser tExpiry) conn =
( C.constant tString ( C.constant tString
, C.constant tUser , C.constant tUser
, C.constant tExpiry , C.constant tExpiry
, C.constant (fromEnum tMethod)
) )
] ]
, iReturning = rReturning (\(ident, _, _) -> ident) , iReturning = rReturning (\(ident, _, _, _) -> ident)
, iOnConflict = Nothing , iOnConflict = Nothing
} }
deleteToken deleteToken
:: ByteString :: T.Text
-> PGS.Connection -> PGS.Connection
-> Handler Int64 -> Handler Int64
deleteToken tstr conn = deleteToken tstr conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr) , dWhere = (\(rtstr, _, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount , dReturning = rCount
} }
@ -211,20 +242,21 @@ deleteTokenByUserId
-> MateHandler Int64 -> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = (\(_, rid, _) -> rid .== C.constant uid) , dWhere = (\(_, rid, _, _) -> rid .== C.constant uid)
, dReturning = rCount , dReturning = rCount
} }
newTicket :: Int -> MateHandler AuthTicket newTicket :: Int -> AuthMethod -> MateHandler AuthTicket
newTicket ident = do newTicket ident method = do
store <- rsTicketStore <$> ask store <- rsTicketStore <$> ask
rand <- liftIO $ random 23 rand <- liftIO $ (decodeUtf8 <$> random 23)
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime) later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket let ticket = Ticket
{ ticketId = AuthTicket rand { ticketId = AuthTicket rand
, ticketUser = ident , ticketUser = ident
, ticketExpiry = later , ticketExpiry = later
, ticketMethod = method
} }
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s) liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
return (AuthTicket rand) return (AuthTicket rand)
@ -244,7 +276,11 @@ processAuthRequest (AuthRequest aticket hash) = do
then then
#if defined(DEVELOP) #if defined(DEVELOP)
do do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime mockticket <- Ticket <$>
pure aticket <*>
pure 1 <*>
liftIO getCurrentTime <*>
pure PrimaryPass
generateToken mockticket hash generateToken mockticket hash
#else #else
return Denied return Denied
@ -255,7 +291,11 @@ processAuthRequest (AuthRequest aticket hash) = do
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
#if defined(DEVELOP) #if defined(DEVELOP)
do do
mockticket <- Ticket <$> pure aticket <*> pure 1 <*> liftIO getCurrentTime mockticket <- Ticket <$>
pure aticket <*>
pure 1 <*>
liftIO getCurrentTime <*>
pure PrimaryPass
generateToken mockticket hash generateToken mockticket hash
#else #else
return Denied return Denied

66
src/Model/User.hs
View file

@ -5,7 +5,7 @@ import Data.Text as T hiding (head, foldl)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Profunctor.Product (p9) import Data.Profunctor.Product (p6)
import Data.ByteString hiding (head, foldl) import Data.ByteString hiding (head, foldl)
@ -35,10 +35,7 @@ initUser = mconcat
, "user_balance INTEGER NOT NULL," , "user_balance INTEGER NOT NULL,"
, "user_timestamp DATE NOT NULL," , "user_timestamp DATE NOT NULL,"
, "user_email TEXT," , "user_email TEXT,"
, "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE," , "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE"
, "user_salt BYTEA NOT NULL,"
, "user_hash BYTEA,"
, "user_algo INTEGER"
, ")" , ")"
] ]
@ -49,9 +46,6 @@ userTable :: Table
, Field SqlDate , Field SqlDate
, FieldNullable SqlText , FieldNullable SqlText
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
) )
( Field SqlInt4 ( Field SqlInt4
, Field SqlText , Field SqlText
@ -59,21 +53,15 @@ userTable :: Table
, Field SqlDate , Field SqlDate
, FieldNullable SqlText , FieldNullable SqlText
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
) )
userTable = table "user" ( userTable = table "user" (
p9 p6
( tableField "user_id" ( tableField "user_id"
, tableField "user_ident" , tableField "user_ident"
, tableField "user_balance" , tableField "user_balance"
, tableField "user_timestamp" , tableField "user_timestamp"
, tableField "user_email" , tableField "user_email"
, tableField "user_avatar" , tableField "user_avatar"
, tableField "user_salt"
, tableField "user_hash"
, tableField "user_algo"
) )
) )
@ -85,10 +73,10 @@ userSelect ref conn = do
today <- utctDay <$> (liftIO $ getCurrentTime) today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (case ref of users <- liftIO $ runSelect conn (case ref of
AllUsers -> selectTable userTable AllUsers -> selectTable userTable
ActiveUsers -> keepWhen (\(_, _, _, ts, _, _, _, _, _) -> ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
ts .>= C.constant (addDays (-30) today) ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< queryTable userTable
OldUsers -> keepWhen (\(_, _, _, ts, _, _, _, _, _) -> OldUsers -> keepWhen (\(_, _, _, ts, _, _) ->
ts .<= C.constant (addDays (-30) today) ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< queryTable userTable
) :: MateHandler ) :: MateHandler
@ -98,14 +86,10 @@ userSelect ref conn = do
, Day , Day
, Maybe Text , Maybe Text
, Maybe Int , Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
) )
] ]
mapM mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $ (\(i1, i2, i3, i4, i5, i6) -> return $
-- User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
UserSummary i1 i2 i6 UserSummary i1 i2 i6
) )
users users
@ -116,7 +100,7 @@ userDetailsSelect
-> MateHandler UserDetails -> MateHandler UserDetails
userDetailsSelect uid conn = do userDetailsSelect uid conn = do
users <- liftIO $ runSelect conn ( users <- liftIO $ runSelect conn (
keepWhen (\(uuid, _, _, _, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== C.constant uid
) <<< queryTable userTable ) <<< queryTable userTable
) :: MateHandler ) :: MateHandler
@ -126,14 +110,11 @@ userDetailsSelect uid conn = do
, Day , Day
, Maybe Text , Maybe Text
, Maybe Int , Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
) )
] ]
head <$> mapM head <$> mapM
(\(i1, i2, i3, _, i5, i6, i7, _, i9) -> return $ (\(i1, i2, i3, _, i5, i6) -> return $
UserDetails i1 i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9) UserDetails i1 i2 i3 i5 i6
) )
users users
@ -144,7 +125,7 @@ userBalanceSelect
-> MateHandler Int -> MateHandler Int
userBalanceSelect conn uid = do userBalanceSelect conn uid = do
users <- liftIO $ runSelect conn ( users <- liftIO $ runSelect conn (
keepWhen (\(uuid, _, _, _, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== C.constant uid
) <<< queryTable userTable ) <<< queryTable userTable
) :: MateHandler ) :: MateHandler
@ -154,13 +135,10 @@ userBalanceSelect conn uid = do
, Day , Day
, Maybe Text , Maybe Text
, Maybe Int , Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
) )
] ]
head <$> mapM head <$> mapM
(\(_, _, i3, _, _, _, _, _, _) -> return $ (\(_, _, i3, _, _, _) -> return $
i3 i3
) )
users users
@ -169,10 +147,9 @@ userBalanceSelect conn uid = do
insertUser insertUser
:: UserSubmit :: UserSubmit
-> Day -> Day
-> ByteString
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> 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 { iTable = userTable
, iRows = , iRows =
[ [
@ -182,12 +159,9 @@ insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
, C.constant now , C.constant now
, C.constant (userSubmitEmail us) , C.constant (userSubmitEmail us)
, C.constant (Nothing :: Maybe Int) , 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 , iOnConflict = Nothing
} }
@ -199,19 +173,16 @@ updateUserDetails
-> MateHandler Int64 -> MateHandler Int64
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, _, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
( id_ ( id_
, C.constant (userDetailsSubmitIdent uds) , C.constant (userDetailsSubmitIdent uds)
, i3 , i3
, C.constant now , C.constant now
, C.constant (userDetailsSubmitEmail uds) , C.constant (userDetailsSubmitEmail uds)
, C.constant (userDetailsSubmitAvatar 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 , uReturning = rCount
} }
@ -222,18 +193,15 @@ addToUserBalance
-> MateHandler Int64 -> MateHandler Int64
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) -> , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
( id_ ( id_
, i2 , i2
, i3 + C.constant amount , i3 + C.constant amount
, i4 , i4
, i5 , i5
, i6 , i6
, i7
, i8
, i9
) )
) )
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid) , uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid)
, uReturning = rCount , uReturning = rCount
} }

105
src/Types/Auth.hs
View file

@ -7,22 +7,30 @@ import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.ByteString
import qualified Data.ByteString.Base16 as B16
import qualified Data.Set as S import qualified Data.Set as S
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Text as T
import Control.Concurrent.STM.TVar (TVar) import Control.Concurrent.STM.TVar (TVar)
-- internal imports -- 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 data AuthInfo = AuthInfo
{ authSalt :: AuthSalt { authChallenge :: Maybe T.Text
, authAlgorithm :: AuthAlgorithm
, authTicket :: AuthTicket , authTicket :: AuthTicket
} }
deriving (Show, Generic) deriving (Show, Generic)
@ -33,59 +41,37 @@ instance ToJSON AuthInfo where
instance FromJSON AuthInfo instance FromJSON AuthInfo
data AuthAlgorithm data AuthMethod
= SHA3_512 = PrimaryPass
deriving (Show, Read, Generic, Enum) | SecondaryPass
| ChallengeResponse
deriving (Show, Generic, Enum, Eq, Ord)
instance ToJSON AuthAlgorithm where instance ToJSON AuthMethod where
toJSON = toJSON . show toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthAlgorithm where instance FromJSON AuthMethod
parseJSON j = read <$> parseJSON j
newtype AuthTicket = AuthTicket ByteString deriving (Show, Eq, Ord) newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
instance ToJSON AuthTicket where instance ToJSON AuthTicket where
toJSON (AuthTicket bs) = (String . decodeUtf8 . B16.encode) bs toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthTicket where instance FromJSON AuthTicket
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthTicket enc)
)
newtype AuthSalt = AuthSalt ByteString deriving (Show) newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic)
instance ToJSON AuthSalt where instance ToJSON AuthResponse where
toJSON (AuthSalt bs) = (String . decodeUtf8 . B16.encode) bs toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthSalt where instance FromJSON AuthResponse
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)
)
data AuthRequest = AuthRequest data AuthRequest = AuthRequest
{ authRequestTicket :: AuthTicket { authRequestTicket :: AuthTicket
, authRequestHash :: AuthHash , authRequestHash :: AuthResponse
} }
deriving (Show, Generic) deriving (Show, Generic)
@ -108,29 +94,22 @@ instance ToJSON AuthResult where
instance FromJSON AuthResult instance FromJSON AuthResult
newtype AuthToken = AuthToken ByteString deriving (Show) newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
instance ToJSON AuthToken where instance ToJSON AuthToken where
toJSON (AuthToken bs) = (String . decodeUtf8 . B16.encode) bs toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthToken where instance FromJSON AuthToken
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthToken enc)
)
data Token = Token data Token = Token
{ tokenString :: ByteString { tokenString :: T.Text
, tokenUser :: Int , tokenUser :: Int
, tokenExpiry :: UTCTime , tokenExpiry :: UTCTime
, tokenMethod :: AuthMethod
} }
deriving (Generic, Show) deriving (Generic, Show)
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = TVar (S.Set Ticket) type TicketStore = TVar (S.Set Ticket)
@ -139,8 +118,18 @@ data Ticket = Ticket
{ ticketId :: AuthTicket { ticketId :: AuthTicket
, ticketUser :: Int , ticketUser :: Int
, ticketExpiry :: UTCTime , ticketExpiry :: UTCTime
, ticketMethod :: AuthMethod
} }
deriving (Ord) deriving (Show, Ord)
instance Eq Ticket where 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)

26
src/Types/User.hs
View file

@ -12,8 +12,6 @@ import qualified Data.Text as T
-- internal imports -- internal imports
import Types.Auth
data User data User
= User = User
{ userId :: Int { userId :: Int
@ -22,22 +20,12 @@ data User
, userTimeStamp :: Day , userTimeStamp :: Day
, userEmail :: Maybe T.Text , userEmail :: Maybe T.Text
, userAvatar :: Maybe Int , userAvatar :: Maybe Int
, userSalt :: AuthSalt -- , userSalt :: AuthSalt
, userHash :: Maybe AuthHash -- , userHash :: Maybe AuthHash
, userAlgo :: Maybe Int -- , userAlgo :: Maybe Int
} }
deriving (Generic, Show) 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 data UserSummary = UserSummary
{ userSummaryId :: Int { userSummaryId :: Int
@ -71,8 +59,8 @@ data UserDetails = UserDetails
, userDetailsBalance :: Int , userDetailsBalance :: Int
, userDetailsEmail :: Maybe T.Text , userDetailsEmail :: Maybe T.Text
, userDetailsAvatar :: Maybe Int , userDetailsAvatar :: Maybe Int
, userDetailsSalt :: AuthSalt -- , userDetailsSalt :: AuthSalt
, userDetailsAlgo :: Maybe AuthAlgorithm -- , userDetailsAlgo :: Maybe AuthAlgorithm
} }
deriving (Generic, Show) deriving (Generic, Show)
@ -86,8 +74,8 @@ data UserDetailsSubmit = UserDetailsSubmit
{ userDetailsSubmitIdent :: T.Text { userDetailsSubmitIdent :: T.Text
, userDetailsSubmitEmail :: Maybe T.Text , userDetailsSubmitEmail :: Maybe T.Text
, userDetailsSubmitAvatar :: Maybe Int , userDetailsSubmitAvatar :: Maybe Int
, userDetailsSubmitHash :: Maybe AuthHash -- , userDetailsSubmitHash :: Maybe AuthHash
, userDetailsSubmitAlgo :: Maybe AuthAlgorithm -- , userDetailsSubmitAlgo :: Maybe AuthAlgorithm
} }
deriving (Generic, Show) deriving (Generic, Show)