From 3b439b8d32b5935b03e931d4b6dc871164e62463 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 9 May 2019 16:53:19 +0200 Subject: [PATCH] bla --- src/Main.hs | 33 ++++++++++++++++++--------- src/Model/Auth.hs | 57 ++++++++++++++++++++++++++++++++++------------- src/Model/User.hs | 14 +++++++----- src/Types/Auth.hs | 2 +- 4 files changed, 74 insertions(+), 32 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 3224cc9..332efac 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 = diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index a7cdf16..5834617 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/User.hs b/src/Model/User.hs index 2e8b5e7..f189b54 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 7b3d25c..771471a 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -94,7 +94,7 @@ instance FromJSON AuthRequest data AuthResult = Granted - { authToken :: Token + { authToken :: AuthToken } | Denied deriving (Show, Generic)