{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.KeyValue(findKeyValue,
formatKeyValue,
getKeyValue,
insertKeyValue,
keyValueListToJSON)
where
import Control.Monad.IO.Class(MonadIO)
import Data.Aeson((.=), object, toJSON)
import Data.Aeson.Types(KeyValue)
import Data.List(partition)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Database.Esqueleto
import BDCS.DB
import BDCS.KeyType
findKeyValue :: MonadIO m => KeyType -> Maybe T.Text -> Maybe T.Text -> SqlPersistT m (Maybe (Key KeyVal))
findKeyValue k v e = firstKeyResult $
select $ from $ \kv -> do
where_ $ kv ^. KeyValKey_value ==. val k &&.
kv ^. KeyValVal_value ==? v &&.
kv ^. KeyValExt_value ==? e
limit 1
return $ kv ^. KeyValId
formatKeyValue :: KeyVal -> T.Text
formatKeyValue KeyVal{..} = let
rhs = case (keyValVal_value, keyValExt_value) of
(Just v, Nothing) -> T.concat [ " = ", v ]
(Just v, Just e) -> T.concat [ " = (", v, ", ", e, ")" ]
_ -> ""
in
T.concat [ T.pack $ show keyValKey_value, rhs ]
getKeyValue :: MonadIO m => Key KeyVal -> SqlPersistT m (Maybe KeyVal)
getKeyValue key = firstEntityResult $
select $ from $ \kv -> do
where_ $ kv ^. KeyValId ==. val key
limit 1
return kv
insertKeyValue :: MonadIO m => KeyType -> Maybe T.Text -> Maybe T.Text -> SqlPersistT m (Key KeyVal)
insertKeyValue k v e =
insert (KeyVal k v e)
keyValueListToJSON :: KeyValue t => [KeyVal] -> [t]
keyValueListToJSON lst = let
isLabelKey (LabelKey _) = True
isLabelKey _ = False
(labelKvs, otherKvs) = partition (isLabelKey . keyValKey_value) lst
labelVals = map (\kv -> (T.pack "labels", [toJSON $ keyValKey_value kv])) labelKvs
otherVals = map (\kv -> (asText $ keyValKey_value kv, [toJSON kv])) otherKvs
labelMap = Map.fromListWith (++) labelVals
otherMap = Map.fromListWith (++) otherVals
pairs = map (\(k, v) -> case v of
[hd] -> k .= hd
_ -> k .= v)
(Map.toList otherMap) ++
map (uncurry (.=)) (Map.toList labelMap)
in
[T.pack "keyvals" .= object pairs]