start out user detail and auth detail management

matebeamter.cabal

@@ -68,7 +68,7 @@ executable matebeamter
                      , cryptonite
                      , stm
                      , stm-containers
-                     , vault
+                     , either
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall

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)

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"
-              , ("Set-Cookie", "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
+                , "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
-              , ("Set-Cookie", "x-token=" <> fromString (T.unpack token) <>";Path=/")
+              , ( "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

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
+        then
-          liftIO $ print resp
+          redirectOverAuth (Just uid) mRefine
-          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"
-                  )
-                ]
-              }
-              )
         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"

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
     )

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

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

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

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" $
+    case method of
-      mapM_
+      MT.PrimaryPass ->
-        (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
+        userSettingsPointer
-          H.li H.! HA.class_ "product" H.!?
+      MT.SecondaryPass ->
-            (isJust avatarid
+        productList
-            , productBgStyle (fromString $ show $ fromJust avatarid)
+      MT.ChallengeResponse -> do
-            ) $
+        userSettingsPointer
-              H.a H.! HA.href ("#" <> fromString (show pid)) $ H.toHtml ident
+        productList
-        )
-        pos
   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