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 conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $
hoistServer userApi (`runReaderT` initState) users
app initState = serve userApi $
hoistServerWithContext
userApi
authProxy
-- genAuthServerContext
(`runReaderT` initState)
users
-- hoistServerWithContext
-- userApi
-- genAuthServerContext
-- (`runReaderT` initState)
-- users
userApi :: Proxy UserAPI
userApi = Proxy
authProxy :: Proxy (Context (AuthHandler Request Bool ': '[]))
authProxy = Proxy
genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
genAuthServerContext = authHandler Servant.:. EmptyContext
@ -86,22 +99,22 @@ users =
)
where
userList :: Maybe Refine -> Bool -> MateHandler [User]
userList ref sw = liftIO $ do
userList ref sw = do
conn <- rsConnection <$> ask
userSelect conn ref sw
userNew :: UserSubmit -> MateHandler Int
userNew us = liftIO $ do
now <- getCurrentTime
randSalt <- random 8
userNew us = do
now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8
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 (id, us) = liftIO $ do
now <- getCurrentTime
userUpdate (id, us) = do
now <- liftIO $ getCurrentTime
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 id =

View file

@ -6,6 +6,8 @@ import GHC.Generics
import Control.Arrow ((<<<))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
@ -59,14 +61,13 @@ tokenTable = table "token" (
)
getUserAuthInfo
:: PGS.Connection
-> Int
:: Int
-> MateHandler AuthInfo
getUserAuthInfo id = do
getUserAuthInfo ident = do
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable
uid .== C.constant ident) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
@ -80,19 +81,19 @@ getUserAuthInfo id = do
)
]
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
checkTicket
generateToken
:: Ticket
-> AuthHash
-> MateHandler Token
generateToken (Ticket _ id exp) hash = do
-> MateHandler AuthResult
generateToken (Ticket _ ident exp) (AuthHash hash) = do
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.cinstant id) <<< queryTable userTable
uid .== C.constant ident) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
@ -105,16 +106,42 @@ generateToken (Ticket _ id exp) hash = do
, 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 id = do
newTicket ident = do
store <- rsTicketStore <$> ask
rand <- liftIO $ random 23
later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
let ticket = Ticket
{ ticketId = AuthTicket rand
, ticketUser = id
, ticketUser = ident
, ticketExpiry = later
}
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
@ -124,8 +151,8 @@ processAuthRequest
:: AuthRequest
-> MateHandler AuthResult
processAuthRequest (AuthRequest aticket hash) = do
store <- (liftIO . readTVarIO) <$> rsTicketStore <$> ask
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
let mticket = S.filter (\st -> ticketId st == aticket) store
case toList mticket of
[ticket] -> checkTicket ticket hash
case S.toList mticket of
[ticket] -> generateToken ticket hash
_ -> return Denied

View file

@ -12,7 +12,6 @@ import Data.Profunctor.Product (p9)
import Data.Maybe (fromJust, isJust, fromMaybe)
import Data.ByteString hiding (head)
-- import Data.ByteString.Random
import Data.Int (Int64)
@ -22,6 +21,8 @@ import GHC.Generics
import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
import Opaleye as O
import qualified Opaleye.Constant as C
@ -30,6 +31,7 @@ import qualified Opaleye.Constant as C
import Types.User
import Types.Refine
import Types.Auth
import Types.Reader
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)"
@ -73,10 +75,10 @@ userSelect
:: PGS.Connection
-> Maybe Refine
-> Bool
-> IO [User]
-> MateHandler [User]
userSelect conn ref sw = do
today <- utctDay <$> getCurrentTime
users <- runSelect conn (case ref of
today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable
@ -84,7 +86,7 @@ userSelect conn ref sw = do
Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable
) :: IO
) :: MateHandler
[ ( Int
, Text
, Int
@ -131,7 +133,7 @@ updateUser id us now = Update
( id_
, C.constant (userSubmitIdent us)
, i3
, C.constant (now)
, C.constant now
, C.constant (userSubmitEmail us)
, i6
, i7

View file

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