Very unpolished (and likely to change) stab at content negotiation in HTTP4S

ContentNegotiate.scala

package shajra.extn.http4s.core


import org.http4s.
  { Charset, CharsetRange, ContentCoding, EntityEncoder, HasQValue, Header,
    HeaderKey, Headers, LanguageTag, MediaRange, MediaType, QValue }
import org.http4s.headers.
  { Accept, `Accept-Encoding`, `Accept-Charset`, `Accept-Language`,
    `Content-Encoding`, `Content-Type` }
import org.http4s.util.CaseInsensitiveString
import scalaz.
  { Applicative, Cont, Contravariant, Foldable, Functor, IList, Maybe,
    MonadPlus, NonEmptyList, Order, Ordering, Semigroup }
import scalaz.Id.Id
import scalaz.Maybe.{ Empty, Just, maybeFirstMonoid }
import scalaz.Tags.First
import scalaz.concurrent.Task
import scalaz.std.anyVal._
import scalaz.std.function._
import scalaz.std.list._
import scalaz.std.option._
import scalaz.std.string._
import scalaz.syntax.enum._
import scalaz.syntax.maybe._
import scalaz.syntax.monadPlus._
import scalaz.syntax.semigroup._
import scalaz.syntax.std.option._
import scalaz.syntax.traverse._

import ContentNegotiate.{ Supported, Requested, Encode }
import ContentNegotiate.Implicits._


final class ContentNegotiate[A] private
    (val supported: Supported,
      private[ContentNegotiate] val encode: Requested => A => Maybe[Encode[A]]) {

  def toEntity(request: Headers, a: A): Maybe[Encode[A]] =
    (selectMedia(request).toEphemeralStream |@|
         selectEncoding(request).toEphemeralStream |@|
         selectCharset(request).toEphemeralStream |@|
         selectLanguage(request).toEphemeralStream)
       .apply(Requested)
       .map { encodeFull(_)(a) }
       .findM[Id] { _.isJust }
       .toMaybe
       .join

  def ++(next: ContentNegotiate[A]): ContentNegotiate[A] =
    new ContentNegotiate[A](
      supported |+| next.supported,
      r => a => {
        First.unwrap(encode(r)(a).first |+| next.encode(r)(a).first)
      })

  def contramap[B](f: B => A): ContentNegotiate[B] =
    new ContentNegotiate[B](
      supported,
      req => a => encode(req)(f(a)))

  private def encodeFull(req: Requested): A => Maybe[Encode[A]] = {
    val headersBase =
      Headers.empty.put(
        `Content-Type`(req.media, req.charset.toOption),
        `Content-Encoding`(req.encoding))
    val headers =
      req
        .langs
        .toNel
        .map { tags => headersBase put `Content-Language`(tags) }
        .getOrElse(headersBase)
    Functor[A => ?]
      .compose[Maybe]
      .map(encode(req)) { case (task, moreHeaders) =>
        (task, headers ++ moreHeaders)
      }
  }

  private def selectMedia(headers: Headers): IList[MediaType] =
    select(reqMedia(headers), supported.media.toIList) {
      (allRequested, supportedMedia) => req =>
        req match {
          case (r: MediaType) =>
            r.mainType == supportedMedia.mainType &&
              r.subType == supportedMedia.subType &&
              r.extensions == supportedMedia.extensions
          case (r: MediaRange) =>
            if (r.mainType == MediaRange.`*/*`.mainType) true  // */
            else r.mainType == supportedMedia.mainType
          case _ => false
        }
    }

  private def selectEncoding(headers: Headers): IList[ContentCoding] =
    select(reqEncoding(headers), supported.encoding :+ ContentCoding.identity) {
      (allRequested, supportedEncoding) => req =>
        if (req.coding == ContentCoding.*.coding)
          allRequested.all { _.coding != supportedEncoding.coding }
        else req.coding == supportedEncoding.coding
    }

  private def selectCharset(headers: Headers): IList[Maybe[Charset]] =
    select(
        reqCharset(headers),
        supported.charset.just.sequence :+ Maybe.empty) {
      (allRequested, supportedCharset) => req =>
        (req, supportedCharset) match {
          case (CharsetRange.*(_), Just(s)) =>
            allRequested.all {
              case CharsetRange.*(_) => true
              case CharsetRange.Atom(r, _) => r != s
            }
          case (CharsetRange.*(_), Empty()) => true
          case (CharsetRange.Atom(r, _), Just(s)) => r == s
          case (CharsetRange.Atom(_, _), Empty()) => false
        }
    }

  private def selectLanguage(headers: Headers): IList[IList[LanguageTag]] =
    chooseAll(select(
        reqLanguage(headers),
        supported.langs.just.sequence :+ Maybe.empty) {
      (allRequested, supportedLangs) => req =>
        supportedLangs match {
          case Just(s) if req.primaryTag == LanguageTag.*.primaryTag =>
            allRequested.all { ! selectsLang(_, s) }
          case Empty() if req.primaryTag == LanguageTag.*.primaryTag => true
          case Just(s) if req.primaryTag != LanguageTag.*.primaryTag =>
            selectsLang(req, s)
          case Empty() if req.primaryTag != LanguageTag.*.primaryTag => false
        }
    }).map { _ >>= { _.toIList } }

  private def select[B : QValued : Order, C]
      (requested: NonEmptyList[B], supported: IList[C])
      (pick: (NonEmptyList[B], C) => B => Boolean)
      : IList[C] =
    supported
      .flatMap { c =>
        val relevant = requested.toIList filter pick(requested, c)
        val max = relevant.maximum
        val min =
          relevant.minimum.filter { b => QValued.qValue(b) > QValue.Zero }
        (max |@| min)((m, _) => (m, c)).toIList }
      .sortBy { _._1 }
      .map { _._2 }

  private def reqMedia(headers: Headers): NonEmptyList[MediaRange] =
    headers
      .get(Accept)
      .map { _.values }
      .getOrElse(NonEmptyList(MediaRange.`*/*`))  // */

  private def reqEncoding(headers: Headers): NonEmptyList[ContentCoding] =
    headers
      .get(`Accept-Encoding`)
      .map { ae => addIdentityMaybe(ae.values) }
      .getOrElse(NonEmptyList(ContentCoding.identity, ContentCoding.*))

  private def reqCharset(headers: Headers): NonEmptyList[CharsetRange] =
    headers
      .get(`Accept-Charset`)
      .map { ac => add8859Maybe(ac.values) }
      .getOrElse(NonEmptyList(CharsetRange.*))

  private def reqLanguage(headers: Headers): NonEmptyList[LanguageTag] =
    headers
      .get(`Accept-Language`)
      .map(_.values)
      .getOrElse(NonEmptyList(LanguageTag.*))

  private def selectsLang(range: LanguageTag, tag: LanguageTag): Boolean = {
    val r = IList.apply(range.primaryTag +: range.subTags: _*)
    val t = IList.apply(tag.primaryTag +: tag.subTags: _*)
    t startsWith r
  }

  private def addIdentityMaybe
      (ccs: NonEmptyList[ContentCoding]): NonEmptyList[ContentCoding] =
    addMaybe(ccs, ContentCoding.identity withQValue QValue.One) {
      case ContentCoding(c, _)
         if c == ContentCoding.*.coding ||
           c == ContentCoding.identity.coding => true
    }

  private def add8859Maybe
      (crs: NonEmptyList[CharsetRange]): NonEmptyList[CharsetRange] =
    addMaybe(crs, Charset.`ISO-8859-1` withQuality QValue.One) {
      case CharsetRange.* => true
      case CharsetRange.Atom(Charset.`ISO-8859-1`, _) => true
    }

  private def addMaybe[B]
      (bs: NonEmptyList[B], otherwise: B)(f: PartialFunction[B, Boolean])
      : NonEmptyList[B] =
    if (bs any f.orElse { case _ => false }) bs
    else bs append NonEmptyList(otherwise)

  private def chooseAll[B](list: IList[B]): IList[IList[B]] =
    (list.length |-> 1).toIList >>= choose(list)

  private def choose[B](list: IList[B])(n: Int): IList[IList[B]] =
    (list, n) match {
      case (_, 0) => IList(IList())
      case (scalaz.INil(), _) => IList()
      case (scalaz.ICons(x, xs), k) =>
        choose(xs)(k-1).map(x +: _) ++ choose(xs)(k)
    }

}


object ContentNegotiate {

  def apply[A]
      (supported: Supported, encode: Requested => A => Maybe[Encode[A]])
      : ContentNegotiate[A] =
    new ContentNegotiate(supported, encode)

  def fromEncoder[A, B : EntityEncoder]
      (supported: Supported)
      (f: A => B)
      (encode: (Requested, A) => Maybe[Headers])
      : ContentNegotiate[A] = {
    val encoder = EntityEncoder[B] contramap f
    def result(a: A)(moreHeaders: Headers) =
      (encoder.toEntity(a), encoder.headers ++ moreHeaders)
    new ContentNegotiate(
      supported,
      req => a => encode(req, a) map result(a))
  }

  type Encode[A] = (Task[EntityEncoder.Entity], Headers)

  final case class Supported
      (media: NonEmptyList[MediaType],
        encoding: IList[ContentCoding],
        charset: IList[Charset],
        langs: IList[LanguageTag]) {
    def ++(more: Supported): Supported =
      Supported(
        media |+| more.media,
        encoding |+| more.encoding,
        charset |+| more.charset,
        langs |+| more.langs)
   }

  object Supported {
    implicit val semigroup: Semigroup[Supported] =
      new Semigroup[Supported] {
        def append(s1: Supported, s2: => Supported) = s1 ++ s2
     }
  }

  final case class Requested
      (media: MediaType,
        encoding: ContentCoding,
        charset: Maybe[Charset],
        langs: IList[LanguageTag])

  implicit def semigroup[A]: Semigroup[ContentNegotiate[A]] =
    new Semigroup[ContentNegotiate[A]] {
      def append(cn1: ContentNegotiate[A], cn2: => ContentNegotiate[A]) =
        cn1 ++ cn2
    }

  implicit val contravariant: Contravariant[ContentNegotiate] =
    new Contravariant[ContentNegotiate] {
      def contramap[A, B](a: ContentNegotiate[A])(f: B => A) = a contramap f
    }

  trait Implicits {

    implicit val mediaRangeOrder: Order[MediaRange] =
      IList(qOrder[MediaRange], mediaRangeMainOrder, mediaRangeTypeOrder).suml

    implicit val charsetRangeOrder: Order[CharsetRange] = qOrder[CharsetRange]
    implicit val contentCodingOrder: Order[ContentCoding] = qOrder[ContentCoding]
    implicit val languageTagOrder: Order[LanguageTag] = qOrder[LanguageTag]

    private def qOrder[A : QValued]: Order[A] =
      Order.order[A] { (a1, a2) =>
        Order[QValue].order(QValued.qValue(a1), QValued.qValue(a2))
      }

    private val mediaRangeMainOrder: Order[MediaRange] =
      Order.order[MediaRange] { (r1, r2) =>
        (r1.mainType, r2.mainType) match {
          case ("*", "*") => Ordering.EQ
          case ("*", _) => Ordering.LT
          case (_, "*") => Ordering.GT
          case (_, _) => Ordering.EQ
        }
      }

    // DESIGN: HTTP4S's design seems to force tag-checking
    @SuppressWarnings(
      Array(
        "org.brianmckenna.wartremover.warts.AsInstanceOf",
        "org.brianmckenna.wartremover.warts.IsInstanceOf"))
    private val mediaRangeTypeOrder: Order[MediaRange] =
      Order.order[MediaRange] {
        case (t1: MediaType, t2: MediaType) =>
          Order[Int].contramap[MediaType](_.extensions.size).order(t1, t2)
        case (r: MediaRange, t: MediaType) => Ordering.LT
        case (t: MediaType, r: MediaRange) => Ordering.GT
        case _ => Ordering.EQ
      }

  }

  object Implicits extends Implicits

}


trait QValued[A] {
  def qValue(a: A): QValue
}


object QValued {

  def by[A](f: A => QValue): QValued[A] =
    new QValued[A] { def qValue(a: A) = f(a) }

  def qValue[A: QValued](a: A)(implicit ev: QValued[A]) = ev.qValue(a)

  implicit val languageTag: QValued[LanguageTag] = by[LanguageTag] { _.q }

  implicit def hasQValue[A <: HasQValue]: QValued[A] = by[A] { _.qValue }

}


object `Content-Language` extends HeaderKey.Recurring {

  type HeaderT = `Content-Language`

  def matchHeader(header: Header): Option[HeaderT] =
    `Content-Language` from Headers(header)

  def name = CaseInsensitiveString("Content-Language")

}


final case class `Content-Language`
    (values: NonEmptyList[LanguageTag]) extends Header.RecurringRenderable {
  def key = `Content-Language`
  type Value = LanguageTag
}