user detail management so far complete

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)]
+    err -> handleErrors
-  where
+      (fmap read mAuthUser)
-    handleErrors merrs = do
+      [leftToMaybe (fst err), leftToMaybe (snd err)]
-      codes <- mapM
+
-        (\eerr -> case eerr of
+userManageDetailsSubmitControl mcookie uds = do
-          Just (FailureResponse _ resp) ->
+  (ReadState l10n backend _) <- ask
-            return $ statusCode (responseStatusCode resp)
+  let loc = Locale
-          Just err ->
+        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
-            throwError $ err500
+      mParsedCookie = fmap parseCookieText mcookie
-              { errBody = fromString (show err)
+      token = T.unpack $ fromMaybe "secret" $
-              }
+        ((lookup "x-token") =<< mParsedCookie)
-          Nothing ->
+      mAuthUser = T.unpack <$>
-            return 200
+        ((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 (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)
       )
-        merrs
+    backend
-      if (any (== 401) codes)
+  case eReturn of
+    Right _ -> throwError $ redirect303 userManageLink
+    Left err -> handleErrors (fmap read mAuthUser) [Just err]
+
+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
-        redirectOverAuth Nothing Nothing
+          throwError $ redirect303 userManageLink
         else
-        throwError $ err500
+          handleErrors (fmap read mAuthUser) [Just err]
-          { errBody = "Could not handle errors in handleErrors"
+      _ -> handleErrors (fmap read mAuthUser) [Just err]
-          }
-
-userManageDetailsSubmitControl mcookie _ =
-  error "not yet implemented"
-
-userManageAuthCreateControl mcookie _ =
-  error "not yet implemented"
-
-userManageAuthDeleteControl mcookie _ =
-  error "not yet implemented"

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"
+          )
+        ]
+      }
+      )

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"