{-# LANGUAGE OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
module Magicbane.Util where
import RIO (MonadThrow, throwM)
import Control.Arrow
import Control.Monad
import Control.Error (hush)
import qualified Data.ByteString.Lazy as L (ByteString)
import qualified Data.HashMap.Strict as HMS
import qualified Data.Sequences as S
import qualified Data.Text as T
import Data.Text (Text)
import Data.Char (isSpace)
import Data.Foldable
import Data.HashMap.Strict (insertWith)
import Data.Maybe
import Data.MonoTraversable
import Data.String.Conversions
import Data.String.Conversions.Monomorphic
import Data.Attoparsec.Text as AP
import Data.Aeson
import Network.URI
import Network.HTTP.Types (hContentType)
import Web.FormUrlEncoded hiding (parseMaybe)
import Servant
mergeVal ∷ Value → Value → Value
mergeVal (Object x) (Object y) = Object $ HMS.unionWith mergeVal x y
mergeVal x _ = x
writeForm ∷ (ConvertibleStrings α Text, ConvertibleStrings β Text, ConvertibleStrings L.ByteString γ) ⇒ [(α, β)] → γ
writeForm = fromLBS . mimeRender (Proxy ∷ Proxy FormUrlEncoded) . map (toST *** toST)
readForm ∷ (ConvertibleStrings Text α, ConvertibleStrings Text β, ConvertibleStrings γ L.ByteString) ⇒ γ → Maybe [(α, β)]
readForm x = map (fromST *** fromST) <$> hush (mimeUnrender (Proxy ∷ Proxy FormUrlEncoded) $ toLBS x)
formList ∷ Form → [(Text, Text)]
formList = fromMaybe [] . hush . fromForm
formToObject ∷ [(Text, Text)] → Value
formToObject f = foldl' assignProp (object []) $ (map . first) parseKey f
where parseKey x = fromMaybe [ x ] $ hush $ parseOnly formKey x
assignProp (Object o) ([k], v) = Object $ insertWith concatJSON k (toJSON [ v ]) o
assignProp (Object o) (k : k' : ks, v) = Object $ insertWith (\_ o' → assignProp o' (k' : ks, v)) k (assignProp (object []) (k' : ks, v)) o
assignProp x _ = x
concatJSON (Array v1) (Array v2) = Array $ v1 <> v2
concatJSON (Array v1) _ = Array v1
concatJSON _ (Array v2) = Array v2
concatJSON _ _ = Null
formKey ∷ Parser [Text]
formKey = do
firstKey ← AP.takeWhile (/= '[')
restKeys ← many' $ do
void $ char '['
s ← AP.takeWhile (/= ']')
void $ char ']'
return s
void $ option '_' $ char '[' >> char ']'
return $ firstKey : S.filter (not . T.null) restKeys
parseUri ∷ ConvertibleStrings α String ⇒ α → URI
parseUri = fromJust . parseURI . cs
slugify ∷ Text → Text
slugify = T.filter (not . isSpace) . T.intercalate "-" . T.words .
T.replace "&" "and" . T.replace "+" "plus" . T.replace "%" "percent" .
T.replace "<" "lt" . T.replace ">" "gt" . T.replace "=" "eq" .
T.replace "#" "hash" . T.replace "@" "at" . T.replace "$" "dollar" .
T.filter (`onotElem` ("!^*?()[]{}`./\\'\"~|"::String)) .
T.toLower . T.strip
errText ∷ ServantErr → L.ByteString → ServantErr
errText e t = e { errHeaders = [ (hContentType, "text/plain; charset=utf-8") ]
, errBody = t }
throwErrText ∷ MonadThrow μ ⇒ ServantErr → L.ByteString → μ α
throwErrText e t = throwM $ errText e t