{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Autodocodec.Multipart where

import Autodocodec
import Data.Aeson as JSON
import Data.Aeson.Types as JSON
import qualified Data.ByteString.Lazy as LB
import Data.Foldable
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as V
import Servant.Multipart as Servant
import Servant.Multipart.API as Servant

toMultipartViaCodec :: forall a tag. HasObjectCodec a => a -> MultipartData tag
toMultipartViaCodec = toMultipartVia (objectCodec @a)

toMultipartVia :: ObjectCodec a void -> a -> MultipartData tag
toMultipartVia = flip go
  where
    go :: a -> ObjectCodec a void -> MultipartData tag
    go a = \case
      BimapCodec _ to c -> go (to a) c
      EitherCodec _ c1 c2 -> case a of
        Left a1 -> go a1 c1
        Right a2 -> go a2 c2
      DiscriminatedUnionCodec discriminator encoding _ ->
        let (discriminatorValue, c) = encoding a
         in mappendMultipartData
              ( MultipartData
                  { inputs = [Input discriminator discriminatorValue],
                    files = []
                  }
              )
              (go a c)
      RequiredKeyCodec key vc _ ->
        MultipartData
          { inputs = map (Input key) (goValue a vc),
            files = []
          }
      OptionalKeyCodec key vc _ ->
        MultipartData
          { inputs = do
              a' <- maybeToList a
              v <- goValue a' vc
              pure $ Input key v,
            files = []
          }
      OptionalKeyWithDefaultCodec key vc _ _ ->
        MultipartData
          { inputs = map (Input key) (goValue a vc),
            files = []
          }
      OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ ->
        MultipartData
          { inputs =
              if a == defaultValue
                then []
                else map (Input key) (goValue a vc),
            files = []
          }
      PureCodec _ -> memptyMultipartData
      ApCodec oc1 oc2 -> mappendMultipartData (go a oc1) (go a oc2)

    goValue :: a -> ValueCodec a void -> [Text]
    goValue a = \case
      BimapCodec _ to vc -> goValue (to a) vc
      EitherCodec _ c1 c2 -> case a of
        Left a1 -> goValue a1 c1
        Right a2 -> goValue a2 c2
      CommentCodec _ vc -> goValue a vc
      ArrayOfCodec _ vc -> map (`goSingleValue` vc) (toList a)
      vc -> [goSingleValue a vc]

    goSingleValue :: a -> ValueCodec a void -> Text
    goSingleValue a = \case
      BimapCodec _ to vc -> goSingleValue (to a) vc
      EitherCodec _ c1 c2 -> case a of
        Left a1 -> goSingleValue a1 c1
        Right a2 -> goSingleValue a2 c2
      CommentCodec _ vc -> goSingleValue a vc
      NullCodec -> "null"
      BoolCodec _ ->
        case a of
          True -> "True"
          False -> "False"
      StringCodec _ -> a
      vc ->
        let value = toJSONVia vc a
         in case value of
              JSON.String t -> t
              _ -> TE.decodeUtf8 (LB.toStrict (JSON.encode value))

memptyMultipartData :: MultipartData tag
memptyMultipartData =
  MultipartData
    { inputs = [],
      files = []
    }

mappendMultipartData :: MultipartData tag -> MultipartData tag -> MultipartData tag
mappendMultipartData mpd1 mpd2 =
  MultipartData
    { inputs = inputs mpd1 ++ inputs mpd2,
      files = files mpd1 ++ files mpd2
    }

instance HasObjectCodec a => Servant.ToMultipart tag (Autodocodec a) where
  toMultipart = toMultipartViaCodec . unAutodocodec

fromMultipartViaCodec :: forall a tag. HasObjectCodec a => MultipartData tag -> Either String a
fromMultipartViaCodec = fromMultipartVia (objectCodec @a)

fromMultipartVia :: ObjectCodec void a -> MultipartData tag -> Either String a
fromMultipartVia = flip go
  where
    go :: MultipartData tag -> ObjectCodec void a -> Either String a
    go mpd = \case
      BimapCodec from _ c -> go mpd c >>= from
      EitherCodec u c1 c2 -> case u of
        PossiblyJointUnion ->
          case go mpd c1 of
            Right l -> pure (Left l)
            Left err1 -> case go mpd c2 of
              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
              Right r -> pure (Right r)
        DisjointUnion ->
          case (go mpd c1, go mpd c2) of
            (Left _, Right r) -> pure (Right r)
            (Right l, Left _) -> pure (Left l)
            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
            (Left lErr, Left rErr) ->
              Left $
                unlines
                  [ "Both branches of a disjoint union failed: ",
                    unwords ["Left:  ", lErr],
                    unwords ["Right: ", rErr]
                  ]
      DiscriminatedUnionCodec discriminator _ m -> do
        discriminatorValue <- lookupInput discriminator mpd
        case HashMap.lookup discriminatorValue m of
          Nothing -> Left $ "Unexpected discriminator value: " <> show discriminatorValue
          Just (_, c) -> go mpd c
      RequiredKeyCodec key vc _ -> do
        values <- lookupLInput key mpd
        goValue values vc
      OptionalKeyCodec key vc _ -> do
        values <- lookupLInput key mpd
        case values of
          [] -> pure Nothing
          _ -> Just <$> goValue values vc
      OptionalKeyWithDefaultCodec key vc defaultValue _ -> do
        values <- lookupLInput key mpd
        case values of
          [] -> pure defaultValue
          _ -> goValue values vc
      OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ -> do
        values <- lookupLInput key mpd
        case values of
          [] -> pure defaultValue
          _ -> goValue values vc
      PureCodec v -> pure v
      ApCodec ocf oca -> go mpd ocf <*> go mpd oca

    goValue :: [Text] -> ValueCodec void a -> Either String a
    goValue ts = \case
      BimapCodec from _ c -> goValue ts c >>= from
      EitherCodec u c1 c2 -> case u of
        PossiblyJointUnion ->
          case goValue ts c1 of
            Right l -> pure (Left l)
            Left err1 -> case goValue ts c2 of
              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
              Right r -> pure (Right r)
        DisjointUnion ->
          case (goValue ts c1, goValue ts c2) of
            (Left _, Right r) -> pure (Right r)
            (Right l, Left _) -> pure (Left l)
            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
            (Left lErr, Left rErr) ->
              Left $
                unlines
                  [ "Both branches of a disjoint union failed: ",
                    unwords ["Left:  ", lErr],
                    unwords ["Right: ", rErr]
                  ]
      ReferenceCodec _ vc -> goValue ts vc
      CommentCodec _ c -> goValue ts c
      ArrayOfCodec _ vc -> V.fromList <$> mapM (`goSingleValue` vc) (toList ts)
      vc -> case ts of
        [t] -> goSingleValue t vc
        _ -> Left "Expected exactly one value."

    goSingleValue :: Text -> ValueCodec void a -> Either String a
    goSingleValue t = \case
      BimapCodec from _ c -> goSingleValue t c >>= from
      EitherCodec u c1 c2 -> case u of
        PossiblyJointUnion ->
          case goSingleValue t c1 of
            Right l -> pure (Left l)
            Left err1 -> case goSingleValue t c2 of
              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
              Right r -> pure (Right r)
        DisjointUnion ->
          case (goSingleValue t c1, goSingleValue t c2) of
            (Left _, Right r) -> pure (Right r)
            (Right l, Left _) -> pure (Left l)
            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
            (Left lErr, Left rErr) ->
              Left $
                unlines
                  [ "Both branches of a disjoint union failed: ",
                    unwords ["Left:  ", lErr],
                    unwords ["Right: ", rErr]
                  ]
      CommentCodec _ c -> goSingleValue t c
      ReferenceCodec _ vc -> goSingleValue t vc
      NullCodec -> case t of
        "null" -> Right ()
        _ -> Left $ "not 'null': " <> show t
      BoolCodec _ -> case t of
        "false" -> Right False
        "False" -> Right False
        "true" -> Right True
        "True" -> Right True
        _ -> Left $ "Unknown bool: " <> show t
      StringCodec _ -> Right t
      vc -> case JSON.parseEither (parseJSONVia vc) (JSON.String t) of
        Right a -> Right a
        Left _ -> do
          value <- JSON.eitherDecode (LB.fromStrict (TE.encodeUtf8 t))
          JSON.parseEither (parseJSONVia vc) value

lookupMInput :: Text -> MultipartData tag -> Either String (Maybe Text)
lookupMInput iname = Right . fmap iValue . find ((== iname) . iName) . inputs

lookupLInput :: Text -> MultipartData tag -> Either String [Text]
lookupLInput iname = Right . map iValue . filter ((== iname) . iName) . inputs

instance HasObjectCodec a => Servant.FromMultipart tag (Autodocodec a) where
  fromMultipart = fmap Autodocodec . fromMultipartViaCodec