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