gistfile1.hs

data TypeOne = TypeOne T.Text TypeTwo TypeThree
  deriving (Show)

data TypeTwo = TypeTwo Double
  deriving (Show)

data TypeThree = TypeThree Double
  deriving (Show)


newtype TheseT e m a = TheseT {
  runTheseT :: m (These e a)
}

instance Functor m => Functor (TheseT e m) where
  fmap f (TheseT m) = TheseT (fmap (fmap f) m)

instance (Monoid e, Applicative m) => Applicative (TheseT e m) where
  pure x = TheseT (pure (pure x))
  TheseT f <*> TheseT x = TheseT (liftA2 (<*>) f x)

instance (Monoid e, Monad m) => Monad (TheseT e m) where
  return x = TheseT (return (return x))
  m >>= f = TheseT $ do
    t <- runTheseT m
    case t of
      This  e   -> return (This e)
      That    x -> runTheseT (f x)
      These _ x -> do
        t' <- runTheseT (f x)
        return (t >> t')  -- this is where errors get concatenated

main :: IO ()
main = scotty 3000 $ do
  middleware logStdoutDev

  post "/pdor" $ do
    api_key <- param "api_key"
    input   <- param "input"

    typeOne <- runTheseT $ do
      result       <- (decode (pack input) :: Maybe Value)   >? ("Could not parse. Input JSON document is malformed", Nothing)
      typeTwoObj   <- (result ^? key "typeTwo")              >? ("Could not find key typeTwo in JSON document.", Just $ object [])
      typeThreeObj <- (result ^? key "typeThree")            >? ("Could not find key typeThree in JSON document.", Just $ object [])
      name         <- (result ^? key "name" . _String)       >? ("Could not find key name in JSON document.", Just "")
      typeTwo      <- eitherThese $ (flip (,) (Just $ TypeTwo 0))   $ prependLeft "Error when parsing TypeTwo: "  $ parseEither jsonTypeTwo typeTwoObj
      typeThree    <- eitherThese $ (flip (,) (Just $ TypeThree 0)) $ prependLeft "Error when parsing TypeThree: " $ parseEither jsonTypeThree typeThreeObj
      return $ TypeOne name typeTwo typeThree

    let successHandler _ = S.json $ object ["api_key" .= (api_key :: String), "message" .= ("success" :: String)]
        errorHandler errorMsgs = do
          _ <- status badRequest400
          S.json $ object ["errors" .=  errorMsgs]

    case typeOne of
      That  x    -> successHandler x
      These [] x -> successHandler x
      These es _ -> errorHandler es
      This  es   -> errorHandler es

prependLeft :: String -> Either String a -> Either String a
prependLeft msg (Left s) = Left (msg ++ s)
prependLeft _ x = x

jsonTypeTwo :: Value -> Parser TypeTwo
jsonTypeTwo (Object v) = TypeTwo <$> v .: "val"
jsonTypeTwo _ = fail $ "no data present for TypeTwo"

jsonTypeThree :: Value -> Parser TypeThree
jsonTypeThree (Object v) = TypeThree <$> v .: "val"
jsonTypeThree _ = fail $ "no data present for TypeThree"


-- | Convert Either into These, taking a Maybe default value.
-- If the default value is Nothing, then halt the computation,
-- if the default value is Just something we can continue.
eitherThese :: Monad m => (Either String a, Maybe a) -> TheseT [String] m a
eitherThese (Left err, Just def) = TheseT . return $ These [err] def
eitherThese (Left err, Nothing)  = TheseT . return $ This [err]
eitherThese (Right x, _)         = TheseT . return $ That x

-- | Continue with default if there is one
(>?) :: Monad m => Maybe a -> (String, Maybe a) -> TheseT [String] m a
(Just val) >? (_, _)          = TheseT . return $ That val
(Nothing)  >? (err, Just val) = TheseT . return $ These [err] val
(Nothing)  >? (err, Nothing)  = TheseT . return $ This [err]
{-# INLINE (>?) #-}