Link.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnicodeSyntax #-}

-- | Simplified model for RFC 8288 links.
--
-- Cf <https://tools.ietf.org/html/rfc8288> . .
module Imm.Link (
  Link (..),
  Relation (..),
  parseRelation,
  MediaType (..),
  parseMediaType,
  pattern MediaTypeRSS,
  pattern MediaTypeAtom,
  pattern MediaTypeApplicationXML,
  pattern MediaTypeTextXML,
  pattern MediaTypeHTML,
)
where

import Data.Aeson
import Text.Parsec (Stream, parse)
import Text.Parser.Char
import URI.ByteString.Extended

data Link = Link
  { _linkRelation ∷ Maybe Relation
  , _linkTitle ∷ Text
  , _linkType ∷ Maybe MediaType
  , _linkURI ∷ AnyURI
  }
  deriving (Eq, Generic, Ord, Show, Typeable)

linkOptions ∷ Options
linkOptions =
  defaultOptions
    { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_link")
    , omitNothingFields = True
    }

instance ToJSON Link where
  toJSON = genericToJSON linkOptions
  toEncoding = genericToEncoding linkOptions

instance FromJSON Link where
  parseJSON = genericParseJSON linkOptions

-- | Cf <https://www.iana.org/assignments/link-relations/link-relations.xhtml> .
data Relation = Alternate | Edit | Next | NoFollow | Replies | Self | OtherRelation Text
  deriving (Eq, Generic, Ord, Read, Show, Typeable)

instance ToJSON Relation where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Relation

parseRelation ∷ Text → Maybe Relation
parseRelation "alternate" = pure Alternate
parseRelation "edit" = pure Edit
parseRelation "next" = pure Next
parseRelation "nofollow" = pure NoFollow
parseRelation "replies" = pure Replies
parseRelation "self" = pure Self
parseRelation "" = Nothing
parseRelation t = pure $ OtherRelation t

-- | https://tools.ietf.org/html/rfc6838
-- https://en.wikipedia.org/wiki/Media_type
data MediaType = MediaType
  { _mediaType ∷ Text
  , _mediaSubtype ∷ Text
  , _mediaSuffix ∷ Text
  , _mediaParameters ∷ [Text]
  }
  deriving (Eq, Generic, Ord, Read, Show, Typeable)

mediaTypeOptions ∷ Options
mediaTypeOptions =
  defaultOptions
    { fieldLabelModifier = camelTo2 '_' . drop (length @[] "_media")
    , omitNothingFields = True
    }

instance ToJSON MediaType where
  toJSON = genericToJSON mediaTypeOptions
  toEncoding = genericToEncoding mediaTypeOptions

instance FromJSON MediaType where
  parseJSON = genericParseJSON mediaTypeOptions

parseMediaType ∷ Stream s Identity Char ⇒ s → Maybe MediaType
parseMediaType = either (const Nothing) pure . parse parser ""
 where
  parser = do
    t ← some $ noneOf "/"
    char '/'
    subtype ← some $ noneOf "+;"
    suffix ← optional $ char '+' >> some (noneOf ";")
    parameters ← many $ char ';' >> some (noneOf ";")

    return $ MediaType (toText t) (toText subtype) (toText $ fromMaybe mempty suffix) $ map toText parameters

pattern MediaTypeRSS ∷ [Text] → MediaType
pattern MediaTypeRSS parameters = MediaType "application" "rss" "xml" parameters

pattern MediaTypeAtom ∷ [Text] → MediaType
pattern MediaTypeAtom parameters = MediaType "application" "atom" "xml" parameters

pattern MediaTypeApplicationXML ∷ Text → [Text] → MediaType
pattern MediaTypeApplicationXML suffix parameters = MediaType "application" "xml" suffix parameters

pattern MediaTypeTextXML ∷ Text → [Text] → MediaType
pattern MediaTypeTextXML suffix parameters = MediaType "text" "xml" suffix parameters

pattern MediaTypeHTML ∷ Text → [Text] → MediaType
pattern MediaTypeHTML suffix parameters = MediaType "text" "html" suffix parameters