This commit is contained in:
nek0 2019-05-09 16:53:19 +02:00
parent 770c20dde0
commit 3b439b8d32
4 changed files with 74 additions and 32 deletions

View file

@ -54,12 +54,25 @@ main = do
app :: ReadState -> Application app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn) -- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $ app initState = serve userApi $
hoistServer userApi (`runReaderT` initState) users hoistServerWithContext
userApi
authProxy
-- genAuthServerContext
(`runReaderT` initState)
users
-- hoistServerWithContext
-- userApi
-- genAuthServerContext
-- (`runReaderT` initState)
-- users
userApi :: Proxy UserAPI userApi :: Proxy UserAPI
userApi = Proxy userApi = Proxy
authProxy :: Proxy (Context (AuthHandler Request Bool ': '[]))
authProxy = Proxy
genAuthServerContext :: Context (AuthHandler Request Bool ': '[]) genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
genAuthServerContext = authHandler Servant.:. EmptyContext genAuthServerContext = authHandler Servant.:. EmptyContext
@ -86,22 +99,22 @@ users =
) )
where where
userList :: Maybe Refine -> Bool -> MateHandler [User] userList :: Maybe Refine -> Bool -> MateHandler [User]
userList ref sw = liftIO $ do userList ref sw = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
userSelect conn ref sw userSelect conn ref sw
userNew :: UserSubmit -> MateHandler Int userNew :: UserSubmit -> MateHandler Int
userNew us = liftIO $ do userNew us = do
now <- getCurrentTime now <- liftIO $ getCurrentTime
randSalt <- random 8 randSalt <- liftIO $ random 8
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
head <$> runInsert_ conn (insertUser us (utctDay now) randSalt) head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt))
userUpdate :: (Int, UserSubmit) -> MateHandler () userUpdate :: (Int, UserSubmit) -> MateHandler ()
userUpdate (id, us) = liftIO $ do userUpdate (id, us) = do
now <- getCurrentTime now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
void $ runUpdate_ conn (updateUser id us (utctDay now)) void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
authGet :: Int -> MateHandler AuthInfo authGet :: Int -> MateHandler AuthInfo
authGet id = authGet id =

View file

@ -6,6 +6,8 @@ import GHC.Generics
import Control.Arrow ((<<<)) import Control.Arrow ((<<<))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
@ -59,14 +61,13 @@ tokenTable = table "token" (
) )
getUserAuthInfo getUserAuthInfo
:: PGS.Connection :: Int
-> Int
-> MateHandler AuthInfo -> MateHandler AuthInfo
getUserAuthInfo id = do getUserAuthInfo ident = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn ( users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) -> keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable uid .== C.constant ident) <<< queryTable userTable
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int
, Text , Text
@ -80,19 +81,19 @@ getUserAuthInfo id = do
) )
] ]
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) ->
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket id AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
) )
users users
checkTicket generateToken
:: Ticket :: Ticket
-> AuthHash -> AuthHash
-> MateHandler Token -> MateHandler AuthResult
generateToken (Ticket _ id exp) hash = do generateToken (Ticket _ ident exp) (AuthHash hash) = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn ( users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) -> keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.cinstant id) <<< queryTable userTable uid .== C.constant ident) <<< queryTable userTable
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int
, Text , Text
@ -105,16 +106,42 @@ generateToken (Ticket _ id exp) hash = do
, Maybe Int , Maybe Int
) )
] ]
let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8) let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8) users
if userHash == Nothing || userHash == Just hash
then do
token <- liftIO $ Token
<$> (random 23)
<*> (pure ident)
<*> (addUTCTime 23 <$> getCurrentTime)
void $ liftIO $ runInsert_ conn (insertToken token)
return $ Granted (AuthToken $ tokenString token)
else
return Denied
insertToken
:: Token
-> Insert [ByteString]
insertToken (Token tString tUser tExpiry) = Insert
{ iTable = tokenTable
, iRows =
[
( C.constant tString
, C.constant tUser
, C.constant tExpiry
)
]
, iReturning = rReturning (\(ident, _, _) -> ident)
, iOnConflict = Nothing
}
newTicket :: Int -> MateHandler AuthTicket newTicket :: Int -> MateHandler AuthTicket
newTicket id = 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/60) <$> getCurrentTime)
let ticket = Ticket let ticket = Ticket
{ ticketId = AuthTicket rand { ticketId = AuthTicket rand
, ticketUser = id , ticketUser = ident
, ticketExpiry = later , ticketExpiry = later
} }
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s) liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
@ -124,8 +151,8 @@ processAuthRequest
:: AuthRequest :: AuthRequest
-> MateHandler AuthResult -> MateHandler AuthResult
processAuthRequest (AuthRequest aticket hash) = do 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 toList mticket of case S.toList mticket of
[ticket] -> checkTicket ticket hash [ticket] -> generateToken ticket hash
_ -> return Denied _ -> return Denied

View file

@ -12,7 +12,6 @@ import Data.Profunctor.Product (p9)
import Data.Maybe (fromJust, isJust, fromMaybe) import Data.Maybe (fromJust, isJust, fromMaybe)
import Data.ByteString hiding (head) import Data.ByteString hiding (head)
-- import Data.ByteString.Random
import Data.Int (Int64) import Data.Int (Int64)
@ -22,6 +21,8 @@ import GHC.Generics
import Control.Arrow ((<<<)) import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
import Opaleye as O import Opaleye as O
import qualified Opaleye.Constant as C import qualified Opaleye.Constant as C
@ -30,6 +31,7 @@ import qualified Opaleye.Constant as C
import Types.User import Types.User
import Types.Refine import Types.Refine
import Types.Auth import Types.Auth
import Types.Reader
initUser :: PGS.Query initUser :: PGS.Query
initUser = "create table if not exists \"user\" (user_id serial primary key, user_ident varchar(128) not null, user_balance integer not null, user_timestamp date not null, user_email varchar(128), user_avatar integer, user_salt bytea not null, user_hash bytea, user_algo integer)" initUser = "create table if not exists \"user\" (user_id serial primary key, user_ident varchar(128) not null, user_balance integer not null, user_timestamp date not null, user_email varchar(128), user_avatar integer, user_salt bytea not null, user_hash bytea, user_algo integer)"
@ -73,10 +75,10 @@ userSelect
:: PGS.Connection :: PGS.Connection
-> Maybe Refine -> Maybe Refine
-> Bool -> Bool
-> IO [User] -> MateHandler [User]
userSelect conn ref sw = do userSelect conn ref sw = do
today <- utctDay <$> getCurrentTime today <- utctDay <$> (liftIO $ getCurrentTime)
users <- runSelect conn (case ref of users <- liftIO $ runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) -> Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .>= C.constant (addDays (-30) today) ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< queryTable userTable
@ -84,7 +86,7 @@ userSelect conn ref sw = do
Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) -> Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .<= C.constant (addDays (-30) today) ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< queryTable userTable
) :: IO ) :: MateHandler
[ ( Int [ ( Int
, Text , Text
, Int , Int
@ -131,7 +133,7 @@ updateUser id us now = Update
( id_ ( id_
, C.constant (userSubmitIdent us) , C.constant (userSubmitIdent us)
, i3 , i3
, C.constant (now) , C.constant now
, C.constant (userSubmitEmail us) , C.constant (userSubmitEmail us)
, i6 , i6
, i7 , i7

View file

@ -94,7 +94,7 @@ instance FromJSON AuthRequest
data AuthResult data AuthResult
= Granted = Granted
{ authToken :: Token { authToken :: AuthToken
} }
| Denied | Denied
deriving (Show, Generic) deriving (Show, Generic)