1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 module Databrary.HTTP.Form 3 ( FormKey(..) 4 , FormPath 5 , formPathText 6 , FormData 7 , FormDatum(..) 8 , Form(..) 9 , initForm 10 , subForm 11 , subForms 12 ) where 13 14 import qualified Data.Aeson as JSON 15 import qualified Data.ByteString as BS 16 import qualified Data.ByteString.Char8 as BSC 17 import qualified Data.HashMap.Strict as HM 18 import qualified Data.Map.Strict as Map 19 import Data.Monoid ((<>)) 20 import qualified Data.Text as T 21 import qualified Data.Text.Encoding as TE 22 import qualified Data.Vector as V 23 import Network.Wai.Parse (FileInfo) 24 25 import Databrary.Has (Has(..)) 26 import Databrary.HTTP.Form.Data 27 28 data FormKey 29 = FormField !T.Text 30 | FormIndex !Int 31 deriving (Eq, Ord) 32 33 type FormPath = [FormKey] 34 35 formSubPath :: FormKey -> FormPath -> FormPath 36 formSubPath k p = p ++ [k] 37 38 instance Has BS.ByteString FormKey where 39 view (FormField t) = TE.encodeUtf8 t 40 view (FormIndex i) = BSC.pack $ show i 41 42 instance Has T.Text FormKey where 43 view (FormField t) = t 44 view (FormIndex i) = T.pack $ show i 45 46 dotsBS :: [BS.ByteString] -> BS.ByteString 47 dotsBS = BS.intercalate (BSC.singleton '.') 48 49 dotBS :: BS.ByteString -> BS.ByteString -> BS.ByteString 50 dotBS a b 51 | BS.null a = b 52 | otherwise = dotsBS [a, b] 53 54 formSubBS :: FormKey -> BS.ByteString -> BS.ByteString 55 formSubBS k b = b `dotBS` view k 56 57 formPathText :: FormPath -> T.Text 58 formPathText = T.intercalate (T.singleton '.') . map view 59 60 data FormDatum 61 = FormDatumNone 62 | FormDatumBS !BS.ByteString 63 | FormDatumJSON !JSON.Value 64 | FormDatumFlag 65 deriving (Eq) 66 67 instance Monoid FormDatum where 68 mempty = FormDatumNone 69 mappend FormDatumNone x = x 70 mappend x _ = x 71 72 data Form a = Form 73 { formData :: !(FormData a) 74 , formPath :: FormPath 75 , formPathBS :: BS.ByteString 76 , formJSON :: Maybe JSON.Value 77 , formDatum :: FormDatum 78 , formFile :: Maybe (FileInfo a) 79 } 80 81 -- makeHasRec ''Form ['formData, 'formPath, 'formPathBS, 'formDatum, 'formFile] 82 83 initForm :: FormData a -> Form a 84 initForm d = form where form = Form d [] "" (formDataJSON d) (getFormDatum form) Nothing 85 86 formSubJSON :: FormKey -> JSON.Value -> Maybe JSON.Value 87 formSubJSON k (JSON.Object o) = HM.lookup (view k) o 88 formSubJSON (FormIndex i) (JSON.Array a) = a V.!? i 89 formSubJSON _ _ = Nothing 90 91 subForm :: FormKey -> Form a -> Form a 92 subForm key form = form' where 93 form' = form 94 { formPath = formSubPath key $ formPath form 95 , formPathBS = formSubBS key $ formPathBS form 96 , formJSON = formSubJSON key =<< formJSON form 97 , formDatum = getFormDatum form' 98 , formFile = getFormFile form' 99 } 100 101 jsonSubForms :: Form a -> [(FormKey, Form a)] 102 jsonSubForms f = maybe [] jfk (formJSON f) where 103 jfk (JSON.Array a) = V.toList $ V.imap (sfj . FormIndex) a 104 jfk (JSON.Object o) = HM.elems $ HM.mapWithKey (sfj . FormField) o 105 jfk _ = [] 106 sfj k v = (k, (subForm k f){ formJSON = Just v, formDatum = FormDatumJSON v }) 107 108 subFormsFor :: (FormData a -> Map.Map BS.ByteString b) -> Form a -> [(FormKey, Form a)] 109 subFormsFor m f = 110 map (sf . FormField . TE.decodeUtf8) $ uniq $ map (BSC.takeWhile ('.' /=) . BS.drop l') $ takeWhile (BS.isPrefixOf p') $ Map.keys $ snd $ Map.split p' $ m $ formData f where 111 sf k = (k, subForm k f) 112 p' = formPathBS f `dotBS` "" 113 l' = BS.length p' 114 uniq (a:bl@(b:_)) 115 | a == b = uniq bl 116 | otherwise = a : uniq bl 117 uniq l = l 118 119 subForms :: Form a -> [(FormKey, Form a)] 120 subForms f = subFormsFor formDataPost f ++ jsonSubForms f ++ subFormsFor formDataQuery f 121 122 jsonFormDatum :: Form a -> FormDatum 123 jsonFormDatum Form{ formJSON = j } = foldMap FormDatumJSON j 124 125 queryFormDatum :: Form a -> FormDatum 126 queryFormDatum Form{ formData = FormData{ formDataQuery = m }, formPathBS = p } = 127 foldMap (maybe FormDatumFlag FormDatumBS) $ Map.lookup p m 128 129 postFormDatum :: Form a -> FormDatum 130 postFormDatum Form{ formData = FormData{ formDataPost = m }, formPathBS = p } = 131 foldMap FormDatumBS $ Map.lookup p m 132 133 getFormDatum :: Form a -> FormDatum 134 getFormDatum form = postFormDatum form <> jsonFormDatum form <> queryFormDatum form 135 136 getFormFile :: Form a -> Maybe (FileInfo a) 137 getFormFile Form{ formData = FormData{ formDataFiles = f }, formPathBS = p } = Map.lookup p f