{-# 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
  { Link -> Maybe Relation
_linkRelation ∷ Maybe Relation
  , Link -> Text
_linkTitle ∷ Text
  , Link -> Maybe MediaType
_linkType ∷ Maybe MediaType
  , Link -> AnyURI
_linkURI ∷ AnyURI
  }
  deriving (Link -> Link -> Bool
(Link -> Link -> Bool) -> (Link -> Link -> Bool) -> Eq Link
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Link -> Link -> Bool
== :: Link -> Link -> Bool
$c/= :: Link -> Link -> Bool
/= :: Link -> Link -> Bool
Eq, (forall x. Link -> Rep Link x)
-> (forall x. Rep Link x -> Link) -> Generic Link
forall x. Rep Link x -> Link
forall x. Link -> Rep Link x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Link -> Rep Link x
from :: forall x. Link -> Rep Link x
$cto :: forall x. Rep Link x -> Link
to :: forall x. Rep Link x -> Link
Generic, Eq Link
Eq Link =>
(Link -> Link -> Ordering)
-> (Link -> Link -> Bool)
-> (Link -> Link -> Bool)
-> (Link -> Link -> Bool)
-> (Link -> Link -> Bool)
-> (Link -> Link -> Link)
-> (Link -> Link -> Link)
-> Ord Link
Link -> Link -> Bool
Link -> Link -> Ordering
Link -> Link -> Link
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Link -> Link -> Ordering
compare :: Link -> Link -> Ordering
$c< :: Link -> Link -> Bool
< :: Link -> Link -> Bool
$c<= :: Link -> Link -> Bool
<= :: Link -> Link -> Bool
$c> :: Link -> Link -> Bool
> :: Link -> Link -> Bool
$c>= :: Link -> Link -> Bool
>= :: Link -> Link -> Bool
$cmax :: Link -> Link -> Link
max :: Link -> Link -> Link
$cmin :: Link -> Link -> Link
min :: Link -> Link -> Link
Ord, Int -> Link -> ShowS
[Link] -> ShowS
Link -> [Char]
(Int -> Link -> ShowS)
-> (Link -> [Char]) -> ([Link] -> ShowS) -> Show Link
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Link -> ShowS
showsPrec :: Int -> Link -> ShowS
$cshow :: Link -> [Char]
show :: Link -> [Char]
$cshowList :: [Link] -> ShowS
showList :: [Link] -> ShowS
Show, Typeable)

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

instance ToJSON Link where
  toJSON :: Link -> Value
toJSON = Options -> Link -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
linkOptions
  toEncoding :: Link -> Encoding
toEncoding = Options -> Link -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
linkOptions

instance FromJSON Link where
  parseJSON :: Value -> Parser Link
parseJSON = Options -> Value -> Parser Link
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
linkOptions

-- | Cf <https://www.iana.org/assignments/link-relations/link-relations.xhtml> .
data Relation = Alternate | Edit | Next | NoFollow | Replies | Self | OtherRelation Text
  deriving (Relation -> Relation -> Bool
(Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool) -> Eq Relation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Relation -> Relation -> Bool
== :: Relation -> Relation -> Bool
$c/= :: Relation -> Relation -> Bool
/= :: Relation -> Relation -> Bool
Eq, (forall x. Relation -> Rep Relation x)
-> (forall x. Rep Relation x -> Relation) -> Generic Relation
forall x. Rep Relation x -> Relation
forall x. Relation -> Rep Relation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Relation -> Rep Relation x
from :: forall x. Relation -> Rep Relation x
$cto :: forall x. Rep Relation x -> Relation
to :: forall x. Rep Relation x -> Relation
Generic, Eq Relation
Eq Relation =>
(Relation -> Relation -> Ordering)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Relation)
-> (Relation -> Relation -> Relation)
-> Ord Relation
Relation -> Relation -> Bool
Relation -> Relation -> Ordering
Relation -> Relation -> Relation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Relation -> Relation -> Ordering
compare :: Relation -> Relation -> Ordering
$c< :: Relation -> Relation -> Bool
< :: Relation -> Relation -> Bool
$c<= :: Relation -> Relation -> Bool
<= :: Relation -> Relation -> Bool
$c> :: Relation -> Relation -> Bool
> :: Relation -> Relation -> Bool
$c>= :: Relation -> Relation -> Bool
>= :: Relation -> Relation -> Bool
$cmax :: Relation -> Relation -> Relation
max :: Relation -> Relation -> Relation
$cmin :: Relation -> Relation -> Relation
min :: Relation -> Relation -> Relation
Ord, ReadPrec [Relation]
ReadPrec Relation
Int -> ReadS Relation
ReadS [Relation]
(Int -> ReadS Relation)
-> ReadS [Relation]
-> ReadPrec Relation
-> ReadPrec [Relation]
-> Read Relation
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Relation
readsPrec :: Int -> ReadS Relation
$creadList :: ReadS [Relation]
readList :: ReadS [Relation]
$creadPrec :: ReadPrec Relation
readPrec :: ReadPrec Relation
$creadListPrec :: ReadPrec [Relation]
readListPrec :: ReadPrec [Relation]
Read, Int -> Relation -> ShowS
[Relation] -> ShowS
Relation -> [Char]
(Int -> Relation -> ShowS)
-> (Relation -> [Char]) -> ([Relation] -> ShowS) -> Show Relation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Relation -> ShowS
showsPrec :: Int -> Relation -> ShowS
$cshow :: Relation -> [Char]
show :: Relation -> [Char]
$cshowList :: [Relation] -> ShowS
showList :: [Relation] -> ShowS
Show, Typeable)

instance ToJSON Relation where
  toEncoding :: Relation -> Encoding
toEncoding = Options -> Relation -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

instance FromJSON Relation

parseRelation ∷ Text → Maybe Relation
parseRelation :: Text -> Maybe Relation
parseRelation Text
"alternate" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
Alternate
parseRelation Text
"edit" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
Edit
parseRelation Text
"next" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
Next
parseRelation Text
"nofollow" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
NoFollow
parseRelation Text
"replies" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
Replies
parseRelation Text
"self" = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
Self
parseRelation Text
"" = Maybe Relation
forall a. Maybe a
Nothing
parseRelation Text
t = Relation -> Maybe Relation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> Maybe Relation) -> Relation -> Maybe Relation
forall a b. (a -> b) -> a -> b
$ Text -> Relation
OtherRelation Text
t

-- | https://tools.ietf.org/html/rfc6838
-- https://en.wikipedia.org/wiki/Media_type
data MediaType = MediaType
  { MediaType -> Text
_mediaType ∷ Text
  , MediaType -> Text
_mediaSubtype ∷ Text
  , MediaType -> Text
_mediaSuffix ∷ Text
  , MediaType -> [Text]
_mediaParameters ∷ [Text]
  }
  deriving (MediaType -> MediaType -> Bool
(MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool) -> Eq MediaType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MediaType -> MediaType -> Bool
== :: MediaType -> MediaType -> Bool
$c/= :: MediaType -> MediaType -> Bool
/= :: MediaType -> MediaType -> Bool
Eq, (forall x. MediaType -> Rep MediaType x)
-> (forall x. Rep MediaType x -> MediaType) -> Generic MediaType
forall x. Rep MediaType x -> MediaType
forall x. MediaType -> Rep MediaType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MediaType -> Rep MediaType x
from :: forall x. MediaType -> Rep MediaType x
$cto :: forall x. Rep MediaType x -> MediaType
to :: forall x. Rep MediaType x -> MediaType
Generic, Eq MediaType
Eq MediaType =>
(MediaType -> MediaType -> Ordering)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> MediaType)
-> (MediaType -> MediaType -> MediaType)
-> Ord MediaType
MediaType -> MediaType -> Bool
MediaType -> MediaType -> Ordering
MediaType -> MediaType -> MediaType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MediaType -> MediaType -> Ordering
compare :: MediaType -> MediaType -> Ordering
$c< :: MediaType -> MediaType -> Bool
< :: MediaType -> MediaType -> Bool
$c<= :: MediaType -> MediaType -> Bool
<= :: MediaType -> MediaType -> Bool
$c> :: MediaType -> MediaType -> Bool
> :: MediaType -> MediaType -> Bool
$c>= :: MediaType -> MediaType -> Bool
>= :: MediaType -> MediaType -> Bool
$cmax :: MediaType -> MediaType -> MediaType
max :: MediaType -> MediaType -> MediaType
$cmin :: MediaType -> MediaType -> MediaType
min :: MediaType -> MediaType -> MediaType
Ord, ReadPrec [MediaType]
ReadPrec MediaType
Int -> ReadS MediaType
ReadS [MediaType]
(Int -> ReadS MediaType)
-> ReadS [MediaType]
-> ReadPrec MediaType
-> ReadPrec [MediaType]
-> Read MediaType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MediaType
readsPrec :: Int -> ReadS MediaType
$creadList :: ReadS [MediaType]
readList :: ReadS [MediaType]
$creadPrec :: ReadPrec MediaType
readPrec :: ReadPrec MediaType
$creadListPrec :: ReadPrec [MediaType]
readListPrec :: ReadPrec [MediaType]
Read, Int -> MediaType -> ShowS
[MediaType] -> ShowS
MediaType -> [Char]
(Int -> MediaType -> ShowS)
-> (MediaType -> [Char])
-> ([MediaType] -> ShowS)
-> Show MediaType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MediaType -> ShowS
showsPrec :: Int -> MediaType -> ShowS
$cshow :: MediaType -> [Char]
show :: MediaType -> [Char]
$cshowList :: [MediaType] -> ShowS
showList :: [MediaType] -> ShowS
Show, Typeable)

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

instance ToJSON MediaType where
  toJSON :: MediaType -> Value
toJSON = Options -> MediaType -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
mediaTypeOptions
  toEncoding :: MediaType -> Encoding
toEncoding = Options -> MediaType -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
mediaTypeOptions

instance FromJSON MediaType where
  parseJSON :: Value -> Parser MediaType
parseJSON = Options -> Value -> Parser MediaType
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
mediaTypeOptions

parseMediaType ∷ Stream s Identity Char ⇒ s → Maybe MediaType
parseMediaType :: forall s. Stream s Identity Char => s -> Maybe MediaType
parseMediaType = (ParseError -> Maybe MediaType)
-> (MediaType -> Maybe MediaType)
-> Either ParseError MediaType
-> Maybe MediaType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe MediaType -> ParseError -> Maybe MediaType
forall a b. a -> b -> a
const Maybe MediaType
forall a. Maybe a
Nothing) MediaType -> Maybe MediaType
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError MediaType -> Maybe MediaType)
-> (s -> Either ParseError MediaType) -> s -> Maybe MediaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec s () MediaType -> [Char] -> s -> Either ParseError MediaType
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec s () MediaType
parser [Char]
""
 where
  parser :: Parsec s () MediaType
parser = do
    [Char]
t ← ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a. ParsecT s () Identity a -> ParsecT s () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT s () Identity Char -> ParsecT s () Identity [Char])
-> ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => [Char] -> m Char
noneOf [Char]
"/"
    Char -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'/'
    [Char]
subtype ← ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a. ParsecT s () Identity a -> ParsecT s () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT s () Identity Char -> ParsecT s () Identity [Char])
-> ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => [Char] -> m Char
noneOf [Char]
"+;"
    Maybe [Char]
suffix ← ParsecT s () Identity [Char]
-> ParsecT s () Identity (Maybe [Char])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT s () Identity [Char]
 -> ParsecT s () Identity (Maybe [Char]))
-> ParsecT s () Identity [Char]
-> ParsecT s () Identity (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' ParsecT s () Identity Char
-> ParsecT s () Identity [Char] -> ParsecT s () Identity [Char]
forall a b.
ParsecT s () Identity a
-> ParsecT s () Identity b -> ParsecT s () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a. ParsecT s () Identity a -> ParsecT s () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ([Char] -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => [Char] -> m Char
noneOf [Char]
";")
    [[Char]]
parameters ← ParsecT s () Identity [Char] -> ParsecT s () Identity [[Char]]
forall a. ParsecT s () Identity a -> ParsecT s () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT s () Identity [Char] -> ParsecT s () Identity [[Char]])
-> ParsecT s () Identity [Char] -> ParsecT s () Identity [[Char]]
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
';' ParsecT s () Identity Char
-> ParsecT s () Identity [Char] -> ParsecT s () Identity [Char]
forall a b.
ParsecT s () Identity a
-> ParsecT s () Identity b -> ParsecT s () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s () Identity Char -> ParsecT s () Identity [Char]
forall a. ParsecT s () Identity a -> ParsecT s () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ([Char] -> ParsecT s () Identity Char
forall (m :: * -> *). CharParsing m => [Char] -> m Char
noneOf [Char]
";")

    MediaType -> Parsec s () MediaType
forall a. a -> ParsecT s () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (MediaType -> Parsec s () MediaType)
-> MediaType -> Parsec s () MediaType
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> [Text] -> MediaType
MediaType ([Char] -> Text
forall a. ToText a => a -> Text
toText [Char]
t) ([Char] -> Text
forall a. ToText a => a -> Text
toText [Char]
subtype) ([Char] -> Text
forall a. ToText a => a -> Text
toText ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
forall a. Monoid a => a
mempty Maybe [Char]
suffix) ([Text] -> MediaType) -> [Text] -> MediaType
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
forall a. ToText a => a -> Text
toText [[Char]]
parameters

pattern MediaTypeRSS ∷ [Text] → MediaType
pattern $mMediaTypeRSS :: forall {r}. MediaType -> ([Text] -> r) -> ((# #) -> r) -> r
$bMediaTypeRSS :: [Text] -> MediaType
MediaTypeRSS parameters = MediaType "application" "rss" "xml" parameters

pattern MediaTypeAtom ∷ [Text] → MediaType
pattern $mMediaTypeAtom :: forall {r}. MediaType -> ([Text] -> r) -> ((# #) -> r) -> r
$bMediaTypeAtom :: [Text] -> MediaType
MediaTypeAtom parameters = MediaType "application" "atom" "xml" parameters

pattern MediaTypeApplicationXML ∷ Text → [Text] → MediaType
pattern $mMediaTypeApplicationXML :: forall {r}. MediaType -> (Text -> [Text] -> r) -> ((# #) -> r) -> r
$bMediaTypeApplicationXML :: Text -> [Text] -> MediaType
MediaTypeApplicationXML suffix parameters = MediaType "application" "xml" suffix parameters

pattern MediaTypeTextXML ∷ Text → [Text] → MediaType
pattern $mMediaTypeTextXML :: forall {r}. MediaType -> (Text -> [Text] -> r) -> ((# #) -> r) -> r
$bMediaTypeTextXML :: Text -> [Text] -> MediaType
MediaTypeTextXML suffix parameters = MediaType "text" "xml" suffix parameters

pattern MediaTypeHTML ∷ Text → [Text] → MediaType
pattern $mMediaTypeHTML :: forall {r}. MediaType -> (Text -> [Text] -> r) -> ((# #) -> r) -> r
$bMediaTypeHTML :: Text -> [Text] -> MediaType
MediaTypeHTML suffix parameters = MediaType "text" "html" suffix parameters