rework auth

app/Main.hs

@@ -62,6 +62,10 @@ app initState =
         authSend :<|>
         authLogout :<|>
 
+        authManageList :<|>
+        authManageNewAuth :<|>
+        authManageDeleteAuth :<|>
+
         userNew :<|>
         userGet :<|>
         userUpdate :<|>

src/API.hs

@@ -22,11 +22,18 @@ type MateAPI =
   :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
   :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] ()
 
+  :<|> "auth" :> "manage" :> AuthProtect "header-auth"
+    :> Get '[JSON] [AuthOverview]
+  :<|> "auth" :> "manage" :> AuthProtect "header-auth"
+    :> ReqBody '[JSON] AuthSubmit :> Post '[JSON] Int
+  :<|> "auth" :> "manage" :> AuthProtect "header-auth"
+    :> ReqBody '[JSON] Int :> Delete '[JSON] ()
+
   :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
   :<|> "user" :> AuthProtect "header-auth"
     :> Capture "uid'" Int :> Get '[JSON] UserDetails
   :<|> "user" :> AuthProtect "header-auth"
-    :> Capture "uid'" Int :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] ()
+    :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] ()
   :<|> "user" :> "list" :> QueryParam "refine" UserRefine :> Get '[JSON] [UserSummary]
   :<|> "user" :> "recharge" :> AuthProtect "header-auth"
     :> ReqBody '[JSON] UserRecharge :> Post '[JSON] ()

src/Control/Auth.hs

@@ -3,6 +3,8 @@ module Control.Auth where
 
 import Servant
 
+import Control.Monad (void)
+
 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 
@@ -36,3 +38,76 @@ authLogout Nothing = do
   throwError $ err401
     { errBody = "Unauthorized access"
     }
+
+authManageList
+  :: Maybe (Int, AuthMethod)
+  -> MateHandler [AuthOverview]
+authManageList (Just (uid, method)) =
+  if any (== method) [PrimaryPass, ChallengeResponse]
+  then do
+    conn <- rsConnection <$> ask
+    selectAuthOverviews uid conn
+  else
+    throwError $ err401
+      { errBody = "Unauthorized access"
+      }
+authManageList Nothing =
+  throwError $ err401
+    { errBody = "Unauthorized access"
+    }
+
+authManageNewAuth
+  :: Maybe (Int, AuthMethod)
+  -> AuthSubmit
+  -> MateHandler Int
+authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = do
+  if any (== method) [PrimaryPass, ChallengeResponse]
+  then do
+    conn <- rsConnection <$> ask
+    putUserAuthInfo uid asmethod ascomment aspayload conn
+  else
+    throwError $ err401
+      { errBody = "Unauthorized access"
+      }
+authManageNewAuth Nothing _ =
+  throwError $ err401
+    { errBody = "Unauthorized access"
+    }
+
+authManageDeleteAuth
+  :: Maybe (Int, AuthMethod)
+  -> Int
+  -> MateHandler ()
+authManageDeleteAuth (Just (uid, method)) adid = do
+  if any (== method) [PrimaryPass, ChallengeResponse]
+  then do
+    conn <- rsConnection <$> ask
+    ads <- selectAuthOverviews uid conn
+    let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
+    case authOverviewMethod currentad of
+      PrimaryPass -> if validateDeletion ads
+        then void (deleteAuthDataById adid conn)
+        else throwError $ err406
+          { errBody = "You need at least one primary password or challenge response authentication"
+          }
+      ChallengeResponse -> if validateDeletion ads
+        then void (deleteAuthDataById adid conn)
+        else throwError $ err406
+          { errBody = "You need at least one primary password or challenge response authentication"
+          }
+      _ -> void $ deleteAuthDataById adid conn
+  else
+    throwError $ err401
+      { errBody = "Unauthorized access"
+      }
+  where
+    validateDeletion ads =
+      2 <= length (filter
+        (\ad -> authOverviewMethod ad == PrimaryPass ||
+          authOverviewMethod ad == ChallengeResponse)
+        ads
+        )
+authManageDeleteAuth Nothing _ = do
+  throwError $ err401
+    { errBody = "Unauthorized access"
+    }

src/Control/User.hs

@@ -27,7 +27,7 @@ userNew (UserSubmit ident email passhash) = do
   now <- liftIO $ getCurrentTime
   conn <- rsConnection <$> ask
   uid <- insertUser ident email (utctDay now) conn
-  void $ putUserAuthInfo uid PrimaryPass passhash conn
+  void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
   return uid
 
 userGet
@@ -50,19 +50,18 @@ userGet (Just (aid, method)) uid =
 
 userUpdate
   :: Maybe (Int, AuthMethod)
-  -> Int
   -> UserDetailsSubmit
   -> MateHandler ()
-userUpdate Nothing _ _ =
+userUpdate Nothing _ =
   throwError $ err401
     { errBody = "No Authentication present."
     }
-userUpdate (Just (aid, method)) uid uds =
+userUpdate (Just (aid, method)) uds =
-  if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
+  if any (== method) [PrimaryPass, ChallengeResponse]
   then do
     now <- liftIO $ getCurrentTime
     conn <- rsConnection <$> ask
-    void $ updateUserDetails uid uds (utctDay now) conn
+    void $ updateUserDetails aid uds (utctDay now) conn
   else
     throwError $ err401
       { errBody = "Wrong Authentication present."

src/Model/Auth.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Arrows #-}
 module Model.Auth where
 
 import Servant
 
-import Control.Arrow ((<<<))
+import Control.Arrow
 
 import Control.Monad (void)
 
@@ -17,7 +18,7 @@ import Control.Concurrent (threadDelay)
 
 import Control.Concurrent.STM
 
-import Data.Profunctor.Product (p4)
+import Data.Profunctor.Product (p4, p5)
 
 import qualified Database.PostgreSQL.Simple as PGS
 
@@ -79,6 +80,7 @@ initAuthData = mconcat
   , "auth_data_id      SERIAL  PRIMARY KEY,"
   , "auth_data_user    INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
   , "auth_data_method  INTEGER NOT NULL,"
+  , "auth_data_comment TEXT    NOT NULL,"
   , "auth_data_payload TEXT    NOT NULL"
   , ")"
   ]
@@ -88,17 +90,20 @@ authDataTable :: Table
   , Field SqlInt4
   , Field SqlInt4
   , Field SqlText
+  , Field SqlText
   )
   ( Field SqlInt4
   , Field SqlInt4
   , Field SqlInt4
   , Field SqlText
+  , Field SqlText
   )
 authDataTable = table "auth_data" (
-  p4
+  p5
     ( tableField "auth_data_id"
     , tableField "auth_data_user"
     , tableField "auth_data_method"
+    , tableField "auth_data_comment"
     , tableField "auth_data_payload"
     )
   )
@@ -112,6 +117,29 @@ generateRandomText :: IO T.Text
 generateRandomText = decodeUtf8 <$> random 23
 
 
+selectAuthOverviews
+  :: Int
+  -> PGS.Connection
+  -> MateHandler [AuthOverview]
+selectAuthOverviews uid conn = do
+  authData <- liftIO $ runSelect conn ( proc () -> do
+    (adid, aduid, admethod, adcomment, adpayload) <-
+      queryTable authDataTable -< ()
+    restrict -< aduid .== C.constant uid
+    returnA -< (adid, adcomment, admethod)
+    ) :: MateHandler
+        [ ( Int
+          , T.Text
+          , Int
+          )
+        ]
+  return $ map
+    (\(adid, adcomment, admethod) ->
+      AuthOverview adid adcomment (toEnum admethod)
+      )
+    authData
+
+
 getUserAuthInfo
   :: Int
   -> AuthMethod
@@ -121,7 +149,7 @@ getUserAuthInfo uid method conn = do
   authdata <- liftIO $ do
     void $ threadDelay delayTime
     runSelect conn (
-      keepWhen (\(_, duid, dmethod, _) ->
+      keepWhen (\(_, duid, dmethod, _, _) ->
         duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
           <<< queryTable authDataTable
       ) :: IO
@@ -129,6 +157,7 @@ getUserAuthInfo uid method conn = do
             , Int
             , Int
             , T.Text
+            , T.Text
             )
           ]
   if null authdata
@@ -148,9 +177,10 @@ putUserAuthInfo
   :: Int
   -> AuthMethod
   -> T.Text
+  -> T.Text
   -> PGS.Connection
   -> MateHandler Int
-putUserAuthInfo uid method payload conn = 
+putUserAuthInfo uid method comment payload conn =
   fmap head $ liftIO $ runInsert_ conn $ Insert
     { iTable = authDataTable
     , iRows =
@@ -158,14 +188,26 @@ putUserAuthInfo uid method payload conn =
       ( C.constant (Nothing :: Maybe Int)
       , C.constant uid
       , C.constant (fromEnum method)
+      , C.constant comment
       , C.constant payload
       )
       ]
-    , iReturning = rReturning (\(adid, _, _, _) -> adid)
+    , iReturning = rReturning (\(adid, _, _, _, _) -> adid)
     , iOnConflict = Nothing
     }
 
 
+deleteAuthDataById
+  :: Int
+  -> PGS.Connection
+  -> MateHandler Int64
+deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
+  { dTable     = authDataTable
+  , dWhere     = (\(aid, _, _, _, _) -> aid .== C.constant adid)
+  , dReturning = rCount
+  }
+
+
 validateToken
   :: ByteString
   -> PGS.Connection
@@ -206,7 +248,7 @@ generateToken
   -> MateHandler AuthResult
 generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
   authData <- liftIO $ runSelect conn (
-    keepWhen (\(_, auid, amethod, _) ->
+    keepWhen (\(_, auid, amethod, _, _) ->
       auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
         <<< queryTable authDataTable
     ) :: MateHandler
@@ -214,9 +256,10 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
           , Int
           , Int
           , T.Text
+          , T.Text
           )
         ]
-  let userPayloads = map (\(_, _, _, payload) -> payload) authData
+  let userPayloads = map (\(_, _, _, _, payload) -> payload) authData
       authResult = case method of
         PrimaryPass       -> validatePass response userPayloads
         SecondaryPass     -> validatePass response userPayloads

src/Types/Auth.hs

@@ -53,6 +53,19 @@ instance ToJSON AuthMethod where
 instance FromJSON AuthMethod
 
 
+data AuthSubmit = AuthSubmit
+  { authSubmitMethod  :: AuthMethod
+  , authSubmitComment :: T.Text
+  , authSubmitPayload :: T.Text
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AuthSubmit where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthSubmit
+
+
 newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
 
 instance ToJSON AuthTicket where
@@ -130,6 +143,20 @@ data AuthData = AuthData
   { authDataId      :: Int
   , authDataUser    :: Int
   , authDataMethod  :: AuthMethod
+  , authDataComment :: T.Text
   , authDataPayload :: T.Text
   }
   deriving (Show)
+
+
+data AuthOverview = AuthOverview
+  { authOverviewId      :: Int
+  , authOverviewComment :: T.Text
+  , authOverviewMethod  :: AuthMethod
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AuthOverview where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthOverview