1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.HTTP.Form.Errors 3 ( FormErrorMessage 4 , FormErrors 5 , formErrors 6 , allFormErrors 7 , nullFormErrors 8 , unsubFormErrors 9 , unsubFormsErrors 10 , singletonFormError 11 , subFormErrors 12 , subFormsErrors 13 , setSubFormErrors 14 ) where 15 16 import Control.Arrow (first) 17 import qualified Data.Aeson as JSON 18 import qualified Data.HashMap.Strict as HM 19 import qualified Data.Map.Strict as Map 20 import Data.Monoid ((<>)) 21 import qualified Data.Text as T 22 23 import Databrary.Has (view) 24 import Databrary.HTTP.Form 25 26 type FormErrorMessage = T.Text 27 data FormErrors = FormErrors 28 { formErrors :: [FormErrorMessage] 29 , _subFormErrors :: Map.Map FormKey FormErrors 30 } 31 32 instance Monoid FormErrors where 33 mempty = FormErrors [] Map.empty 34 mappend (FormErrors t1 s1) (FormErrors t2 s2) = 35 FormErrors (t1 ++ t2) (Map.unionWith mappend s1 s2) 36 37 nullFormErrors :: FormErrors -> Bool 38 nullFormErrors (FormErrors [] s) = Map.null s 39 nullFormErrors _ = False 40 41 unsubFormErrors :: FormKey -> FormErrors -> FormErrors 42 unsubFormErrors k e 43 | nullFormErrors e = mempty 44 | otherwise = FormErrors [] $ Map.singleton k e 45 46 unsubFormsErrors :: [FormErrors] -> FormErrors 47 unsubFormsErrors = FormErrors [] . sf 0 where 48 sf _ [] = Map.empty 49 sf i (e:l) 50 | nullFormErrors e = m 51 | otherwise = Map.insert (FormIndex i) e m 52 where m = sf (succ i) l 53 54 subFormErrors :: FormKey -> FormErrors -> FormErrors 55 subFormErrors k (FormErrors _ s) = Map.findWithDefault mempty k s 56 57 subFormsErrors :: FormErrors -> [FormErrors] 58 subFormsErrors (FormErrors _ s) = zs 0 (maybe id ((:) . (,) (FormIndex 0)) i0 $ Map.toAscList is) where 59 zs _ [] = [] 60 zs i l@((FormIndex j,e):r) 61 | i == j = e : zs (succ i) r 62 | i < j = mempty : zs (succ i) l 63 zs _ _ = error "subFormsErrors" 64 (_, i0, is) = Map.splitLookup (FormIndex 0) s 65 66 setSubFormErrors :: FormErrors -> FormKey -> FormErrors -> FormErrors 67 setSubFormErrors (FormErrors e m) k s = FormErrors e $ 68 (if nullFormErrors s then Map.delete k else Map.insert k s) m 69 70 singletonFormError :: FormErrorMessage -> FormErrors 71 singletonFormError e = FormErrors [e] Map.empty 72 73 allFormErrors :: FormErrors -> [(FormPath, FormErrorMessage)] 74 allFormErrors (FormErrors l m) = 75 map ((,) []) l ++ Map.foldMapWithKey (\k -> map (first (k:)) . allFormErrors) m 76 77 subToJSON :: JSON.Object -> Map.Map FormKey FormErrors -> JSON.Value 78 subToJSON z = JSON.Object . Map.foldrWithKey (\k -> HM.insert (view k) . JSON.toJSON) z 79 80 subToEncoding :: Map.Map FormKey FormErrors -> JSON.Series 81 subToEncoding = Map.foldMapWithKey ((JSON..=) . view) 82 83 topToJSON :: [FormErrorMessage] -> JSON.Value 84 topToJSON [] = JSON.Null 85 topToJSON [e] = JSON.toJSON e 86 topToJSON l = JSON.toJSON l 87 88 instance JSON.ToJSON FormErrors where 89 toJSON (FormErrors [] m) = 90 subToJSON HM.empty m 91 toJSON (FormErrors l m) 92 | Map.null m = top 93 | otherwise = subToJSON (HM.singleton "" top) m 94 where top = topToJSON l 95 toEncoding (FormErrors [] m) = 96 JSON.pairs $ subToEncoding m 97 toEncoding (FormErrors l m) 98 | Map.null m = JSON.toEncoding top 99 | otherwise = JSON.pairs $ "" JSON..= top <> subToEncoding m 100 where top = topToJSON l