matebeamter/src/Util.hs

217 lines
5.0 KiB
Haskell
Raw Permalink Normal View History

2019-09-08 10:48:57 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
2019-09-18 13:24:23 +00:00
{-# LANGUAGE FlexibleContexts #-}
2019-10-14 15:40:20 +00:00
{-# LANGUAGE PackageImports #-}
2019-10-16 16:07:12 +00:00
{-# LANGUAGE LambdaCase #-}
2019-09-08 15:27:38 +00:00
module Util where
2019-09-08 10:48:57 +00:00
import Servant hiding (addHeader)
2019-10-14 15:40:20 +00:00
import Servant.Client
2019-09-08 10:48:57 +00:00
2019-10-21 18:41:58 +00:00
import qualified Text.Blaze.Html5.Attributes as HA
2022-09-16 14:37:00 +00:00
import Text.Blaze.Internal
2019-10-21 18:41:58 +00:00
2019-09-11 04:27:54 +00:00
import qualified Data.Text as T
import Data.Text.Encoding
2019-09-11 04:27:54 +00:00
2019-11-01 11:22:28 +00:00
import Data.Text.I18n
2019-09-11 04:27:54 +00:00
import Data.List (intercalate)
import Data.List.Split (chunksOf)
import Data.String (fromString)
2019-10-22 18:43:50 +00:00
import Data.Maybe (fromMaybe)
2019-09-11 04:27:54 +00:00
import Text.Printf (printf)
2019-10-14 15:40:20 +00:00
import Network.HTTP.Types.Status
2022-09-16 14:37:00 +00:00
import Control.Monad.Reader (ask)
2019-12-12 02:41:22 +00:00
2019-10-14 15:40:20 +00:00
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Types
import API
2019-09-11 04:27:54 +00:00
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 <$>
2019-12-12 02:41:22 +00:00
break (== '.') (printf "%.2f" (abs (fromIntegral amount / 100) :: Float))
2019-09-18 13:24:23 +00:00
redirect303
2019-10-04 07:04:23 +00:00
:: Link
-> ServerError
2019-09-18 13:24:23 +00:00
redirect303 link =
2019-10-04 07:04:23 +00:00
err303
2019-09-18 13:24:23 +00:00
{ errHeaders =
2019-10-16 16:07:12 +00:00
[ ("Location", "/" <> fromString (show $ linkURI link))
2019-09-18 13:24:23 +00:00
]
}
2019-10-04 07:04:23 +00:00
2019-10-24 16:05:22 +00:00
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 <>
2019-10-24 16:05:22 +00:00
"; Path=/; Max-Age=5"
) : errHeaders err
}
2019-10-04 07:04:23 +00:00
parseCookieText
:: T.Text
-> [(T.Text, T.Text)]
parseCookieText = map
(\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two))
. T.splitOn "; "
2019-10-14 15:40:20 +00:00
2019-10-22 18:43:50 +00:00
parseTokenAndUser
:: Maybe T.Text
-> (String, Maybe Int)
2019-10-22 18:43:50 +00:00
parseTokenAndUser mcookie =
(token, mAuthUser)
where
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
2024-02-28 10:56:38 +00:00
mAuthUser = read . T.unpack <$>
2019-10-22 18:43:50 +00:00
(lookup "x-auth-user" =<< mParsedCookie)
mParsedCookie = fmap parseCookieText mcookie
2019-11-01 11:22:28 +00:00
localeFromCookie
:: Maybe T.Text
-> Locale
localeFromCookie mcookie = Locale
2024-02-28 10:56:38 +00:00
(fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
2019-11-01 11:22:28 +00:00
2019-10-14 15:40:20 +00:00
handleErrors
:: (Traversable t, Show (t (Maybe ClientError)))
=> Maybe Int
2019-10-14 19:41:28 +00:00
-> Maybe Link
2019-10-14 15:40:20 +00:00
-> t (Maybe ClientError)
-> UserHandler UserOverviewPage
2019-10-14 19:41:28 +00:00
handleErrors mAuthUser mLink merrs = do
2019-10-14 15:40:20 +00:00
codes <- mapM
2019-10-16 16:07:12 +00:00
(\case
2019-10-14 15:40:20 +00:00
Just (FailureResponse _ resp) ->
return $ statusCode (responseStatusCode resp)
Just err ->
throwError $ err500
{ errBody = fromString (show err)
}
Nothing ->
return 200
)
merrs
2019-10-16 16:07:12 +00:00
if 401 `elem` codes
2019-10-14 15:40:20 +00:00
then
2019-10-14 19:41:28 +00:00
redirectOverAuth mAuthUser mLink Nothing
2019-10-14 15:40:20 +00:00
else
throwError $ err500
{ errBody = fromString (show merrs)
}
redirectOverAuth
:: Maybe Int
2019-10-14 19:41:28 +00:00
-> Maybe Link
2019-10-16 16:07:12 +00:00
-> Maybe MT.ProductRefine
2019-10-14 15:40:20 +00:00
-> UserHandler UserOverviewPage
2019-10-14 19:41:28 +00:00
redirectOverAuth muid mLink mRefine = do
2019-10-14 15:40:20 +00:00
let redirectHeaders = errHeaders $
2019-12-14 23:05:12 +00:00
-- redirect303 authLink
2019-10-14 15:40:20 +00:00
redirect303 (authLink (Just $ "/" <>
2019-10-14 19:41:28 +00:00
fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link
2019-10-16 16:07:12 +00:00
(Nothing, Just uid) -> userOverviewLink uid mRefine
_ -> userSelectLink Nothing
2019-10-14 15:40:20 +00:00
))))
throwError
(err303
{ errHeaders = redirectHeaders ++ (case muid of
Just uid ->
[ ( "Set-Cookie"
2019-10-16 16:07:12 +00:00
, "x-auth-user=" <> fromString (show uid) <> "; Path=/"
2019-10-14 15:40:20 +00:00
)
]
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"
)
]
}
)
2019-10-21 18:41:58 +00:00
2022-09-16 14:37:00 +00:00
productBgStyle
:: AttributeValue
-> Attribute
2019-10-21 18:41:58 +00:00
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;"
]
2019-12-12 02:41:22 +00:00
controlInit
:: Maybe T.Text
-> UserHandler (String, Maybe Int, Locale, L10n, ClientEnv, T.Text, T.Text)
2019-12-12 02:41:22 +00:00
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)
2019-12-14 23:05:12 +00:00
2022-09-16 14:37:00 +00:00
handleClientErr
:: ClientError
-> Maybe Int
-> Maybe Link
-> UserHandler UserOverviewPage
2019-12-15 09:34:38 +00:00
handleClientErr err muid authTargetLink =
2019-12-14 23:05:12 +00:00
case err of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
2019-12-15 09:34:38 +00:00
redirectOverAuth muid authTargetLink Nothing
2019-12-14 23:05:12 +00:00
else
throwError $
addMessage (fromString $ show err) $
redirect303 (userSelectLink Nothing)
2019-12-14 23:05:12 +00:00
othererr ->
throwError $
addMessage (fromString $ show othererr) $
redirect303 (userSelectLink Nothing)