{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} module Control.User where import Servant import Servant.Client import Servant.Client.Core.Auth import Servant.Server import Data.String (fromString) import qualified Data.Text as T import Data.Text.I18n import Data.Maybe (fromMaybe) import Data.Either.Combinators (leftToMaybe) import Control.Monad (void, when) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status -- imports from "mateamt" import qualified "mateamt" API as MA import qualified "mateamt" Types as MT -- internal imports import Types import Client import ClientAuth import View import Hash import API import Util userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage userSelectControl mcookie = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) euser <- liftIO $ runClientM (userList (Nothing)) backend case euser of Right uss -> return $ userSelectPage l10n loc uss Left err -> error $ show err userNewControl :: Maybe T.Text -> UserHandler UserNewPage userNewControl mcookie = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) return $ userNewPage l10n loc userNewPostControl :: Maybe T.Text -> MT.UserSubmit -> UserHandler UserSelectPage userNewPostControl _ us@(MT.UserSubmit ident email pass) = do backend <- rsBackend <$> ask hashedPass <- hashPassword pass void $ liftIO $ runClientM (userNew $us { MT.userSubmitPassHash = hashedPass }) backend throwError $ redirect303 userSelectLink userOverviewControl :: Maybe T.Text -> Int -> Maybe MT.ProductRefine -> UserHandler UserOverviewPage 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)) backend eproducts <- liftIO $ runClientM (productShortList mRefine) backend case (euser, eproducts) of (Right ud, Right 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 redirectOverAuth (Just uid) mRefine else throwError $ err500 { errBody = fromString (show uerr) } _ -> throwError $ err500 { errBody = fromString (show uerr) } (Right _, Left perr) -> throwError $ err500 { errBody = fromString (show perr) } (Left uerr, Left perr) -> 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"