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.Lazy.Encoding

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

-- 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" (abs $ (fromIntegral amount / 100) :: 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 "; "

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

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"
          )
        ]
      }
      )

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;"
  ]