oasis-xrd (empty) → 1.0
raw patch · 11 files changed
+700/−0 lines, 11 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, oasis-xrd, text, time, uri-bytestring, xml-conduit, xml-conduit-writer
Files
- CHANGELOG.md +16/−0
- LICENSE +30/−0
- README.md +85/−0
- Setup.hs +2/−0
- lib/Data/XRD/JSON.hs +106/−0
- lib/Data/XRD/Types.hs +111/−0
- lib/Data/XRD/XML.hs +99/−0
- oasis-xrd.cabal +92/−0
- tests/example-common/Utils.hs +20/−0
- tests/example-json/Main.hs +76/−0
- tests/example-xml/Main.hs +63/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+<XRD xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns="http://docs.oasis-open.org/ns/xri/xrd-1.0">+ <Expires>+ 1970-01-01T00:00:00Z+ </Expires>+ <Subject>+ http://example.com/gpburdell+ </Subject>+ <Property type="http://spec.example.net/type/person" xsi:nil="True"/>+ <Link href="http://services.example.com/auth" rel="http://spec.example.net/auth/1.0"/>+ <Link+ href="http://photos.example.com/gpburdell.jpg"+ rel="http://spec.example.net/photo/1.0"+ type="image/jpeg">+ <Title xml:lang="en">+ User Photo+ </Title>+ <Title xml:lang="de">+ Benutzerfoto+ </Title>+ <Property type="http://spec.example.net/created/1.0">+ 1970-01-01+ </Property>+ </Link>+</XRD>+```++## 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"+ }+}+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/Data/XRD/JSON.hs view
@@ -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+ )+
+ lib/Data/XRD/Types.hs view
@@ -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
+ lib/Data/XRD/XML.hs view
@@ -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"
+ oasis-xrd.cabal view
@@ -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
+ tests/example-common/Utils.hs view
@@ -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
+ tests/example-json/Main.hs view
@@ -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}"+ }+ ]+ }
+ tests/example-xml/Main.hs view
@@ -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")+ ]+ }+ ]+ }