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