module Hails.Database.MongoDB.TCB.Convert (
labeledDocI
) where
import LIO
import LIO.TCB
import qualified Data.Bson as B (Value(..))
import qualified Data.UString as U
import Data.IterIO
import Data.IterIO.Http
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as S
import Data.List
import Data.List.Utils
import Data.UString (pack)
import Hails.Data.LBson.TCB
labeledDocI :: (LabelState l p s)
=> HttpReq a
-> Labeled l L.ByteString
-> LIO l p s (Labeled l (Document l))
labeledDocI req lbody = do
let lbl = labelOf lbody
doc <- enumPure (unlabelTCB lbody) |$ formFolder req
return $ labelTCB lbl doc
formFolder :: (LabelState l p s)
=> HttpReq a -> Iter L.ByteString (LIO l p s) (Document l)
formFolder req = foldForm req docontrol []
where docontrol acc field = do
formVal <- fmap L.unpack pureI
let k = S.unpack $ ffName field
if endswith "[]" k then
return $ appendVal acc k formVal
else do
let lfld = pack (S.unpack.ffName $ field) =: formVal
return $ lfld : acc
appendVal :: LabelState l p s => Document l -> String -> String -> Document l
appendVal doc k' formVal =
let k = U.pack $ takeWhile (/= '[') k'
field = (k := BsonVal (B.Array [B.String $ U.pack formVal]))
in case find (isKey k) doc of
Just _ -> map (upsert k) doc
Nothing -> field:doc
where upsert k f@(k0 := (BsonVal (B.Array arr))) =
if k0 == k then
(k =: (B.String $ U.pack formVal):arr)
else f
upsert _ f = f
isKey kk (k := _) = k == kk