XML.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module Data.XRD.XML
  ( toDocument
  ) where

import Data.Maybe (catMaybes)
import Data.Text (Text, pack)
import Data.Time (defaultTimeLocale, formatTime, iso8601DateFormat)
import Data.Foldable (for_)
import Text.XML (Document(..), Prologue(..), Element(..), Name(..), def)
import Text.XML.Writer (XML)

import qualified Data.Map as Map
import qualified Text.XML.Writer as XML

import Data.XRD.Types
  ( XRD(..)
  , Subject(..)
  , Property(..)
  , Link(..), LinkType(..), Title(..)
  , uriText, linkRelText
  )

toDocument :: XRD -> Document
toDocument XRD{..} = document xrdID $ do
  for_ xrdExpires $ \expires ->
    XML.element (xrdName "Expires") . pack $
      formatTime defaultTimeLocale xmlTime expires

  for_ xrdSubject $ \(Subject subjectURI) ->
    XML.element (xrdName "Subject") $
      uriText subjectURI

  for_ xrdAliases $ \(Subject subjectURI) ->
    XML.element (xrdName "Alias") $
      uriText subjectURI

  for_ xrdProperties renderProperty

  for_ xrdLinks $ \Link{..} -> do
    let
      attrs = catMaybes
        [ fmap (("rel",) . linkRelText)              linkRel
        , fmap (\(LinkType lt) -> ("type", lt))      linkType
        , fmap (\href -> ("href", uriText href))     linkHref
        , fmap (\template -> ("template", template)) linkTemplate
        ]
    XML.elementA (xrdName "Link") attrs $ do
      for_ linkTitles $ \(Title lang text) ->
        case lang of
          Nothing ->
            XML.element (xrdName "Title") text
          Just value ->
            XML.elementA (xrdName "Title") [("xml:lang", value)] text
      for_ linkProperties renderProperty

document :: Maybe Text -> XML -> Document
document xrdID xml = Document
  { documentPrologue = Prologue def def def
  , documentRoot = Element
    { elementName = xrdName "XRD"
    , elementAttributes =
        case xrdID of
          Nothing -> mempty
          Just id' -> Map.singleton "id" id'
    , elementNodes = XML.render xml
    }
  , documentEpilogue = mempty
  }

renderProperty :: Property -> XML
renderProperty (Property propertyURI body) =
  XML.elementA (xrdName "Property") attrs content
  where
    (attrs, content) =
      case body of
        Just text ->
          ( [("type", uriText propertyURI)]
          , XML.content text
          )
        Nothing ->
          ( [ ("type", uriText propertyURI)
            , ("{http://www.w3.org/2001/XMLSchema-instance}nil", "True")
            ]
          , XML.empty
          )

xrdName :: Text -> Name
xrdName name = Name
  { nameLocalName = name
  , nameNamespace = Just "http://docs.oasis-open.org/ns/xri/xrd-1.0"
  , namePrefix    = Nothing
  }

xmlTime :: String
xmlTime = iso8601DateFormat $ Just "%H:%M:%SZ"