diff --git a/app/Main.hs b/app/Main.hs index 3c7965e..b1d0155 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -62,6 +62,10 @@ app initState = authSend :<|> authLogout :<|> + authManageList :<|> + authManageNewAuth :<|> + authManageDeleteAuth :<|> + userNew :<|> userGet :<|> userUpdate :<|> diff --git a/src/API.hs b/src/API.hs index 4481b7c..81b6faf 100644 --- a/src/API.hs +++ b/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] () diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 4e60134..71a20f7 100644 --- a/src/Control/Auth.hs +++ b/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" + } diff --git a/src/Control/User.hs b/src/Control/User.hs index 082971d..5b14bd3 100644 --- a/src/Control/User.hs +++ b/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 = - if aid == uid && any (== method) [PrimaryPass, ChallengeResponse] +userUpdate (Just (aid, method)) uds = + 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." diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index bcab2d7..b839a21 100644 --- a/src/Model/Auth.hs +++ b/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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 8ead9e9..c2ad45b 100644 --- a/src/Types/Auth.hs +++ b/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