matebeamter/src/Util.hs

134 lines
3.0 KiB
Haskell

{-# 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 Data.Text as T
import Data.Text.Lazy.Encoding
import Data.ByteString.Builder
import Data.List (intercalate)
import Data.List.Split (chunksOf)
import Data.String (fromString)
import Web.Cookie
import Text.Printf (printf)
import Network.HTTP.Types.Status
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Types
import API
setCookie
:: SetCookie
-> Request
-> Request
setCookie c = addHeader "Set-Cookie" (decodeUtf8 . toLazyByteString $ renderSetCookie c)
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" (fromIntegral $ abs amount :: Float))
redirect303
:: Link
-> ServerError
redirect303 link =
err303
{ errHeaders =
[ ("Location", "/" <> fromString (show $ linkURI link))
]
}
parseCookieText
:: T.Text
-> [(T.Text, T.Text)]
parseCookieText = map
(\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two))
. T.splitOn "; "
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 (Just $ "/" <>
fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link
(Nothing, Just uid) -> userOverviewLink uid mRefine
_ -> 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"
)
]
}
)