matebeamter/src/Util.hs

{-# 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 String)
parseTokenAndUser mcookie =
  (token, mAuthUser)
  where
    token = T.unpack $ fromMaybe "secret"
      (lookup "x-token" =<< mParsedCookie)
    mAuthUser = 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
            ))))
  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 String, 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
    othererr ->
      throwError $
        addMessage (fromString $ show othererr) $
        redirect303 userSelectLink