Check token at auth

This commit is contained in:
nek0 2019-05-13 22:50:24 +02:00
parent 37c3fda960
commit 887a4cae9e
5 changed files with 72 additions and 48 deletions

View file

@ -2,6 +2,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Servant
@ -13,6 +14,8 @@ import Data.ByteString.Random
import Data.Set (empty)
import Data.Maybe (isJust)
import Database.PostgreSQL.Simple
import Network.Wai
@ -54,53 +57,51 @@ main = do
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $
hoistServerWithContext
userApi
authProxy
(`runReaderT` initState)
users
-- hoistServerWithContext
-- userApi
-- genAuthServerContext
-- (`runReaderT` initState)
-- users
app initState =
serveWithContext userApi (genAuthServerContext (rsConnection initState)) $
hoistServerWithContext
userApi
authProxy
(`runReaderT` initState)
( users :<|>
auth
)
userApi :: Proxy UserAPI
userApi = Proxy
authProxy :: Proxy '[ AuthHandler Request Bool ]
authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
authProxy = Proxy
genAuthServerContext :: Context '[ AuthHandler Request Bool ]
genAuthServerContext = authHandler Servant.:. EmptyContext
genAuthServerContext
:: Connection
-> Context '[ AuthHandler Request (Maybe Int) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
type instance AuthServerData (AuthProtect "header-auth") = Bool
type instance AuthServerData (AuthProtect "header-auth") = Maybe Int
authHandler :: AuthHandler Request Bool
authHandler = mkAuthHandler handler
authHandler :: Connection -> AuthHandler Request (Maybe Int)
authHandler conn = mkAuthHandler handler
where
handler :: Request -> Handler (Maybe Int)
handler req = do
let headers = requestHeaders req
res = case lookup "Authorization" headers of
Just _ -> True
_ -> False
res <- case lookup "Authorization" headers of
Just hh -> do
validateToken conn hh
_ ->
return Nothing
return res
users :: ServerT UserAPI (ReaderT ReadState Handler)
users =
( userList :<|>
userNew :<|>
userUpdate
) :<|>
( authGet :<|>
authSend
)
userList :<|>
userNew :<|>
userUpdate
where
userList :: Maybe Refine -> Bool -> MateHandler [User]
userList ref sw = do
userList :: Maybe Refine -> Maybe Int -> MateHandler [User]
userList ref muid = do
conn <- rsConnection <$> ask
userSelect conn ref sw
userSelect conn ref (isJust muid)
userNew :: UserSubmit -> MateHandler Int
userNew us = do
@ -115,6 +116,10 @@ users =
conn <- rsConnection <$> ask
void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
auth =
authGet :<|>
authSend
where
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id

View file

@ -2,6 +2,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Model.Auth where
import Servant (Handler)
import GHC.Generics
import Control.Arrow ((<<<))
@ -85,6 +87,29 @@ getUserAuthInfo ident = do
)
users
validateToken
:: PGS.Connection
-> ByteString
-> Handler (Maybe Int)
validateToken conn header = do
tokens <- liftIO $ runSelect conn (
keepWhen (\(tstr, _, _) ->
tstr .== C.constant header) <<< queryTable tokenTable
) :: Handler
[ ( ByteString
, Int
, UTCTime
)
]
case tokens of
[(_, uid, stamp)] -> do
now <- liftIO $ getCurrentTime
if diffUTCTime stamp now > 0
then return $ Just uid
else return $ Nothing
_ ->
return Nothing
generateToken
:: Ticket
-> AuthHash

View file

@ -100,9 +100,7 @@ userSelect conn ref sw = do
]
mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
if sw
then User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
else QueryUser i1 i2 i6
User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
)
users

View file

@ -35,6 +35,7 @@ instance ToJSON AuthInfo where
instance FromJSON AuthInfo
data AuthAlgorithm
= SHA3_512
deriving (Show, Read, Generic, Enum)
@ -45,6 +46,7 @@ instance ToJSON AuthAlgorithm where
instance FromJSON AuthAlgorithm where
parseJSON j = read <$> parseJSON j
newtype AuthTicket = AuthTicket ByteString deriving (Show, Eq, Ord)
instance ToJSON AuthTicket where
@ -57,6 +59,7 @@ instance FromJSON AuthTicket where
return (AuthTicket enc)
)
newtype AuthSalt = AuthSalt ByteString deriving (Show)
instance ToJSON AuthSalt where
@ -69,6 +72,7 @@ instance FromJSON AuthSalt where
return (AuthSalt enc)
)
newtype AuthHash = AuthHash ByteString deriving (Show)
instance ToJSON AuthHash where
@ -81,6 +85,7 @@ instance FromJSON AuthHash where
return (AuthHash enc)
)
data AuthRequest = AuthRequest
{ authRequestTicket :: AuthTicket
, authRequestHash :: AuthHash
@ -92,6 +97,7 @@ instance ToJSON AuthRequest where
instance FromJSON AuthRequest
data AuthResult
= Granted
{ authToken :: AuthToken
@ -102,6 +108,7 @@ data AuthResult
instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions
newtype AuthToken = AuthToken ByteString deriving (Show)
instance ToJSON AuthToken where
@ -114,6 +121,7 @@ instance FromJSON AuthToken where
return (AuthToken enc)
)
data Token = Token
{ tokenString :: ByteString
, tokenUser :: Int
@ -124,8 +132,10 @@ data Token = Token
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = TVar (S.Set Ticket)
data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int

View file

@ -26,24 +26,10 @@ data User
, userHash :: Maybe AuthHash
, userAlgo :: Maybe Int
}
| QueryUser
{ userId :: Int
, userIdent :: T.Text
, userAvatar :: Maybe Int
}
deriving (Generic, Show)
instance ToJSON User where
toEncoding (User id ident balance ts email avatar _ _ _) =
pairs
( "userId" .= id
<> "userIdent" .= ident
<> "userBalance" .= balance
<> "userTimeStamp" .= ts
<> "userEmail" .= email
<> "userAvatar" .= avatar
)
toEncoding (QueryUser id ident avatar) =
pairs
( "userId" .= id
<> "userIdent" .= ident