auth process seems to work
This commit is contained in:
parent
3b439b8d32
commit
312047b4a5
11
src/Main.hs
11
src/Main.hs
|
@ -54,11 +54,10 @@ main = do
|
||||||
|
|
||||||
app :: ReadState -> Application
|
app :: ReadState -> Application
|
||||||
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
|
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
|
||||||
app initState = serve userApi $
|
app initState = serveWithContext userApi genAuthServerContext $
|
||||||
hoistServerWithContext
|
hoistServerWithContext
|
||||||
userApi
|
userApi
|
||||||
authProxy
|
authProxy
|
||||||
-- genAuthServerContext
|
|
||||||
(`runReaderT` initState)
|
(`runReaderT` initState)
|
||||||
users
|
users
|
||||||
-- hoistServerWithContext
|
-- hoistServerWithContext
|
||||||
|
@ -70,10 +69,10 @@ app initState = serve userApi $
|
||||||
userApi :: Proxy UserAPI
|
userApi :: Proxy UserAPI
|
||||||
userApi = Proxy
|
userApi = Proxy
|
||||||
|
|
||||||
authProxy :: Proxy (Context (AuthHandler Request Bool ': '[]))
|
authProxy :: Proxy '[ AuthHandler Request Bool ]
|
||||||
authProxy = Proxy
|
authProxy = Proxy
|
||||||
|
|
||||||
genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
|
genAuthServerContext :: Context '[ AuthHandler Request Bool ]
|
||||||
genAuthServerContext = authHandler Servant.:. EmptyContext
|
genAuthServerContext = authHandler Servant.:. EmptyContext
|
||||||
|
|
||||||
type instance AuthServerData (AuthProtect "header-auth") = Bool
|
type instance AuthServerData (AuthProtect "header-auth") = Bool
|
||||||
|
@ -104,7 +103,7 @@ users =
|
||||||
userSelect conn ref sw
|
userSelect conn ref sw
|
||||||
|
|
||||||
userNew :: UserSubmit -> MateHandler Int
|
userNew :: UserSubmit -> MateHandler Int
|
||||||
userNew us = do
|
userNew us = do
|
||||||
now <- liftIO $ getCurrentTime
|
now <- liftIO $ getCurrentTime
|
||||||
randSalt <- liftIO $ random 8
|
randSalt <- liftIO $ random 8
|
||||||
conn <- rsConnection <$> ask
|
conn <- rsConnection <$> ask
|
||||||
|
@ -121,4 +120,4 @@ users =
|
||||||
getUserAuthInfo id
|
getUserAuthInfo id
|
||||||
|
|
||||||
authSend :: AuthRequest -> MateHandler AuthResult
|
authSend :: AuthRequest -> MateHandler AuthResult
|
||||||
authSend _ = liftIO $ Granted <$> AuthToken <$> random 8
|
authSend = processAuthRequest
|
||||||
|
|
|
@ -112,7 +112,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
|
||||||
token <- liftIO $ Token
|
token <- liftIO $ Token
|
||||||
<$> (random 23)
|
<$> (random 23)
|
||||||
<*> (pure ident)
|
<*> (pure ident)
|
||||||
<*> (addUTCTime 23 <$> getCurrentTime)
|
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
||||||
void $ liftIO $ runInsert_ conn (insertToken token)
|
void $ liftIO $ runInsert_ conn (insertToken token)
|
||||||
return $ Granted (AuthToken $ tokenString token)
|
return $ Granted (AuthToken $ tokenString token)
|
||||||
else
|
else
|
||||||
|
@ -138,7 +138,7 @@ newTicket :: Int -> MateHandler AuthTicket
|
||||||
newTicket ident = do
|
newTicket ident = do
|
||||||
store <- rsTicketStore <$> ask
|
store <- rsTicketStore <$> ask
|
||||||
rand <- liftIO $ random 23
|
rand <- liftIO $ random 23
|
||||||
later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
|
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
|
||||||
let ticket = Ticket
|
let ticket = Ticket
|
||||||
{ ticketId = AuthTicket rand
|
{ ticketId = AuthTicket rand
|
||||||
, ticketUser = ident
|
, ticketUser = ident
|
||||||
|
@ -154,5 +154,11 @@ processAuthRequest (AuthRequest aticket hash) = do
|
||||||
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
|
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
|
||||||
let mticket = S.filter (\st -> ticketId st == aticket) store
|
let mticket = S.filter (\st -> ticketId st == aticket) store
|
||||||
case S.toList mticket of
|
case S.toList mticket of
|
||||||
[ticket] -> generateToken ticket hash
|
[ticket] -> do
|
||||||
|
now <- liftIO $ getCurrentTime
|
||||||
|
if now > ticketExpiry ticket
|
||||||
|
then
|
||||||
|
return Denied
|
||||||
|
else
|
||||||
|
generateToken ticket hash
|
||||||
_ -> return Denied
|
_ -> return Denied
|
||||||
|
|
Loading…
Reference in a new issue