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)