From c3cda9a253064af43c4033e04fd5aee8dfa5af1a Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 14 Oct 2019 17:40:20 +0200 Subject: [PATCH] user detail management so far complete --- src/Control/User.hs | 126 ++++++++++++++++++++++---------------------- src/Util.hs | 73 +++++++++++++++++++++++++ src/View/User.hs | 12 +++-- 3 files changed, 145 insertions(+), 66 deletions(-) diff --git a/src/Control/User.hs b/src/Control/User.hs index c9880f1..97e1028 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -122,40 +122,6 @@ userOverviewControl mcookie uid mRefine = do { errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr) } -redirectOverAuth - :: Maybe Int - -> Maybe (MT.ProductRefine) - -> UserHandler UserOverviewPage -redirectOverAuth muid mRefine = do - let redirectHeaders = errHeaders $ - redirect303 (authLink (Just $ "/" <> - fromString (show $ linkURI (case muid of - Just uid -> userOverviewLink uid mRefine - Nothing -> userSelectLink - )))) - throwError - (err303 - { errHeaders = redirectHeaders ++ (case muid of - Just uid -> - [ ( "Set-Cookie" - , "x-auth-user=" <> (fromString $ show uid) <> "; Path=/" - ) - ] - Nothing -> - [ - ] - ) - ++ - [ ( "Set-Cookie" - , "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" - ) - , ( "Set-Cookie" - , "x-method=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" - ) - ] - } - ) - userManageControl :: Maybe T.Text -> UserHandler UserManagePage @@ -163,8 +129,11 @@ userManageControl mcookie = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ - (lookup "x-token" =<< fmap parseCookieText mcookie) + ((lookup "x-token") =<< mParsedCookie) + mAuthUser = T.unpack <$> + ((lookup "x-auth-user") =<< mParsedCookie) eUserDetails <- liftIO $ do runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) @@ -176,34 +145,65 @@ userManageControl mcookie = do case (eUserDetails, eAuthOverviews) of (Right userDetails, Right authOverviews) -> return $ userManagePage l10n loc userDetails authOverviews - err -> handleErrors [leftToMaybe (fst err), leftToMaybe (snd err)] - where - handleErrors merrs = do - codes <- mapM - (\eerr -> case eerr of - Just (FailureResponse _ resp) -> - return $ statusCode (responseStatusCode resp) - Just err -> - throwError $ err500 - { errBody = fromString (show err) - } - Nothing -> - return 200 - ) - merrs - if (any (== 401) codes) - then - redirectOverAuth Nothing Nothing - else - throwError $ err500 - { errBody = "Could not handle errors in handleErrors" - } + err -> handleErrors + (fmap read mAuthUser) + [leftToMaybe (fst err), leftToMaybe (snd err)] -userManageDetailsSubmitControl mcookie _ = - error "not yet implemented" +userManageDetailsSubmitControl mcookie uds = do + (ReadState l10n backend _) <- ask + let loc = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" $ + ((lookup "x-token") =<< mParsedCookie) + mAuthUser = T.unpack <$> + ((lookup "x-auth-user") =<< mParsedCookie) + eReturn <- liftIO $ runClientM + (userUpdate (mkAuthenticatedRequest token authenticateReq) uds) + backend + case eReturn of + Right _ -> throwError $ redirect303 userManageLink + Left err -> handleErrors (fmap read mAuthUser) [Just err] -userManageAuthCreateControl mcookie _ = - error "not yet implemented" +userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do + (ReadState l10n backend _) <- ask + let loc = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" $ + ((lookup "x-token") =<< mParsedCookie) + mAuthUser = T.unpack <$> + ((lookup "x-auth-user") =<< mParsedCookie) + hashedPass <- hashPassword pass + eReturn <- liftIO $ runClientM + (authManageNewAuth + (mkAuthenticatedRequest token authenticateReq) + (MT.AuthSubmit (toEnum method) comment hashedPass) + ) + backend + case eReturn of + Right _ -> throwError $ redirect303 userManageLink + Left err -> handleErrors (fmap read mAuthUser) [Just err] -userManageAuthDeleteControl mcookie _ = - error "not yet implemented" +userManageAuthDeleteControl mcookie (AuthDetailId adid) = do + (ReadState l10n backend _) <- ask + let loc = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" $ + ((lookup "x-token") =<< mParsedCookie) + mAuthUser = T.unpack <$> + ((lookup "x-auth-user") =<< mParsedCookie) + eReturn <- liftIO $ runClientM + (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) + backend + case eReturn of + Right _ -> throwError $ redirect303 userManageLink + Left err -> case err of + FailureResponse _ resp -> + if statusCode (responseStatusCode resp) == 406 + then + throwError $ redirect303 userManageLink + else + handleErrors (fmap read mAuthUser) [Just err] + _ -> handleErrors (fmap read mAuthUser) [Just err] diff --git a/src/Util.hs b/src/Util.hs index 104a2d1..7c2e238 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -2,9 +2,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PackageImports #-} module Util where import Servant hiding (addHeader) +import Servant.Client import Servant.Client.Core.Request import Servant.Client.Core.Request (addHeader) @@ -22,6 +24,17 @@ import Web.Cookie import Text.Printf (printf) +import Network.HTTP.Types.Status + +-- imports from "mateamt" + +import qualified "mateamt" Types as MT + +-- internal imports + +import Types +import API + setCookie :: SetCookie -> Request @@ -55,3 +68,63 @@ parseCookieText parseCookieText = map (\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two)) . T.splitOn "; " + +handleErrors + :: (Traversable t, Show (t (Maybe ClientError))) + => Maybe Int + -> t (Maybe ClientError) + -> UserHandler UserOverviewPage +handleErrors mAuthUser merrs = do + codes <- mapM + (\eerr -> case eerr of + Just (FailureResponse _ resp) -> + return $ statusCode (responseStatusCode resp) + Just err -> + throwError $ err500 + { errBody = fromString (show err) + } + Nothing -> + return 200 + ) + merrs + if (any (== 401) codes) + then + redirectOverAuth mAuthUser Nothing + else + throwError $ err500 + { errBody = fromString (show merrs) + } + +redirectOverAuth + :: Maybe Int + -> Maybe (MT.ProductRefine) + -> UserHandler UserOverviewPage +redirectOverAuth muid mRefine = do + let redirectHeaders = errHeaders $ + redirect303 (authLink (Just $ "/" <> + fromString (show $ linkURI (case muid of + Just uid -> userOverviewLink uid mRefine + Nothing -> userSelectLink + )))) + throwError + (err303 + { errHeaders = redirectHeaders ++ (case muid of + Just uid -> + [ ( "Set-Cookie" + , "x-auth-user=" <> (fromString $ show uid) <> "; Path=/" + ) + ] + Nothing -> + [ + ] + ) + ++ + [ ( "Set-Cookie" + , "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" + ) + , ( "Set-Cookie" + , "x-method=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" + ) + ] + } + ) diff --git a/src/View/User.hs b/src/View/User.hs index b11558b..d0a7748 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -201,7 +201,13 @@ userManagePage l10n locale userDetails authOverviews = H.! HA.action ("/" <> (fromString $ show $ linkURI $ userManageAuthDeleteLink)) H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do - H.legend $ H.toHtml $ comment + H.legend $ H.toHtml $ comment <> " - " <> case method of + MT.PrimaryPass -> + translate "Primary password" + MT.SecondaryPass -> + translate "Secondary password" + MT.ChallengeResponse -> + translate "Challenge response authentication" H.div H.! HA.class_ "form-group required" $ do H.input H.! HA.class_ "form-control" @@ -253,10 +259,10 @@ userManagePage l10n locale userDetails authOverviews = H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do H.option H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ - H.toHtml $ translate "Secondary Password" + H.toHtml $ translate "Secondary password" H.option H.! HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $ - H.toHtml $ translate "Primary Password" + H.toHtml $ translate "Primary password" H.div H.! HA.class_ "form-group optional" $ do H.button H.! HA.class_ "btn btn-default"