delete duplicate product page attempts, refine authenitcation

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)

src/Control.hs

@@ -4,4 +4,3 @@ module Control
 
 import Control.Auth as C
 import Control.User as C
-import Control.Product as C

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."
   }

src/Control/Product.hs

@@ -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
-        }

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

src/Main.hs

@@ -47,7 +47,6 @@ userApp initState = serveWithContext userApi (EmptyContext) $
     :<|> userOverviewControl mcookie
     :<|> userNewControl mcookie
     :<|> userNewPostControl mcookie
-    :<|> productListControl mcookie
     :<|> authControl mcookie
     :<|> authPostControl mcookie
     )

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

src/View.hs

@@ -4,4 +4,3 @@ module View
 
 import View.Auth as V
 import View.User as V
-import View.Product as V

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 $

src/View/Product.hs

@@ -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

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"