{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} module Control.User where import Servant import Servant.Client import Servant.Client.Core.Auth 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) import Control.Monad.Reader (ask, asks) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status -- imports from "mateamt" 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 _ _) <- 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 _ _ pass) = do backend <- asks rsBackend 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) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ lookup "x-token" =<< mParsedCookie mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) mMethod = T.unpack <$> (lookup "x-method" =<< mParsedCookie) euser <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend eproducts <- liftIO $ runClientM (productShortList mRefine) backend case (euser, eproducts) of (Right ud, Right prods) -> case mMethod of Just method -> if fmap read mAuthUser == Just uid then return $ userOverviewPage l10n loc (toEnum $ read method) ud prods else redirectOverAuth (Just uid) (Just $ userOverviewLink uid mRefine) mRefine Nothing -> redirectOverAuth (read <$> mAuthUser) Nothing mRefine (Left uerr, Right _) -> case uerr of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then redirectOverAuth (Just uid) Nothing 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) } userManageControl :: Maybe T.Text -> Int -> UserHandler UserManagePage userManageControl mcookie uid = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) eUserDetails <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend eAuthOverviews <- liftIO $ runClientM (authManageList (mkAuthenticatedRequest token authenticateReq)) backend case (eUserDetails, eAuthOverviews) of (Right userDetails, Right authOverviews) -> if Just uid == fmap read mAuthUser then return $ userManagePage l10n loc userDetails authOverviews else redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing err -> handleErrors (Just uid) (Just $ userManageLink uid) [leftToMaybe (fst err), leftToMaybe (snd err)] userManageDetailsSubmitControl :: Maybe T.Text -> Int -> MT.UserDetailsSubmit -> UserHandler UserOverviewPage userManageDetailsSubmitControl mcookie uid uds = do (ReadState _ backend _) <- ask let mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) eReturn <- liftIO $ runClientM (userUpdate (mkAuthenticatedRequest token authenticateReq) uds) backend case eReturn of Right _ -> throwError $ redirect303 (userManageLink uid) Left err -> handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] userManageAuthCreateControl :: Maybe T.Text -> Int -> AuthSubmitReturn -> UserHandler UserOverviewPage userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do (ReadState _ backend _) <- ask let mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) hashedPass <- hashPassword pass eReturn <- liftIO $ runClientM (authManageNewAuth (mkAuthenticatedRequest token authenticateReq) (MT.AuthSubmit (toEnum method) comment hashedPass) ) backend case eReturn of Right _ -> throwError $ redirect303 $ userManageLink uid Left err -> handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] userManageAuthDeleteControl :: Maybe T.Text -> Int -> AuthDetailId -> UserHandler UserOverviewPage userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do (ReadState _ backend _) <- ask let mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) eReturn <- liftIO $ runClientM (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) backend case eReturn of Right _ -> throwError $ redirect303 $ userManageLink uid Left err -> case err of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 406 then throwError $ redirect303 $ userManageLink uid else handleErrors (fmap read mAuthUser) Nothing [Just err] _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]