{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE LambdaCase #-} module Util where import Servant hiding (addHeader) import Servant.Client import Servant.Client.Core.Request import qualified Text.Blaze.Html5.Attributes as HA import qualified Data.Text as T import Data.Text.Encoding import Data.Text.I18n import Data.ByteString.Builder import Data.List (intercalate) import Data.List.Split (chunksOf) import Data.String (fromString) import Data.Maybe (fromMaybe) import Web.Cookie import Text.Printf (printf) import Network.HTTP.Types.Status import Control.Monad.Reader (ask, asks) -- imports from "mateamt" import qualified "mateamt" Types as MT -- internal imports import Types import API formatMoney :: Int -> T.Text formatMoney amount = pre <> t <> "," <> c where pre = if amount < 0 then "-" else "" t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp) c = fromString $ snd sp sp = tail <$> break (== '.') (printf "%.2f" (abs (fromIntegral amount / 100) :: Float)) redirect303 :: Link -> ServerError redirect303 link = err303 { errHeaders = [ ("Location", "/" <> fromString (show $ linkURI link)) ] } redirect307 :: Link -> ServerError redirect307 link = err307 { errHeaders = [ ("Location", "/" <> fromString (show $ linkURI link)) ] } addMessage :: T.Text -> ServerError -> ServerError addMessage message err = err { errHeaders = ( "Set-Cookie" , "message=" <> encodeUtf8 message <> "; Path=/; Max-Age=5" ) : errHeaders err } parseCookieText :: T.Text -> [(T.Text, T.Text)] parseCookieText = map (\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two)) . T.splitOn "; " parseTokenAndUser :: Maybe T.Text -> (String, Maybe Int) parseTokenAndUser mcookie = (token, mAuthUser) where token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) mAuthUser = read <$> T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) mParsedCookie = fmap parseCookieText mcookie localeFromCookie :: Maybe T.Text -> Locale localeFromCookie mcookie = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) handleErrors :: (Traversable t, Show (t (Maybe ClientError))) => Maybe Int -> Maybe Link -> t (Maybe ClientError) -> UserHandler UserOverviewPage handleErrors mAuthUser mLink merrs = do codes <- mapM (\case Just (FailureResponse _ resp) -> return $ statusCode (responseStatusCode resp) Just err -> throwError $ err500 { errBody = fromString (show err) } Nothing -> return 200 ) merrs if 401 `elem` codes then redirectOverAuth mAuthUser mLink Nothing else throwError $ err500 { errBody = fromString (show merrs) } redirectOverAuth :: Maybe Int -> Maybe Link -> Maybe MT.ProductRefine -> UserHandler UserOverviewPage redirectOverAuth muid mLink mRefine = do let redirectHeaders = errHeaders $ -- redirect303 authLink redirect303 (authLink (Just $ "/" <> fromString (show $ linkURI (case (mLink, muid) of (Just link, _) -> link (Nothing, Just uid) -> userOverviewLink uid mRefine _ -> userSelectLink Nothing )))) 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" ) ] } ) productBgStyle aid = HA.style $ mconcat [ "background-image: url(#" <> aid <> ");" -- FILLME , "backgronud-color: blue;" , "text-shadow:" , " -1px 0 1px black," , " 0 1px 1px black," , " 1px 0 1px black," , " 0 -1px 1px black;" ] controlInit :: Maybe T.Text -> UserHandler (String, Maybe Int, Locale, L10n, ClientEnv, T.Text, T.Text) controlInit mcookie = do let (token, muser) = parseTokenAndUser mcookie loc = localeFromCookie mcookie (ReadState l10n backend _ symbol version) <- ask return (token, muser, loc, l10n, backend, symbol, version) handleClientErr err muid authTargetLink = case err of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then redirectOverAuth muid authTargetLink Nothing else throwError $ addMessage (fromString $ show err) $ redirect303 (userSelectLink Nothing) othererr -> throwError $ addMessage (fromString $ show othererr) $ redirect303 (userSelectLink Nothing)