{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.XRD.JSON
( toByteString
, toValue
, subjectToValue
, propertiesToValue
, linkToValue
) where
import Data.Aeson (Value, encode, object, toJSON, (.=))
import Data.ByteString.Lazy (ByteString)
import Data.Maybe (fromMaybe, maybeToList)
import Data.XRD.Types
( XRD(..)
, Subject(..)
, Property(..)
, Link(..), LinkType(..), Title(..)
, uriText, linkRelText
)
toByteString :: XRD -> ByteString
toByteString = encode . toValue
toValue :: XRD -> Value
toValue XRD{..} = object topLvl
where
topLvl = mconcat $ map maybeToList
[ fmap
(\e -> "expires" .= e)
xrdExpires
, fmap
(\s -> "subject" .= subjectToValue s)
xrdSubject
, aliases
, properties
, links
]
aliases
| null xrdAliases = Nothing
| otherwise = Just
( "aliases" .=
[ uriText uri
| Subject uri <- xrdAliases
]
)
properties
| null xrdProperties = Nothing
| otherwise = Just
( "properties" .= propertiesToValue xrdProperties
)
links
| null xrdLinks = Nothing
| otherwise = Just
( "links" .= map linkToValue xrdLinks
)
subjectToValue :: Subject -> Value
subjectToValue (Subject uri) = toJSON (uriText uri)
propertiesToValue :: [Property] -> Value
propertiesToValue props = object
[ uriText uri .= val
| Property uri val <- props
]
linkToValue :: Link -> Value
linkToValue Link{..} = object . mconcat $ map maybeToList
[ fmap
(\r -> "rel" .= linkRelText r)
linkRel
, fmap
(\(LinkType t) -> "type" .= t)
linkType
, fmap
(\uri -> "href" .= uriText uri)
linkHref
, fmap
(\t -> "template" .= t)
linkTemplate
, titles
, properties
]
where
titles
| null linkTitles = Nothing
| otherwise = Just
( "titles" .= object
[ fromMaybe "default" lang .= title
| Title lang title <- linkTitles
]
)
properties
| null linkProperties = Nothing
| otherwise = Just
( "properties" .= propertiesToValue linkProperties
)