zgo-backend/src/LangComponent.hs

87 lines
2.3 KiB
Haskell
Raw Normal View History

2023-02-02 21:14:28 +00:00
{-# LANGUAGE OverloadedStrings #-}
module LangComponent where
import Data.Aeson
import Data.Aeson.KeyMap
import qualified Data.Bson as B
import Data.ByteString.Builder.Extra (AllocationStrategy)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Database.MongoDB
import Xero (Xero(x_clientId))
-- | Type to represent a UI components text variables in different languages
data LangComponent =
LangComponent
{ lc_id :: Maybe ObjectId
, lc_lang :: T.Text
, lc_component :: T.Text
, lc_data :: Data.Aeson.Object
}
deriving (Show, Eq)
instance ToJSON LangComponent where
toJSON (LangComponent i l c d) =
case i of
Just oid ->
object
["_id" .= show oid, "language" .= l, "component" .= c, "data" .= d]
Nothing ->
object
[ "_id" .= ("" :: String)
, "language" .= l
, "component" .= c
, "data" .= d
]
instance FromJSON LangComponent where
parseJSON =
withObject "LangComponent" $ \obj -> do
l <- obj .: "language"
c <- obj .: "component"
d <- obj .: "data"
pure $ LangComponent Nothing l c d
instance Val LangComponent where
val (LangComponent i l c d) =
if isJust i
then Doc
[ "_id" =: i
, "language" =: l
, "component" =: c
, "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d
]
else Doc
[ "language" =: l
, "component" =: c
, "data" =: (TL.toStrict . TLE.decodeUtf8 . encode) d
]
cast' (Doc d) = do
i <- B.lookup "_id" d
l <- B.lookup "language" d
c <- B.lookup "component" d
dt <- B.lookup "data" d
pure $
LangComponent
i
l
c
(fromMaybe
Data.Aeson.KeyMap.empty
((decode . TLE.encodeUtf8 . TL.fromStrict) dt))
-- Database Actions
findLangComponent :: T.Text -> T.Text -> Action IO (Maybe Document)
findLangComponent lang component =
findOne (select ["language" =: lang, "component" =: component] "langcomps")
loadLangComponent :: LangComponent -> Action IO ()
loadLangComponent lc = do
let langComp = val lc
case langComp of
Doc x -> insert_ "langcomps" x
_ -> error "Couldn't parse language JSON"