Check token at auth

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 $
+app initState =
-  hoistServerWithContext
+  serveWithContext userApi (genAuthServerContext (rsConnection initState)) $
-    userApi
+    hoistServerWithContext
-    authProxy
+      userApi
-    (`runReaderT` initState)
+      authProxy
-    users
+      (`runReaderT` initState)
-  -- hoistServerWithContext
+      ( users :<|>
-  --   userApi
+        auth
-  --   genAuthServerContext
+      )
-  --   (`runReaderT` initState)
-  --   users
 
 userApi :: Proxy UserAPI
 userApi = Proxy
 
-authProxy :: Proxy '[ AuthHandler Request Bool ]
+authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
 authProxy = Proxy
 
-genAuthServerContext :: Context '[ AuthHandler Request Bool ]
+genAuthServerContext
-genAuthServerContext = authHandler Servant.:. EmptyContext
+  :: 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 :: Connection -> AuthHandler Request (Maybe Int)
-authHandler = mkAuthHandler handler
+authHandler conn = mkAuthHandler handler
   where
+    handler :: Request -> Handler (Maybe Int)
     handler req = do
       let headers = requestHeaders req
-          res = case lookup "Authorization" headers of
+      res <- case lookup "Authorization" headers of
-            Just _ -> True
+        Just hh -> do
-            _      -> False
+          validateToken conn hh
+        _       ->
+          return Nothing
       return res
 
-users :: ServerT UserAPI (ReaderT ReadState Handler)
 users =
-  ( userList :<|>
+  userList :<|>
-    userNew :<|>
+  userNew :<|>
-    userUpdate
+  userUpdate
-  ) :<|>
-  ( authGet :<|>
-    authSend
-  )
   where
-    userList :: Maybe Refine -> Bool -> MateHandler [User]
+    userList :: Maybe Refine -> Maybe Int -> MateHandler [User]
-    userList ref sw = do
+    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

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

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
+      User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
-      then User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
-      else QueryUser i1 i2 i6
       )
     users
 

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

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