start out user detail and auth detail management

2019-10-14 15:07:17 +02:00 · 2019-10-14 15:07:17 +02:00 · 83db59262d
commit 83db59262d
parent 41031c9c7a
9 changed files with 297 additions and 37 deletions
--- a/matebeamter.cabal
+++ b/matebeamter.cabal
@ -68,7 +68,7 @@ executable matebeamter
                     , cryptonite
                     , stm
                     , stm-containers
-                     , vault
+                     , either
  hs-source-dirs:      src
  default-language:    Haskell2010
  ghc-options:         -Wall
--- a/src/API.hs
+++ b/src/API.hs
@ -35,6 +35,15 @@ type UserAPI =
  :<|> "user" :> "create" :> Get '[HTML] UserNewPage
  :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
    :> Post '[HTML] UserSelectPage
+  :<|> "user" :> "manage" :> Get '[HTML] UserManagePage
+  :<|> "user" :> "manage" :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
+    :> Post '[HTML] UserManagePage
+  :<|> "user" :> "manage" :> "authcreate"
+    :> ReqBody '[FormUrlEncoded] AuthSubmitReturn
+    :> Post '[HTML] UserManagePage
+  :<|> "user" :> "manage" :> "authdelete"
+    :> ReqBody '[FormUrlEncoded] AuthDetailId
+    :> Post '[HTML] UserManagePage
  :<|> "auth"
    :> QueryParam "destination" T.Text
    :> Get '[HTML]
@ -52,6 +61,10 @@ type UserAPI =
  userOverviewLink :<|>
  userNewLink :<|>
  userNewPostLink :<|>
+  userManageLink :<|>
+  userManageDetailsSubmitLink :<|>
+  userManageAuthCreateLink :<|>
+  userManageAuthDeleteLink :<|>
  authLink :<|>
  authPostLink
  ) = allLinks (Proxy :: Proxy UserAPI)
--- a/src/Control/Auth.hs
+++ b/src/Control/Auth.hs
@ -147,14 +147,19 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
                  redirect303
                    (userOverviewLink
                      (read $ T.unpack user)
-                      (Just MT.AvailableProducts)
+                      Nothing
                      )
                _ -> errHeaders $ redirect303 userSelectLink
          throwError $ err303
            { errHeaders = headers ++
-              [ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
-              , ("Set-Cookie", "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
-              , ("Set-Cookie", "x-token=" <> fromString (T.unpack token) <>";Path=/")
+              [ ( "Set-Cookie"
+                , "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
+              , ( "Set-Cookie"
+                , "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
+              , ( "Set-Cookie"
+                , "x-token=" <> fromString (T.unpack token) <>";Path=/")
+              , ( "Set-Cookie"
+                , "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
              ]
            }
        Right MT.Denied -> throwError $ err401
--- a/src/Control/User.hs
+++ b/src/Control/User.hs
@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Control.User where

 import Servant
@ -14,8 +15,9 @@ import qualified Data.Text as T
 import Data.Text.I18n

 import Data.Maybe (fromMaybe)
+import Data.Either.Combinators (leftToMaybe)

-import Control.Monad (void)
+import Control.Monad (void, when)
 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)

@ -80,38 +82,29 @@ userOverviewControl mcookie uid mRefine = do
  (ReadState l10n backend _) <- ask
  let loc = Locale
        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+  let mMethod = T.unpack <$>
+        (lookup "x-method" =<< fmap parseCookieText mcookie)
  euser <- liftIO $ do
    let mToken = T.unpack $ fromMaybe "secret" $
          lookup "x-token" =<< fmap parseCookieText mcookie
    runClientM
-      (userGet (mkAuthenticatedRequest mToken authenticateReq) uid)
+      (userGet (mkAuthenticatedRequest mToken authenticateReq))
      backend
  eproducts <- liftIO $ runClientM
    (productShortList mRefine)
    backend
  case (euser, eproducts) of
    (Right ud, Right prods) ->
-      return $ userOverviewPage l10n loc ud prods
+      case mMethod of
+        Just method ->
+          return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
+        Nothing ->
+          redirectOverAuth (Just uid) mRefine
    (Left uerr, Right _) -> case uerr of
      FailureResponse _ resp ->
        if statusCode (responseStatusCode resp) == 401
-        then do
-          liftIO $ print resp
-          let redirectHeaders = errHeaders $
-                redirect303 (authLink (Just $ "/" <>
-                  fromString (show $ linkURI (userOverviewLink uid mRefine))))
-          throwError
-            (err303
-              { errHeaders = redirectHeaders ++
-                [ ( "Set-Cookie"
-                  , "x-auth-user=" <> (fromString $ show uid) <> "; Path=/"
-                  )
-                , ( "Set-Cookie"
-                  , "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
-                  )
-                ]
-              }
-              )
+        then
+          redirectOverAuth (Just uid) mRefine
        else
          throwError $ err500
            { errBody = fromString (show uerr)
@ -128,3 +121,89 @@ userOverviewControl mcookie uid mRefine = do
      throwError $ err500
        { 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
+userManageControl mcookie = do
+  (ReadState l10n backend _) <- ask
+  let loc = Locale
+        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+      token = T.unpack $ fromMaybe "secret" $
+        (lookup "x-token" =<< fmap parseCookieText mcookie)
+  eUserDetails <- liftIO $ do
+    runClientM
+      (userGet (mkAuthenticatedRequest token authenticateReq))
+      backend
+  eAuthOverviews <- liftIO $ do
+    runClientM
+      (authManageList (mkAuthenticatedRequest token authenticateReq))
+      backend
+  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"
+          }
+
+userManageDetailsSubmitControl mcookie _ =
+  error "not yet implemented"
+
+userManageAuthCreateControl mcookie _ =
+  error "not yet implemented"
+
+userManageAuthDeleteControl mcookie _ =
+  error "not yet implemented"
--- a/src/Main.hs
+++ b/src/Main.hs
@ -47,6 +47,10 @@ userApp initState = serveWithContext userApi (EmptyContext) $
    :<|> userOverviewControl mcookie
    :<|> userNewControl mcookie
    :<|> userNewPostControl mcookie
+    :<|> userManageControl mcookie
+    :<|> userManageDetailsSubmitControl mcookie
+    :<|> userManageAuthCreateControl mcookie
+    :<|> userManageAuthDeleteControl mcookie
    :<|> authControl mcookie
    :<|> authPostControl mcookie
    )
--- a/src/Types/Auth.hs
+++ b/src/Types/Auth.hs
@ -20,3 +20,21 @@ data AuthReturn = AuthReturn

 instance MimeRender HTML AuthReturn
 instance FromForm AuthReturn
+
+data AuthSubmitReturn = AuthSubmitReturn
+  { authSubmitReturnComment :: T.Text
+  , authSubmitReturnPass    :: T.Text
+  , authSubmitReturnMethod  :: Int
+  }
+  deriving (Show, Generic)
+
+instance MimeRender HTML AuthSubmitReturn
+instance FromForm AuthSubmitReturn
+
+newtype AuthDetailId = AuthDetailId
+  { unId :: Int
+  }
+  deriving (Show, Generic)
+
+instance MimeRender HTML AuthDetailId
+instance FromForm AuthDetailId
--- a/src/Types/Orphans.hs
+++ b/src/Types/Orphans.hs
@ -9,9 +9,16 @@ import GHC.Generics

 import Text.Blaze

+import Text.Read (readEither)
+
+import qualified Data.Text as T
+
 import Servant.API
 import Servant.HTML.Blaze
 import Web.Internal.FormUrlEncoded

 instance MimeUnrender HTML MT.UserSubmit
 instance FromForm MT.UserSubmit
+
+instance MimeUnrender HTML MT.UserDetailsSubmit
+instance FromForm MT.UserDetailsSubmit
--- a/src/Types/Views.hs
+++ b/src/Types/Views.hs
@ -8,6 +8,8 @@ type UserNewPage = H.Html

 type UserOverviewPage = H.Html

+type UserManagePage = H.Html
+
 type ProductListPage = H.Html

 type AuthPage = H.Html
--- a/src/View/User.hs
+++ b/src/View/User.hs
@ -7,11 +7,13 @@ import Servant.Links
 import qualified Text.Blaze.Html5 as H hiding (style)
 import qualified Text.Blaze.Html5.Attributes as HA

+import qualified Data.Text as T
+
 import Data.Text.I18n

 import Data.String (fromString)

-import Data.Maybe (isJust, fromJust)
+import Data.Maybe (isJust, fromJust, fromMaybe)

 -- imports from mateamt

@ -47,10 +49,11 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
 userOverviewPage
  :: L10n
  -> Locale
+  -> MT.AuthMethod
  -> MT.UserDetails
  -> [MT.ProductShortOverview]
  -> UserOverviewPage
-userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
+userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
  (localize l10n locale $ gettext "Matebeamter") <>
  " - " <>
  (localize l10n locale $ gettext "User Menu for ") <>
@ -63,16 +66,14 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
      ": " <>
      (formatMoney $ MT.userDetailsBalance ud)
      -- TODO: Add currency symbol
-    H.ul H.! HA.class_ "product_list" $
-      mapM_
-        (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
-          H.li H.! HA.class_ "product" H.!?
-            (isJust avatarid
-            , productBgStyle (fromString $ show $ fromJust avatarid)
-            ) $
-              H.a H.! HA.href ("#" <> fromString (show pid)) $ H.toHtml ident
-        )
-        pos
+    case method of
+      MT.PrimaryPass ->
+        userSettingsPointer
+      MT.SecondaryPass ->
+        productList
+      MT.ChallengeResponse -> do
+        userSettingsPointer
+        productList
  where
    translate = localize l10n locale . gettext
    productBgStyle aid = HA.style $ mconcat
@ -84,6 +85,22 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
      , "  1px 0 1px black,"
      , "  0 -1px 1px black;"
      ]
+    userSettingsPointer =
+      H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink)) $
+        H.toHtml $ translate "Manage user settings"
+    productList =
+      H.p $
+        H.ul H.! HA.class_ "product_list" $
+          mapM_
+            (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
+              H.li H.! HA.class_ "product" H.!?
+                (isJust avatarid
+                , productBgStyle (fromString $ show $ fromJust avatarid)
+                ) $
+                  H.a H.! HA.href ("#" <> fromString (show pid)) $
+                    H.toHtml ident
+            )
+            pos

 userNewPage
  :: L10n
@ -132,3 +149,118 @@ userNewPage l10n locale = scaffold l10n locale (initPage $
            $ H.toHtml $ translate "Submit"
  where
    translate = localize l10n locale . gettext
+
+userManagePage
+  :: L10n
+  -> Locale
+  -> MT.UserDetails
+  -> [MT.AuthOverview]
+  -> UserManagePage
+userManagePage l10n locale userDetails authOverviews =
+  scaffold l10n locale (initPage $
+    (translate "Matebeamter") <>
+    " - " <>
+    (translate "Manage user data")
+    ) $ do
+      H.p $ H.form
+        H.! HA.method "post"
+        H.! HA.action ("/" <>
+          (fromString $ show $ linkURI $ userManageDetailsSubmitLink))
+        H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
+          H.legend $ H.toHtml $ translate "User details"
+          H.div H.! HA.class_ "form-group required" $ do
+            H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
+            H.input
+              H.! HA.id "username"
+              H.! HA.class_ "form-control"
+              H.! HA.name "userDetailsSubmitIdent"
+              H.! HA.type_ "text"
+              H.! HA.required ""
+              H.! HA.value
+                (fromString $ T.unpack $ MT.userDetailsIdent userDetails)
+          H.div H.! HA.class_ "form-group optional" $ do
+            H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
+            H.input
+              H.! HA.id "useremail"
+              H.! HA.class_ "form-control"
+              H.! HA.name "userDetailsSubmitEmail"
+              H.! HA.type_ "email"
+              H.! HA.required ""
+              H.! HA.value
+                (fromMaybe "" $ fromString <$> T.unpack <$>
+                  MT.userDetailsEmail userDetails)
+          H.div H.! HA.class_ "form-group optional" $ do
+            H.button
+              H.! HA.class_ "btn btn-default"
+              H.! HA.type_ "submit"
+              $ H.toHtml $ translate "Submit"
+      H.p $ do
+        mapM_
+          (\(MT.AuthOverview aoid comment method) -> H.form
+            H.! HA.method "post"
+            H.! HA.action ("/" <>
+              (fromString $ show $ linkURI $ userManageAuthDeleteLink))
+            H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
+              H.legend $ H.toHtml $ comment
+              H.div H.! HA.class_ "form-group required" $ do
+                H.input
+                  H.! HA.class_ "form-control"
+                  H.! HA.name "unId"
+                  H.! HA.type_ "hidden"
+                  H.! HA.required ""
+                  H.! HA.value (fromString $ show aoid)
+              H.div H.! HA.class_ "form-group optional" $ do
+                H.button
+                  H.! HA.class_ "btn btn-default"
+                  H.! HA.type_ "submit"
+                  $ H.toHtml $ translate "Delete"
+            )
+          authOverviews
+        H.form
+          H.! HA.method "post"
+          H.! HA.action ("/" <>
+            (fromString $ show $ linkURI $ userManageAuthCreateLink))
+          H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
+            H.legend $ H.toHtml $ translate "Authentication details"
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "comment" $ H.toHtml $
+                translate "Comment"
+              H.input
+                H.! HA.id "comment"
+                H.! HA.class_ "form_control"
+                H.! HA.name "authSubmitReturnComment"
+                H.! HA.type_ "text"
+                H.! HA.required ""
+                H.! HA.value ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "password" $ H.toHtml $
+                translate "Password"
+              H.input
+                H.! HA.id "password"
+                H.! HA.class_ "form_control"
+                H.! HA.name "authSubmitReturnPass"
+                H.! HA.type_ "password"
+                H.! HA.required ""
+                H.! HA.value ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "method" $ H.toHtml $
+                translate "Authentication Method"
+              H.select
+                H.! HA.id "method"
+                H.! HA.class_ "form-control"
+                H.! HA.name "authSubmitReturnMethod"
+                H.! HA.required ""
+                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.option H.!
+                    HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
+                      H.toHtml $ translate "Primary Password"
+            H.div H.! HA.class_ "form-group optional" $ do
+              H.button
+                H.! HA.class_ "btn btn-default"
+                H.! HA.type_ "submit"
+                $ H.toHtml $ translate "Submit"
+  where
+    translate = localize l10n locale . gettext