diff --git a/src/API.hs b/src/API.hs index d248c35..658beeb 100644 --- a/src/API.hs +++ b/src/API.hs @@ -30,22 +30,21 @@ import Types type UserAPI = Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage - :<|> "user" :> Capture "id" Int + :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine :> Get '[HTML] UserOverviewPage :<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :> Post '[HTML] UserSelectPage - :<|> "product" :> "list" :> QueryParam "refine" MT.ProductRefine - :> Get '[HTML] ProductListPage :<|> "auth" + :> QueryParam "destination" T.Text :> Get '[HTML] (Headers '[ Header "Set-Cookie" T.Text - , Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) - :<|> "auth" :> ReqBody '[FormUrlEncoded] AuthReturn + :<|> "auth" :> QueryParam "destination" T.Text + :> ReqBody '[FormUrlEncoded] AuthReturn :> Post '[HTML] UserSelectPage ) @@ -53,7 +52,6 @@ type UserAPI = userOverviewLink :<|> userNewLink :<|> userNewPostLink :<|> - productListLink :<|> authLink :<|> authPostLink ) = allLinks (Proxy :: Proxy UserAPI) diff --git a/src/Control.hs b/src/Control.hs index 16138c8..cc596b4 100644 --- a/src/Control.hs +++ b/src/Control.hs @@ -4,4 +4,3 @@ module Control import Control.Auth as C import Control.User as C -import Control.Product as C diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 0d65179..7cc1405 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -17,7 +17,6 @@ import Data.String (fromString) import Data.Maybe (fromMaybe) import Data.Either (isRight, rights, lefts) -import Control.Monad (foldM) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) @@ -36,17 +35,32 @@ import Hash authControl :: Maybe T.Text + -> Maybe T.Text -> UserHandler (Headers '[ Header "Set-Cookie" T.Text - , Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) -authControl mcookie@(Just cookie) = do - let mauthUser = lookup "x-auth-user" (parseCookieText cookie) - case mauthUser of - Just authUser -> do +authControl mcookie@(Just cookie) mDestination = do + let mAuthUser = lookup "x-auth-user" (parseCookieText cookie) + let mToken = lookup "x-token" (parseCookieText cookie) + case (mAuthUser, mToken) of + (Just authUser, Just _) -> do + throwError $ case mDestination of + Just destination -> + err303 + { errHeaders = + [ ("Location", fromString (T.unpack destination)) + ] + } + Nothing -> + redirect303 + (userOverviewLink + (read $ T.unpack authUser) + Nothing + ) + (Just authUser, Nothing) -> do (ReadState _ backend _) <- ask let trs = map (MT.TicketRequest @@ -70,7 +84,7 @@ authControl mcookie@(Just cookie) = do else throwError $ err400 { errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos } - Nothing -> + (Nothing, _) -> error $ "Error handling not yet implemented properly, but here's your user: " <> (fromString $ T.unpack $ fromMaybe "" $ lookup "x-auth-user" (parseCookieText cookie) @@ -81,7 +95,6 @@ authControl mcookie@(Just cookie) = do -> UserHandler (Headers '[ Header "Set-Cookie" T.Text - , Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) @@ -94,21 +107,21 @@ authControl mcookie@(Just cookie) = do "x-ticket-"<> fromString (show $ fromEnum method) <>"=" <> (fromString $ T.unpack ticket) <> ";Path=/") tupAuthInfos - return $ addHeader - "x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $ - addHeader (ticketHeaders !! 0) $ - addHeader (ticketHeaders !! 1) $ - authPage l10n loc -authControl Nothing = + return $ + addHeader (ticketHeaders !! 0) $ + addHeader (ticketHeaders !! 1) $ + authPage l10n loc mDestination +authControl Nothing _ = throwError $ err400 { errBody = "No cookie present." } authPostControl :: Maybe T.Text + -> Maybe T.Text -> AuthReturn -> UserHandler UserSelectPage -authPostControl (Just cookies) (AuthReturn pass method) = do +authPostControl (Just cookies) mDestination (AuthReturn pass method) = do let mticket = lookup ("x-ticket-" <> fromString (show method)) $ parseCookieText cookies case mticket of @@ -125,10 +138,18 @@ authPostControl (Just cookies) (AuthReturn pass method) = do backend case etoken of Right (MT.Granted (MT.AuthToken token)) -> do - let headers = errHeaders $ - redirect303 - -- FIXME: redirect to product select - (productListLink (Just MT.AvailableProducts)) + let mUser = lookup "x-auth-user" $ parseCookieText cookies + headers = case (mDestination, mUser) of + (Just destination, _) -> + [ ("Location", fromString (T.unpack destination)) + ] + (Nothing, Just user) -> errHeaders $ + redirect303 + (userOverviewLink + (read $ T.unpack user) + (Just MT.AvailableProducts) + ) + _ -> errHeaders $ redirect303 userSelectLink throwError $ err303 { errHeaders = headers ++ [ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") @@ -145,6 +166,6 @@ authPostControl (Just cookies) (AuthReturn pass method) = do Nothing -> throwError $ err400 { errBody = "No ticket cookie present." } -authPostControl Nothing _ = throwError $ err400 +authPostControl Nothing _ _ = throwError $ err400 { errBody = "No ticket cookie present." } diff --git a/src/Control/Product.hs b/src/Control/Product.hs deleted file mode 100644 index 3822193..0000000 --- a/src/Control/Product.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE DataKinds #-} -module Control.Product where - -import Servant -import Servant.Client -import Servant.Server - -import qualified Data.Text as T - -import Data.Maybe (fromMaybe) - -import Data.Text.I18n - -import Data.String (fromString) - -import Control.Monad.Reader (ask) -import Control.Monad.IO.Class (liftIO) - --- imports from "mateamt" - -import qualified "mateamt" Types as MT - --- internal imports - -import View -import Types -import Client -import Util - -productListControl - :: Maybe T.Text - -> Maybe MT.ProductRefine - -> UserHandler ProductListPage -productListControl mcookie mrefine = do - (ReadState l10n backend _) <- ask - let loc = Locale - (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - eProducts <- liftIO $ runClientM - (productShortList mrefine) - backend - case eProducts of - Right products -> - return $ productListPage l10n loc mrefine products - Left err -> - throwError $ err500 - { errBody = fromString $ show err - } diff --git a/src/Control/User.hs b/src/Control/User.hs index 3ad4269..522e956 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -74,16 +74,20 @@ userNewPostControl _ us@(MT.UserSubmit ident email pass) = do userOverviewControl :: Maybe T.Text -> Int + -> Maybe MT.ProductRefine -> UserHandler UserOverviewPage -userOverviewControl mcookie uid = do +userOverviewControl mcookie uid mRefine = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - euser <- liftIO $ runClientM - (userGet (mkAuthenticatedRequest "secret" authenticateReq) uid) - backend + euser <- liftIO $ do + let mToken = T.unpack $ fromMaybe "secret" $ + lookup "x-token" =<< fmap parseCookieText mcookie + runClientM + (userGet (mkAuthenticatedRequest mToken authenticateReq) uid) + backend eproducts <- liftIO $ runClientM - (productShortList Nothing) + (productShortList mRefine) backend case (euser, eproducts) of (Right ud, Right prods) -> @@ -92,12 +96,18 @@ userOverviewControl mcookie uid = do FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then do - let redirectHeaders = errHeaders $ redirect303 authLink + 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-auth-user=" <> (fromString $ show uid) <> "; Path=/" + ) + , ( "Set-Cookie" + , "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" ) ] } diff --git a/src/Main.hs b/src/Main.hs index 5b38b30..e9ee339 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -47,7 +47,6 @@ userApp initState = serveWithContext userApi (EmptyContext) $ :<|> userOverviewControl mcookie :<|> userNewControl mcookie :<|> userNewPostControl mcookie - :<|> productListControl mcookie :<|> authControl mcookie :<|> authPostControl mcookie ) diff --git a/src/Util.hs b/src/Util.hs index ad9d937..104a2d1 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -37,7 +37,7 @@ formatMoney amount = pre <> t <> "," <> c t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp) c = fromString $ snd sp sp = tail <$> - break (== '.') (printf "%.2f" (abs amount)) + break (== '.') (printf "%.2f" (fromIntegral $ abs amount :: Float)) redirect303 :: Link @@ -45,7 +45,7 @@ redirect303 redirect303 link = err303 { errHeaders = - [ ("Location", "/" <> (fromString $ show $ linkURI $ link)) + [ ("Location", "/" <> (fromString $ show $ linkURI link)) ] } diff --git a/src/View.hs b/src/View.hs index c09ba74..c2782ae 100644 --- a/src/View.hs +++ b/src/View.hs @@ -4,4 +4,3 @@ module View import View.Auth as V import View.User as V -import View.Product as V diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 6d34445..11d6470 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -7,6 +7,8 @@ import Servant.Links (linkURI) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA +import qualified Data.Text as T + import Data.Text.I18n import Data.String @@ -24,8 +26,9 @@ import View.Scaffold authPage :: L10n -> Locale + -> Maybe T.Text -> AuthPage -authPage l10n locale = scaffold +authPage l10n locale mDestination = scaffold l10n locale (initPage $ @@ -36,7 +39,8 @@ authPage l10n locale = scaffold $ do H.p $ H.form H.! HA.method "post" - H.! HA.action ("/" <> (fromString $ show $ linkURI $ authPostLink)) + H.! HA.action ("/" <> (fromString $ show $ linkURI $ + authPostLink mDestination)) H.! HA.enctype "application/x-www-form-urlencoded" $ do H.div H.! HA.class_ "form-group required" $ do H.label H.! HA.for "method" $ H.toHtml $ diff --git a/src/View/Product.hs b/src/View/Product.hs deleted file mode 100644 index bdc31db..0000000 --- a/src/View/Product.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -module View.Product where - -import Servant.Links - -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as HA - -import Data.Text.I18n - -import Data.String (fromString) - --- imports from "mateamt" - -import qualified "mateamt" Types as MT - --- internal imports - -import Util -import Types -import View.Scaffold -import API - -productListPage - :: L10n - -> Locale - -> Maybe MT.ProductRefine - -> [MT.ProductShortOverview] - -> ProductListPage -productListPage l10n locale mRefine psos = scaffold l10n locale (initPage $ - (translate "Matebeamter") <> - " - " <> - (translate "Product list") - ) $ if null psos - then - H.h1 $ H.toHtml $ translate "No products present" - else do - mapM_ (\(MT.ProductShortOverview pid ident price amount ml mAvatar) -> do - H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ - productListLink mRefine)) $ - H.toHtml ident - ) psos - where - translate = localize l10n locale . gettext diff --git a/src/View/User.hs b/src/View/User.hs index a5478a4..6293ee1 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -35,8 +35,9 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $ (translate "Home") ) $ do mapM_ (\(MT.UserSummary uid ident _) -> do - H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userOverviewLink uid)) $ - H.toHtml ident + H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ + userOverviewLink uid Nothing)) $ + H.toHtml ident ) uss H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $ H.toHtml $ translate "New user"