diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [Compatible Versioning](https://github.com/staltz/comver). + +## [Unreleased] + +## [1.0] - 2018-04-07 + +### Added + +- Initial release with XRD and JRD encoders + +[1.0]: https://gitlab.com/dpwiz/oasis-xrd/tree/1.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexander Bondarenko (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Bondarenko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,85 @@ +# oasis-xrd + +Types and rendering of [XRD] and [web-host] metadata. + +Part of the [Fediverse] suite of protocols. + +[XRD]: http://docs.oasis-open.org/xri/xrd/v1.0/xrd-1.0.html +[web-host]: https://tools.ietf.org/html/rfc6415 +[Fediverse]: https://en.wikipedia.org/wiki/Fediverse + +## XML + +XML output of `tests/example/Main.hs` on example from Section B: + +```xml + + + 1970-01-01T00:00:00Z + + + http://example.com/gpburdell + + + + + + User Photo + + + Benutzerfoto + + + 1970-01-01 + + + +``` + +## JSON (JRD) + +JSON output of `tests/example-json/Main.hs` on example from RFC 6415: + + +```json +{ + "subject": "http://blog.example.com/article/id/314", + "expires": "1970-01-01T00:00:00Z", + "aliases": [ + "http://blog.example.com/cool_new_thing", + "http://blog.example.com/steve/article/7" + ], + "links": [ + { + "titles": { + "default": "About the Author", + "en-us": "Author Information" + }, + "href": "http://blog.example.com/author/steve", + "type": "text/html", + "rel": "author", + "properties": { + "http://example.com/role": "editor" + } + }, + { + "titles": { + "default": "The other author" + }, + "href": "http://example.com/author/john", + "rel": "author" + }, + { + "template": "http://example.com/copyright?id={uri}", + "rel": "author" + } + ], + "properties": { + "http://blgx.example.net/ns/ext": null, + "http://blgx.example.net/ns/version": "1.3" + } +} +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/Data/XRD/JSON.hs b/lib/Data/XRD/JSON.hs new file mode 100644 --- /dev/null +++ b/lib/Data/XRD/JSON.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Orphan-less conversions to JSON (as JRD, by rfc6415). + +module Data.XRD.JSON + ( toByteString + , toValue + -- * Conversions for inner parts + , 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 + ) + diff --git a/lib/Data/XRD/Types.hs b/lib/Data/XRD/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Data/XRD/Types.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Data.XRD.Types + ( XRD(..) + , emptyXRD + -- * Document fields + , Subject(..) + , subject + , Property(..) + , property + , property_ + , Link(..) + , emptyLink + , LinkRel(..) + , linkRelURI + , linkRelText + , LinkType(..) + , Title(..) + -- * URI building helper + , uri + , URIParseError(..) + , uriText + ) where + +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import URI.ByteString (URIParseError(..), URIRef, Absolute, laxURIParserOptions, parseURI, normalizeURIRef', aggressiveNormalization) + +data XRD = XRD + { xrdID :: Maybe Text + , xrdExpires :: Maybe UTCTime + , xrdSubject :: Maybe Subject + , xrdAliases :: [Subject] + , xrdProperties :: [Property] + , xrdLinks :: [Link] + } deriving (Eq, Show, Generic) + +emptyXRD :: XRD +emptyXRD = XRD + { xrdID = Nothing + , xrdExpires = Nothing + , xrdSubject = Nothing + , xrdAliases = [] + , xrdProperties = [] + , xrdLinks = [] + } + +newtype Subject = Subject (URIRef Absolute) + deriving (Eq, Ord, Show, Generic) + +subject :: Text -> Either URIParseError Subject +subject = fmap Subject . uri + +data Property = Property (URIRef Absolute) (Maybe Text) + deriving (Eq, Ord, Show, Generic) + +property :: Text -> Maybe Text -> Either URIParseError Property +property typ body = Property + <$> uri typ + <*> pure body + +property_ :: Text -> Either URIParseError Property +property_ typ = property typ Nothing + +data Link = Link + { linkRel :: Maybe LinkRel + , linkType :: Maybe LinkType + , linkHref :: Maybe (URIRef Absolute) + , linkTemplate :: Maybe Text + , linkTitles :: [Title] + , linkProperties :: [Property] + } deriving (Eq, Ord, Show, Generic) + +emptyLink :: Link +emptyLink = Link + { linkRel = Nothing + , linkType = Nothing + , linkHref = Nothing + , linkTemplate = Nothing + , linkTitles = mempty + , linkProperties = mempty + } + +data LinkRel + = LinkRelURI (URIRef Absolute) + | LinkRelRegistered Text + deriving (Eq, Ord, Show, Generic) + +linkRelURI :: Text -> Either URIParseError LinkRel +linkRelURI = fmap LinkRelURI . uri + +linkRelText :: LinkRel -> Text +linkRelText lr = case lr of + LinkRelURI lrURI -> + uriText lrURI + LinkRelRegistered lrR -> + lrR + +newtype LinkType = LinkType Text + deriving (Eq, Ord, Show, Generic) + +data Title = Title (Maybe Text) Text + deriving (Eq, Ord, Show, Generic) + +uri :: Text -> Either URIParseError (URIRef Absolute) +uri = parseURI laxURIParserOptions . encodeUtf8 + +uriText :: URIRef Absolute -> Text +uriText = decodeUtf8 . normalizeURIRef' aggressiveNormalization diff --git a/lib/Data/XRD/XML.hs b/lib/Data/XRD/XML.hs new file mode 100644 --- /dev/null +++ b/lib/Data/XRD/XML.hs @@ -0,0 +1,99 @@ +{-# 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" diff --git a/oasis-xrd.cabal b/oasis-xrd.cabal new file mode 100644 --- /dev/null +++ b/oasis-xrd.cabal @@ -0,0 +1,92 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: bf4eeceb8339d4f976b41b82515ff3e6378b9f732d3d9a4b0257eeb8271a7ddf + +name: oasis-xrd +version: 1.0 +synopsis: Extensible Resource Descriptor +description: Types and encodings for "XRD, a simple generic format for describing resources". +category: Web +homepage: https://github.com/wiz/oasis-xrd#readme +author: Alexander Bondarenko +maintainer: aenor.realm@gmail.com +copyright: 2018 Alexander Bondarenko +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + README.md + +library + hs-source-dirs: + lib + ghc-options: -Wall + build-depends: + aeson >=1.2 && <2.0 + , base >=4.10 && <5.0 + , bytestring >=0.10 && <1.0 + , containers >=0.5 && <0.6 + , text >=1.2 && <2.0 + , time >=1.8 && <2.0 + , uri-bytestring >=0.3 && <0.4 + , xml-conduit >=1.8 && <2.0 + , xml-conduit-writer >=0.1 && <0.2 + exposed-modules: + Data.XRD.JSON + Data.XRD.Types + Data.XRD.XML + other-modules: + Paths_oasis_xrd + default-language: Haskell2010 + +test-suite example-json + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + tests/example-common + tests/example-json + ghc-options: -Wall + build-depends: + aeson >=1.2 && <2.0 + , aeson-pretty >=0.8 && <1.0 + , base >=4.10 && <5.0 + , bytestring >=0.10 && <1.0 + , containers >=0.5 && <0.6 + , oasis-xrd + , text >=1.2 && <2.0 + , time >=1.8 && <2.0 + , uri-bytestring >=0.3 && <0.4 + , xml-conduit >=1.8 && <2.0 + , xml-conduit-writer >=0.1 && <0.2 + other-modules: + Utils + Paths_oasis_xrd + default-language: Haskell2010 + +test-suite example-xml + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + tests/example-common + tests/example-xml + ghc-options: -Wall + build-depends: + aeson >=1.2 && <2.0 + , base >=4.10 && <5.0 + , bytestring >=0.10 && <1.0 + , containers >=0.5 && <0.6 + , oasis-xrd + , text >=1.2 && <2.0 + , time >=1.8 && <2.0 + , uri-bytestring >=0.3 && <0.4 + , xml-conduit >=1.8 && <2.0 + , xml-conduit-writer >=0.1 && <0.2 + other-modules: + Utils + Paths_oasis_xrd + default-language: Haskell2010 diff --git a/tests/example-common/Utils.hs b/tests/example-common/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/example-common/Utils.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Utils + ( theBeginning + , forceURI + ) where + +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError, iso8601DateFormat) + +import qualified Data.XRD.Types as XRD + +theBeginning :: UTCTime +theBeginning = parseTimeOrError + False + defaultTimeLocale + (iso8601DateFormat $ Just "%H:%M:%S") + "1970-01-01T00:00:00" + +forceURI :: Either XRD.URIParseError a -> a +forceURI = either (error . show) id diff --git a/tests/example-json/Main.hs b/tests/example-json/Main.hs new file mode 100644 --- /dev/null +++ b/tests/example-json/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Example JRD document from https://tools.ietf.org/html/rfc6415 + +module Main where + +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.XRD.Types (XRD(..), Link(..)) + +import qualified Data.XRD.Types as XRD +import qualified Data.XRD.JSON as JRD + +import qualified Data.ByteString.Lazy.Char8 as BSLC + +import Utils (forceURI, theBeginning) + +main :: IO () +main = BSLC.putStrLn + . encodePretty + $ JRD.toValue exampleJRD + +exampleJRD :: XRD.XRD +exampleJRD = XRD.emptyXRD + { xrdExpires = Just theBeginning + , xrdSubject = either (error "bad subject") Just $ + XRD.subject "http://blog.example.com/article/id/314" + , xrdAliases = + [ forceURI $ XRD.subject "http://blog.example.com/cool_new_thing" + , forceURI $ XRD.subject "http://blog.example.com/steve/article/7" + ] + , xrdProperties = + [ forceURI $ XRD.property -- XXX: overwritten + "http://blgx.example.net/ns/version" + (Just "1.2") + , forceURI $ XRD.property + "http://blgx.example.net/ns/version" + (Just "1.3") + , forceURI $ XRD.property + "http://blgx.example.net/ns/ext" + Nothing + ] + , xrdLinks = + [ XRD.emptyLink + { linkRel = Just $ + XRD.LinkRelRegistered "author" + , linkType = Just $ + XRD.LinkType "text/html" + , linkHref = Just . forceURI $ + XRD.uri "http://blog.example.com/author/steve" + , linkTitles = + [ XRD.Title Nothing "About the Author" + , XRD.Title (Just "en-us") "Author Information" + ] + , linkProperties = + [ forceURI $ XRD.property + "http://example.com/role" + (Just "editor") + ] + } + , XRD.emptyLink + { linkRel = Just $ + XRD.LinkRelRegistered "author" + , linkHref = Just . forceURI $ + XRD.uri "http://example.com/author/john" + , linkTitles = + [ XRD.Title Nothing "The other guy" -- XXX: overwritten + , XRD.Title Nothing "The other author" + ] + } + , XRD.emptyLink + { linkRel = Just $ + XRD.LinkRelRegistered "author" + , linkTemplate = Just "http://example.com/copyright?id={uri}" + } + ] + } diff --git a/tests/example-xml/Main.hs b/tests/example-xml/Main.hs new file mode 100644 --- /dev/null +++ b/tests/example-xml/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Example XRD document from http://docs.oasis-open.org/xri/xrd/v1.0/xrd-1.0.html#examples + +module Main where + +import qualified Data.Text.Lazy.IO as Text +import qualified Text.XML as XML + +import Data.XRD.Types (XRD(..), Link(..)) + +import qualified Data.XRD.Types as XRD +import qualified Data.XRD.XML as XML + +import Utils (forceURI, theBeginning) + +main :: IO () +main = Text.putStrLn + . XML.renderText prettyRS + $ XML.toDocument exampleXRD + where + prettyRS = XML.def + { XML.rsPretty = True + , XML.rsNamespaces = + [ ("xsi", "http://www.w3.org/2001/XMLSchema-instance") + ] + } + +exampleXRD :: XRD.XRD +exampleXRD = XRD.emptyXRD + { xrdExpires = Just theBeginning + , xrdSubject = either (error "bad subject") Just $ + XRD.subject "http://example.com/gpburdell" + , xrdProperties = + [ forceURI $ XRD.property + "http://spec.example.net/type/person" + Nothing + ] + , xrdLinks = + [ XRD.emptyLink + { linkRel = Just . forceURI $ + XRD.linkRelURI "http://spec.example.net/auth/1.0" + , linkHref = Just . forceURI $ + XRD.uri "http://services.example.com/auth" + } + , XRD.emptyLink + { linkRel = Just . forceURI $ + XRD.linkRelURI "http://spec.example.net/photo/1.0" + , linkType = Just $ XRD.LinkType "image/jpeg" + , linkHref = Just . forceURI $ + XRD.uri "http://photos.example.com/gpburdell.jpg" + , linkTitles = + [ XRD.Title (Just "en") "User Photo" + , XRD.Title (Just "de") "Benutzerfoto" + ] + , linkProperties = + [ forceURI $ XRD.property + "http://spec.example.net/created/1.0" + (Just "1970-01-01") + ] + } + ] + }