change auth response type

app/Main.hs

@@ -88,20 +88,20 @@ app initState =
 mateApi :: Proxy MateAPI
 mateApi = Proxy
 
-authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
+authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
 authProxy = Proxy
 
 genAuthServerContext
   :: Connection
-  -> Context '[ AuthHandler Request (Maybe Int) ]
+  -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
 genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
 
-type instance AuthServerData (AuthProtect "header-auth") = Maybe Int
+type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
 
-authHandler :: Connection -> AuthHandler Request (Maybe Int)
+authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
 authHandler conn = mkAuthHandler handler
   where
-    handler :: Request -> Handler (Maybe Int)
+    handler :: Request -> Handler (Maybe (Int, AuthMethod))
     handler req = do
       let headers = requestHeaders req
       res <- case lookup "Authentication" headers of

src/API.hs

@@ -20,8 +20,7 @@ import Types
 type MateAPI =
   "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
   :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
-  :<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
-    :> Delete '[JSON] ()
+  :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] ()
 
   :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
   :<|> "user" :> AuthProtect "header-auth"

src/Control/Auth.hs

@@ -3,28 +3,36 @@ module Control.Auth where
 
 import Servant
 
+import Control.Monad.Reader (ask)
+import Control.Monad.IO.Class (liftIO)
+
+import Control.Concurrent.STM (readTVarIO)
+
 -- internal imports
 
 import Types
 import Model
 
-authGet :: TicketRequest -> MateHandler AuthInfo
+authGet
+  :: TicketRequest
+  -> MateHandler AuthInfo
 authGet (TicketRequest uid method) = do
-  getUserAuthInfo uid method
+  getUserAuthInfo uid method =<< (rsConnection <$> ask)
 
-authSend :: AuthRequest -> MateHandler AuthResult
-authSend = processAuthRequest
+authSend
+  :: AuthRequest
+  -> MateHandler AuthResult
+authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
+  (liftIO . readTVarIO =<< rsTicketStore <$> ask) <*>
+  (rsConnection <$> ask)
+  )
 
-authLogout :: Maybe Int -> Int -> MateHandler ()
-authLogout (Just muid) luid = do
-  if muid == luid
-  then
-    processLogout luid
-  else
-    throwError $ err401
-      { errBody = "Unauthorized access"
-      }
-authLogout Nothing _ = do
+authLogout
+  :: Maybe (Int, AuthMethod)
+  -> MateHandler ()
+authLogout (Just (muid, method)) = do
+  processLogout muid =<< (rsConnection <$> ask)
+authLogout Nothing = do
   throwError $ err401
     { errBody = "Unauthorized access"
     }

src/Control/Avatar.hs

@@ -43,7 +43,7 @@ avatarGet aid = do
     ) :: Application)
 
 avatarInsert
-  :: Maybe Int
+  :: Maybe (Int, AuthMethod)
   -> AvatarData
   -> MateHandler Int
 avatarInsert (Just _) ad = do
@@ -55,7 +55,7 @@ avatarInsert Nothing _ =
     }
 
 avatarUpdate
-  :: Maybe Int
+  :: Maybe (Int, AuthMethod)
   -> Int
   -> AvatarData
   -> MateHandler ()

src/Control/Buy.hs

@@ -11,10 +11,10 @@ import Types
 import Model
 
 buy
-  :: Maybe Int
+  :: Maybe (Int, AuthMethod)
   -> [PurchaseDetail]
   -> MateHandler PurchaseResult
-buy (Just auid) pds = do
+buy (Just (auid, _)) pds = do
   conn <- rsConnection <$> ask
   (missing, real) <- foldM (\(ms, rs) pd -> do
     mmiss <- checkProductAvailability pd conn

src/Control/Journal.hs

@@ -11,7 +11,7 @@ import Types
 import Model.Journal
 
 journalShow
-  :: Maybe Int
+  :: Maybe (Int, AuthMethod)
   -> Maybe Int
   -> Maybe Int
   -> MateHandler [JournalEntry]

src/Control/Product.hs

@@ -14,7 +14,10 @@ import Data.Maybe (fromMaybe)
 import Types
 import Model
 
-productNew :: Maybe Int -> ProductSubmit -> MateHandler Int
+productNew
+  :: Maybe (Int, AuthMethod)
+  -> ProductSubmit
+  -> MateHandler Int
 productNew (Just _) bevsub = do
   conn <- rsConnection <$> ask
   bevid <- insertProduct bevsub conn
@@ -23,12 +26,17 @@ productNew (Just _) bevsub = do
 productNew Nothing _ =
   throwError $ err401
 
-productOverview :: Int -> MateHandler ProductOverview
+productOverview
+  :: Int
+  -> MateHandler ProductOverview
 productOverview pid = do
   conn <- rsConnection <$> ask
   productOverviewSelectSingle pid conn
 
-productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
+productStockRefill
+  :: Maybe (Int, AuthMethod)
+  -> [AmountRefill]
+  -> MateHandler ()
 productStockRefill (Just _) amorefs = do
   if all ((>= 0) . amountRefillAmount) amorefs
   then do
@@ -43,7 +51,10 @@ productStockRefill Nothing _ =
     { errBody = "No Authentication present."
     }
 
-productStockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
+productStockUpdate
+  :: Maybe (Int, AuthMethod)
+  -> [AmountUpdate]
+  -> MateHandler ()
 productStockUpdate (Just _) amoups = do
   if all ((>= 0) . amountUpdateRealAmount) amoups
   then do
@@ -58,7 +69,9 @@ productStockUpdate Nothing _ =
     { errBody = "No Authentication present."
     }
 
-productList :: Maybe ProductRefine -> MateHandler [ProductOverview]
+productList
+  :: Maybe ProductRefine
+  -> MateHandler [ProductOverview]
 productList mrefine = do
   conn <- rsConnection <$> ask
   productOverviewSelect (fromMaybe AvailableProducts mrefine) conn

src/Control/User.hs

@@ -20,19 +20,24 @@ import qualified Data.Text as T
 import Types
 import Model
 
-userNew :: UserSubmit -> MateHandler Int
+userNew
+  :: UserSubmit
+  -> MateHandler Int
 userNew us = do
   now <- liftIO $ getCurrentTime
   conn <- rsConnection <$> ask
   insertUser us (utctDay now) conn
 
-userGet :: Maybe Int -> Int -> MateHandler UserDetails
+userGet
+  :: Maybe (Int, AuthMethod)
+  -> Int
+  -> MateHandler UserDetails
 userGet Nothing _ =
   throwError $ err401
     { errBody = "No Authentication present."
     }
-userGet (Just aid) uid =
-  if aid == uid
+userGet (Just (aid, method)) uid =
+  if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
   then do
     conn <- rsConnection <$> ask
     userDetailsSelect uid conn
@@ -41,13 +46,17 @@ userGet (Just aid) uid =
       { errBody = "Wrong Authentication present."
       }
 
-userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
+userUpdate
+  :: Maybe (Int, AuthMethod)
+  -> Int
+  -> UserDetailsSubmit
+  -> MateHandler ()
 userUpdate Nothing _ _ =
   throwError $ err401
     { errBody = "No Authentication present."
     }
-userUpdate (Just aid) uid uds =
-  if aid == uid
+userUpdate (Just (aid, method)) uid uds =
+  if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
   then do
     now <- liftIO $ getCurrentTime
     conn <- rsConnection <$> ask
@@ -57,13 +66,18 @@ userUpdate (Just aid) uid uds =
       { errBody = "Wrong Authentication present."
       }
 
-userList :: Maybe UserRefine -> MateHandler [UserSummary]
+userList
+  :: Maybe UserRefine
+  -> MateHandler [UserSummary]
 userList ref = do
   conn <- rsConnection <$> ask
   userSelect (fromMaybe ActiveUsers ref) conn
 
-userRecharge :: Maybe Int -> UserRecharge -> MateHandler ()
-userRecharge (Just auid) (UserRecharge amount) =
+userRecharge
+  :: Maybe (Int, AuthMethod)
+  -> UserRecharge
+  -> MateHandler ()
+userRecharge (Just (auid, _)) (UserRecharge amount) =
   if amount >= 0
   then do
     conn <- rsConnection <$> ask
@@ -85,32 +99,41 @@ userRecharge Nothing _ =
     { errBody = "No Authentication present."
     }
 
-userTransfer :: Maybe Int -> UserTransfer -> MateHandler ()
-userTransfer (Just auid) (UserTransfer target amount) =
+userTransfer
+  :: Maybe (Int, AuthMethod)
+  -> UserTransfer
+  -> MateHandler ()
+userTransfer (Just (auid, method)) (UserTransfer target amount) =
   if amount >= 0
   then
     if auid /= target
-    then do
-      conn <- rsConnection <$> ask
-      user <- userDetailsSelect auid conn
-      if amount < userDetailsBalance user
+    then
+      if any (== method) [PrimaryPass, ChallengeResponse]
       then do
-        mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
-        if not (null mtarget)
+        conn <- rsConnection <$> ask
+        user <- userDetailsSelect auid conn
+        if amount < userDetailsBalance user
         then do
-          void $ addToUserBalance auid (-amount) conn
-          void $ addToUserBalance target amount conn
+          mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
+          if not (null mtarget)
+          then do
+            void $ addToUserBalance auid (-amount) conn
+            void $ addToUserBalance target amount conn
+          else
+            throwError $ err400
+              { errBody = "Target user not found."
+              }
         else
-          throwError $ err400
-            { errBody = "Target user not found."
-            }
+         throwError $ err400
+           { errBody = "Not enough credit balance."
+           }
       else
-       throwError $ err400
-         { errBody = "Not enough credit balance."
-         }
+        throwError $ err400
+          { errBody = "You can not transfer yourself money."
+          }
     else
-      throwError $ err400
-        { errBody = "You can not transfer yourself money."
+      throwError $ err401
+        { errBody = "No Authentication present."
         }
   else
     throwError $ err400

src/Model/Auth.hs

@@ -28,14 +28,11 @@ import Data.Text.Encoding
 
 import qualified Data.Set as S
 
-import Data.Time.Calendar (Day)
 import Data.Time.Clock
 
 import Data.ByteString (ByteString)
 import Data.ByteString.Random
 
-import Data.Maybe (fromMaybe)
-
 import Opaleye hiding (null)
 import qualified Opaleye.Constant as C
 
@@ -44,8 +41,6 @@ import qualified Opaleye.Constant as C
 import Types.Auth
 import Types.Reader
 
-import Model.User
-
 
 initToken :: PGS.Query
 initToken = mconcat
@@ -112,12 +107,17 @@ authDataTable = table "auth_data" (
 delayTime :: Int
 delayTime = 1 * 10 ^ (6 :: Int)
 
+
+generateRandomText :: IO T.Text
+generateRandomText = decodeUtf8 <$> random 23
+
+
 getUserAuthInfo
   :: Int
   -> AuthMethod
+  -> PGS.Connection
   -> MateHandler AuthInfo
-getUserAuthInfo uid method = do
-  conn <- rsConnection <$> ask
+getUserAuthInfo uid method conn = do
   authdata <- liftIO $ do
     void $ threadDelay delayTime
     runSelect conn (
@@ -135,19 +135,27 @@ getUserAuthInfo uid method = do
   then
     -- generate mock AuthInfo
     liftIO $ do
-      rand1 <- decodeUtf8 <$> random 23
+      rand1 <- generateRandomText
       rand2 <- case method of
-        ChallengeResponse -> Just <$> decodeUtf8 <$> random 23
+        ChallengeResponse -> Just <$> generateRandomText
         _                 -> return Nothing
       return $ AuthInfo rand2 (AuthTicket rand1)
   else
     uncurry AuthInfo <$> newTicket uid method
 
 
+putUserAuthInfo
+  :: Int
+  -> AuthMethod
+  -> PGS.Connection
+  -> MateHandler Int
+putUserAuthInfo uid method conn = error "Not yet implemented: putUserAuthInfo"
+
+
 validateToken
   :: ByteString
   -> PGS.Connection
-  -> Handler (Maybe Int)
+  -> Handler (Maybe (Int, AuthMethod))
 validateToken header conn = do
   tokens <- liftIO $ runSelect conn (
     keepWhen (\(tstr, _, _, _) ->
@@ -163,7 +171,7 @@ validateToken header conn = do
     [(_, uid, stamp, method)] -> do
       now <- liftIO $ getCurrentTime
       if diffUTCTime stamp now > 0
-      then return $ Just uid
+      then return $ Just (uid, toEnum method)
       else do
         void $ deleteToken (decodeUtf8 header) conn
         liftIO $ threadDelay delayTime
@@ -180,9 +188,9 @@ validateToken header conn = do
 generateToken
   :: Ticket
   -> AuthResponse
+  -> PGS.Connection
   -> MateHandler AuthResult
-generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) = do
-  conn <- rsConnection <$> ask
+generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
   authData <- liftIO $ runSelect conn (
     keepWhen (\(_, auid, amethod, _) ->
       auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
@@ -202,7 +210,7 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) = do
   if authResult
   then do
     token <- liftIO $ Token
-      <$> (decodeUtf8 <$> random 23)
+      <$> generateRandomText
       <*> pure tuid
       <*> (addUTCTime (23*60) <$> getCurrentTime)
       <*> pure method
@@ -263,9 +271,9 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
 newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
 newTicket ident method = do
   store <- rsTicketStore <$> ask
-  rand1 <- liftIO $ (decodeUtf8 <$> random 23)
+  rand1 <- liftIO $ generateRandomText
   rand2 <- liftIO $ case method of
-    ChallengeResponse -> Just <$> (decodeUtf8 <$> random 23)
+    ChallengeResponse -> Just <$> generateRandomText
     _                 -> return Nothing
   later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
   let ticket = Ticket
@@ -280,9 +288,10 @@ newTicket ident method = do
 
 processAuthRequest
   :: AuthRequest
+  -> S.Set Ticket
+  -> PGS.Connection
   -> MateHandler AuthResult
-processAuthRequest (AuthRequest aticket hash) = do
-  store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
+processAuthRequest (AuthRequest aticket hash) store conn = do
   let mticket = S.filter (\st -> ticketId st == aticket) store
   case S.toList mticket of
     [ticket] -> do
@@ -297,12 +306,12 @@ processAuthRequest (AuthRequest aticket hash) = do
             pure 1 <*>
             liftIO getCurrentTime <*>
             pure (PrimaryPass, Nothing)
-          generateToken mockticket hash
+          generateToken mockticket hash conn
 #else
         return Denied
 #endif
       else
-        generateToken ticket hash
+        generateToken ticket hash conn
     _        -> do
       liftIO $ threadDelay delayTime
 #if defined(DEVELOP)
@@ -312,14 +321,14 @@ processAuthRequest (AuthRequest aticket hash) = do
           pure 1 <*>
           liftIO getCurrentTime <*>
           pure (PrimaryPass, Nothing)
-        generateToken mockticket hash
+        generateToken mockticket hash conn
 #else
       return Denied
 #endif
 
 processLogout
   :: Int
+  -> PGS.Connection
   -> MateHandler ()
-processLogout uid = do
-  conn <- rsConnection <$> ask
+processLogout uid conn = do
   void $ deleteTokenByUserId uid conn