diff --git a/matebeamter.cabal b/matebeamter.cabal index c142441..66d5ddf 100644 --- 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 diff --git a/src/API.hs b/src/API.hs index 658beeb..2954767 100644 --- 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) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 7cc1405..6231768 100644 --- 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 diff --git a/src/Control/User.hs b/src/Control/User.hs index 522e956..c9880f1 100644 --- 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" diff --git a/src/Main.hs b/src/Main.hs index e9ee339..0a5b48e 100644 --- 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 ) diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 65b3668..82ecf67 100644 --- 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 diff --git a/src/Types/Orphans.hs b/src/Types/Orphans.hs index ca1638c..c8ba688 100644 --- 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 diff --git a/src/Types/Views.hs b/src/Types/Views.hs index 18dc301..0482839 100644 --- 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 diff --git a/src/View/User.hs b/src/View/User.hs index 6293ee1..b11558b 100644 --- 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