1 {-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables #-} 2 module Databrary.HTTP.Form.Deform 3 ( DeformT 4 , runDeform 5 , deformSync' 6 , (.:>) 7 , withSubDeforms 8 , deformOptional 9 , deformNonEmpty 10 , Deform(..) 11 , deformError 12 , deformError' 13 , deformMaybe' 14 , deformGuard 15 , deformCheck 16 , deformParse 17 , deformRead 18 , deformRequired 19 , textInteger 20 ) where 21 22 import Control.Applicative (Alternative(..), liftA2) 23 import Control.Arrow (first, second, (***), left) 24 import Control.Monad (MonadPlus(..), liftM, mapAndUnzipM, guard) 25 import Control.Monad.Reader (MonadReader(..), asks) 26 import Control.Monad.IO.Class (MonadIO(..)) 27 import Control.Monad.Trans.Class (MonadTrans(..)) 28 import Control.Monad.Trans.Control (MonadTransControl(..)) 29 import Control.Monad.Writer.Class (MonadWriter(..)) 30 import qualified Data.Aeson as JSON 31 import qualified Data.ByteString as BS 32 import qualified Data.ByteString.Char8 as BSC 33 import qualified Data.ByteString.UTF8 as BSU 34 import Data.Functor (($>)) 35 import qualified Data.HashMap.Strict as HM 36 import Data.Int (Int64, Int32, Int16) 37 import Data.Monoid ((<>)) 38 import qualified Data.Text as T 39 import qualified Data.Text.Encoding as TE 40 import qualified Data.Text.Read as TR 41 import Data.Time (fromGregorian) 42 import Data.Time.Format (parseTimeM, defaultTimeLocale) 43 import qualified Data.Vector as V 44 import qualified Database.PostgreSQL.Typed.Range as Range (Range(Empty)) 45 import qualified Network.URI as URI 46 import Network.Wai.Parse (FileInfo) 47 import Text.Read (readEither) 48 49 import Databrary.Model.URL 50 import Databrary.Model.Time 51 import Databrary.Model.Offset 52 import Databrary.Model.Segment 53 import Databrary.HTTP.Form 54 import Databrary.HTTP.Form.Errors 55 56 newtype DeformT f m a = DeformT { runDeformT :: Form f -> m (FormErrors, Maybe a) } 57 58 instance MonadTrans (DeformT f) where 59 lift m = DeformT $ \_ -> 60 liftM ((,) mempty . Just) m 61 62 instance MonadTransControl (DeformT f) where 63 type StT (DeformT f) a = (FormErrors, Maybe a) 64 liftWith f = DeformT $ \d -> 65 liftM ((,) mempty . Just) $ f $ \t -> runDeformT t d 66 restoreT m = DeformT $ \_ -> m 67 68 instance MonadIO m => MonadIO (DeformT f m) where 69 liftIO = lift . liftIO 70 71 instance Functor m => Functor (DeformT f m) where 72 fmap f (DeformT m) = DeformT $ \d -> 73 second (fmap f) `fmap` m d 74 75 instance Applicative m => Applicative (DeformT f m) where 76 pure a = DeformT $ \_ -> pure (mempty, Just a) 77 DeformT f <*> DeformT v = DeformT $ \d -> 78 liftA2 k (f d) (v d) where 79 k (ef, mf) (ev, mv) = (ef <> ev, mf <*> mv) 80 81 instance Monad m => Monad (DeformT f m) where 82 return = lift . return 83 DeformT x >>= f = DeformT $ \d -> do 84 (ex, mx) <- x d 85 case mx of 86 Nothing -> return (ex, Nothing) 87 Just vx -> first (ex <>) `liftM` runDeformT (f $! vx) d 88 fail = deformError' . T.pack 89 90 instance Monad m => MonadPlus (DeformT f m) where 91 mzero = DeformT $ \_ -> return (mempty, Nothing) 92 DeformT a `mplus` DeformT b = DeformT $ \d -> do 93 ar <- a d 94 case ar of 95 (er, Just _) | nullFormErrors er -> return ar 96 _ -> b d 97 98 instance (Applicative m, Monad m) => Alternative (DeformT f m) where 99 empty = mzero 100 (<|>) = mplus 101 102 instance Monad m => MonadReader (Form f) (DeformT f m) where 103 ask = DeformT $ \d -> return (mempty, Just d) 104 reader f = DeformT $ \d -> return (mempty, Just (f d)) 105 local f (DeformT a) = DeformT $ a . f 106 107 instance Monad m => MonadWriter FormErrors (DeformT f m) where 108 writer (a, e) = DeformT $ \_ -> return (e, Just a) 109 listen (DeformT a) = DeformT $ \d -> do 110 (e, r) <- a d 111 return (e, fmap (flip (,) e) r) 112 pass (DeformT a) = DeformT $ \q -> do 113 (e, mrf) <- a q 114 case mrf of 115 Just (r, f) -> return (f e, Just r) 116 Nothing -> return (e, Nothing) 117 118 runDeform :: Monad m => DeformT f m a -> FormData f -> m (Either FormErrors a) 119 runDeform (DeformT fa) = fmap fr . fa . initForm where 120 fr (e, Just a) | nullFormErrors e = Right a 121 fr (e, _) = Left e 122 123 deformSync' :: Monad m => DeformT f m a -> DeformT f m a 124 deformSync' (DeformT f) = DeformT $ fmap sync . f where 125 sync (e, a) = (e, guard (nullFormErrors e) >> a) 126 127 withSubDeform :: Monad m => FormKey -> DeformT f m a -> DeformT f m a 128 withSubDeform k (DeformT a) = DeformT $ fmap (first (unsubFormErrors k)) . a . subForm k 129 130 infixr 2 .:> 131 (.:>) :: Monad m => T.Text -> DeformT f m a -> DeformT f m a 132 (.:>) keyName subDeform = withSubDeform (FormField keyName) subDeform 133 134 withSubDeforms :: Monad m => (FormKey -> DeformT f m a) -> DeformT f m [a] 135 withSubDeforms s = DeformT $ 136 fmap (unsubFormsErrors *** sequence) . mapAndUnzipM (uncurry $ runDeformT . s) . subForms 137 138 deformErrorWith :: Monad m => Maybe a -> FormErrorMessage -> DeformT f m a 139 deformErrorWith r e = DeformT $ \_ -> return (singletonFormError e, r) 140 141 deformError :: Monad m => FormErrorMessage -> DeformT f m () 142 deformError = deformErrorWith (Just ()) 143 144 deformError' :: Monad m => FormErrorMessage -> DeformT f m a 145 deformError' = deformErrorWith Nothing 146 147 deformMaybe' :: Monad m => FormErrorMessage -> Maybe a -> DeformT f m a 148 deformMaybe' e = maybe (deformError' e) return 149 150 deformEither :: Monad m => a -> Either FormErrorMessage a -> DeformT f m a 151 deformEither def = either ((<$) def . deformError) return 152 153 deformGuard :: Monad m => FormErrorMessage -> Bool -> DeformT f m () 154 deformGuard _ True = return () 155 deformGuard e False = deformError e 156 157 deformCheck :: Monad m => FormErrorMessage -> (a -> Bool) -> a -> DeformT f m a 158 deformCheck e f v = (deformGuard e . f) v $> v 159 160 deformOptional :: Monad m => DeformT f m a -> DeformT f m (Maybe a) 161 deformOptional f = opt =<< asks formDatum where 162 opt FormDatumNone = return Nothing 163 opt _ = Just <$> f 164 165 deformNonEmpty :: Monad m => DeformT f m a -> DeformT f m (Maybe a) 166 deformNonEmpty f = opt =<< asks formDatum where 167 opt FormDatumNone = return Nothing 168 opt (FormDatumBS s) | BS.null s = return Nothing 169 opt (FormDatumJSON (JSON.String s)) | T.null s = return Nothing 170 opt (FormDatumJSON (JSON.Object o)) | HM.null o = return Nothing 171 opt (FormDatumJSON (JSON.Array v)) | V.null v = return Nothing 172 opt (FormDatumJSON JSON.Null) = return Nothing 173 opt _ = Just <$> f 174 175 deformParse :: Monad m => a -> (FormDatum -> Either FormErrorMessage a) -> DeformT f m a 176 deformParse def p = deformEither def =<< asks (p . formDatum) 177 178 deformParseJSON :: (Monad m, JSON.FromJSON a) => a -> (Maybe BS.ByteString -> Either FormErrorMessage a) -> DeformT f m a 179 deformParseJSON def p = do 180 d <- asks formDatum 181 case d of 182 FormDatumNone -> deformEither def $ p Nothing 183 FormDatumBS b -> deformEither def $ p $ Just b 184 FormDatumJSON j -> case JSON.fromJSON j of 185 JSON.Error e -> def <$ deformError (T.pack e) 186 JSON.Success r -> return r 187 FormDatumFlag -> deformEither def $ p Nothing 188 189 class Deform f a where 190 deform :: Monad m => DeformT f m a 191 192 instance Deform f FormDatum where 193 deform = asks formDatum 194 195 instance Deform f (Maybe (FileInfo f)) where 196 deform = asks formFile 197 198 instance Deform f (FileInfo f) where 199 deform = deformMaybe' "File upload required" =<< deform 200 201 instance Deform f JSON.Value where 202 deform = asks (j . formDatum) where 203 j FormDatumNone = JSON.Null 204 j (FormDatumJSON v) = v 205 j (FormDatumBS b) = JSON.String $ TE.decodeUtf8 b 206 j FormDatumFlag = JSON.Bool True 207 208 -- |'Text' fields are stripped of whitespace, while other string types are not. 209 instance Deform f T.Text where 210 deform = deformParse "" fv where 211 fv (FormDatumBS b) = return $ T.strip $ TE.decodeUtf8 b 212 fv (FormDatumJSON (JSON.String t)) = return $ T.strip t 213 fv (FormDatumJSON (JSON.Number n)) = return $ T.pack $ show n 214 fv (FormDatumJSON (JSON.Bool True)) = return "1" 215 fv (FormDatumJSON (JSON.Bool False)) = return "" 216 fv FormDatumNone = Left "This field is required" 217 fv _ = Left "String value required" 218 219 instance Deform f BS.ByteString where 220 deform = deformParse "" fv where 221 fv (FormDatumBS b) = return b 222 fv (FormDatumJSON (JSON.String t)) = return $ TE.encodeUtf8 t 223 fv (FormDatumJSON (JSON.Number n)) = return $ BSC.pack $ show n 224 fv (FormDatumJSON (JSON.Bool True)) = return "1" 225 fv (FormDatumJSON (JSON.Bool False)) = return "" 226 fv FormDatumNone = Left "This field is required" 227 fv _ = Left "String value required" 228 229 instance Deform f String where 230 deform = deformParse "" fv where 231 fv (FormDatumBS b) = return $ BSU.toString b 232 fv (FormDatumJSON (JSON.String t)) = return $ T.unpack t 233 fv (FormDatumJSON (JSON.Number n)) = return $ show n 234 fv (FormDatumJSON (JSON.Bool True)) = return "1" 235 fv (FormDatumJSON (JSON.Bool False)) = return "" 236 fv FormDatumNone = Left "This field is required" 237 fv _ = Left "String value required" 238 239 instance Deform f Bool where 240 deform = deformParse False fv where 241 fv FormDatumNone = return False 242 fv (FormDatumBS "true") = return True 243 fv (FormDatumBS "false") = return False 244 fv (FormDatumBS "on") = return True 245 fv (FormDatumBS "off") = return False 246 fv (FormDatumBS "1") = return True 247 fv (FormDatumBS "0") = return False 248 fv (FormDatumBS "") = return False 249 fv (FormDatumJSON (JSON.String "true")) = return True 250 fv (FormDatumJSON (JSON.String "false")) = return False 251 fv (FormDatumJSON (JSON.String "on")) = return True 252 fv (FormDatumJSON (JSON.String "off")) = return False 253 fv (FormDatumJSON (JSON.String "1")) = return True 254 fv (FormDatumJSON (JSON.String "0")) = return False 255 fv (FormDatumJSON (JSON.String "")) = return False 256 fv (FormDatumJSON (JSON.Number n)) = return $ n /= 0 257 fv (FormDatumJSON (JSON.Bool b)) = return b 258 fv (FormDatumJSON JSON.Null) = return False 259 fv FormDatumFlag = return True 260 fv _ = Left "Boolean value required" 261 262 instance Deform f Int where 263 deform = deformParse 0 fv where 264 fv (FormDatumBS b) = maybe (Left "Invalid integer") Right $ do 265 (i, r) <- BSC.readInt b 266 guard $ BS.null r 267 return i 268 fv (FormDatumJSON (JSON.String t)) = textInteger t 269 fv (FormDatumJSON (JSON.Number n)) = return $ round n 270 fv (FormDatumJSON (JSON.Bool True)) = return 1 271 fv (FormDatumJSON (JSON.Bool False)) = return 0 272 fv FormDatumNone = Left "This field is required" 273 fv _ = Left "Integer required" 274 275 instance Deform f Int64 where 276 deform = deformParse 0 fv where 277 fv (FormDatumBS b) = readParser $ BSC.unpack b 278 fv (FormDatumJSON (JSON.String t)) = textInteger t 279 fv (FormDatumJSON (JSON.Number n)) = return $ round n 280 fv (FormDatumJSON (JSON.Bool True)) = return 1 281 fv (FormDatumJSON (JSON.Bool False)) = return 0 282 fv FormDatumNone = Left "This field is required" 283 fv _ = Left "Integer required" 284 285 instance Deform f Int32 where 286 deform = deformParse 0 fv where 287 fv (FormDatumBS b) = readParser $ BSC.unpack b 288 fv (FormDatumJSON (JSON.String t)) = textInteger t 289 fv (FormDatumJSON (JSON.Number n)) = return $ round n 290 fv (FormDatumJSON (JSON.Bool True)) = return 1 291 fv (FormDatumJSON (JSON.Bool False)) = return 0 292 fv FormDatumNone = Left "This field is required" 293 fv _ = Left "Integer required" 294 295 instance Deform f Int16 where 296 deform = deformParse 0 fv where 297 fv (FormDatumBS b) = readParser $ BSC.unpack b 298 fv (FormDatumJSON (JSON.String t)) = textInteger t 299 fv (FormDatumJSON (JSON.Number n)) = return $ round n 300 fv (FormDatumJSON (JSON.Bool True)) = return 1 301 fv (FormDatumJSON (JSON.Bool False)) = return 0 302 fv FormDatumNone = Left "This field is required" 303 fv _ = Left "Integer required" 304 305 instance Deform f Date where 306 deform = maybe (deformErrorWith (Just (fromGregorian 1900 1 1)) "Invalid date (please use YYYY-MM-DD)") return . pd =<< deform where 307 pd t = pf "%Y-%-m-%-d" t <|> pf "%-m/%-d/%y" t 308 pf = parseTimeM True defaultTimeLocale 309 310 instance Deform f Offset where 311 deform = deformParseJSON 0 312 $ maybe (Left "Offset required") $ readParser . BSC.unpack 313 314 instance Deform f Segment where 315 deform = deformParseJSON (Segment Range.Empty) 316 $ maybe (Left "Segment required") $ readParser . BSC.unpack 317 318 instance Deform f URI where 319 deform = maybe (deformErrorWith (Just URI.nullURI) "Invalid URL") return . parseURL =<< deform 320 321 readParser :: Read a => String -> Either FormErrorMessage a 322 readParser = left T.pack . readEither 323 324 textInteger :: Integral a => T.Text -> Either FormErrorMessage a 325 textInteger t = case TR.signed TR.decimal t of 326 Left s -> Left (T.pack s) 327 Right (i,r) 328 | T.null r -> Right i 329 | otherwise -> Left ("Trailing \"" <> r `T.snoc` '"') 330 331 deformRead :: Monad m => Read a => a -> DeformT f m a 332 deformRead def = deformEither def . readParser =<< deform 333 334 deformRequired :: Monad m => T.Text -> DeformT f m T.Text 335 deformRequired = deformCheck "Required" (not . T.null)