diff --git a/src/Main.hs b/src/Main.hs index 712160e..94facab 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index c7975ee..8a480ff 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/User.hs b/src/Model/User.hs index f189b54..6a60cef 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 771471a..0df941e 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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 diff --git a/src/Types/User.hs b/src/Types/User.hs index b7a8773..45ba8ef 100644 --- a/src/Types/User.hs +++ b/src/Types/User.hs @@ -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