ripple-federation (empty) → 0.1

raw patch · 5 files changed

+333/−0 lines, 5 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, base58address, blaze-builder, bytestring, errors, http-streams, http-types, io-streams, network, text, unexceptionalio

Files

COPYING +13/−0
README +1/−0
Ripple/Federation.hs +273/−0
Setup.hs +3/−0
ripple-federation.cabal +43/−0

+ COPYING view

@@ -0,0 +1,13 @@+Copyright © 2014, Stephen Paul Weber <singpolyma.net>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

+ README view

@@ -0,0 +1,1 @@+To resolve federation names, etc.

+ Ripple/Federation.hs view

@@ -0,0 +1,273 @@+module Ripple.Federation (+	resolve,+	getRippleTxt,+	Alias(..),+	ResolvedAlias(..),+	-- * Errors+	Error(..),+	ErrorType(..),+	-- * Utils+	rippleTxtParser+)where++import Control.Applicative ((<$>), (<*>), (*>), (<*), (<|>), many, some)+import Control.Monad (guard)+import Data.Either (rights)+import Data.Monoid (Monoid(..))+import Data.Word (Word32)+import Control.Error (readZ, fmapLT, throwT, runEitherT, EitherT(..), hoistEither, note)+import UnexceptionalIO (fromIO, runUnexceptionalIO, UnexceptionalIO)+import Control.Exception (fromException)+import Data.Base58Address (RippleAddress)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8 -- eww++import Blaze.ByteString.Builder (Builder)+import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+import System.IO.Streams (OutputStream, InputStream)+import System.IO.Streams.Attoparsec (parseFromStream, ParseException(..))+import Network.Http.Client (withConnection, establishConnection, sendRequest, buildRequest, http, setAccept, Response, receiveResponse, RequestBuilder, setContentLength)+import qualified Network.Http.Client as HttpStreams++import Network.HTTP.Types.QueryLike (QueryLike(..))+import Network.HTTP.Types.URI (renderQuery)+import Data.Aeson (FromJSON(..), ToJSON(..), object, (.=), (.:), (.:?))+import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.ByteString as Attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec hiding (takeTill)++-- * Errors and stuff++data ErrorType = NoSuchUser | NoSupported | NoSuchDomain | InvalidParams | Unavailable deriving (Show, Eq)++data Error = Error {+		errorType :: ErrorType,+		errorMessage :: Text+	} deriving (Show, Eq)++instance Monoid Error where+	mempty = Error Unavailable (T.pack "mempty")+	mappend _ y = y++instance ToJSON Error where+	toJSON (Error typ message) = object [+			T.pack "result" .= "error",+			T.pack "error" .= typ,+			T.pack "error_message" .= message+		]++instance FromJSON Error where+	parseJSON (Aeson.Object o) =+		Error                 <$>+		(o .: T.pack "error") <*>+		(o .: T.pack "error_message")+	parseJSON _ = fail "Ripple federation errors are always objects."++instance ToJSON ErrorType where+	toJSON NoSuchUser = toJSON "noSuchUser"+	toJSON NoSupported = toJSON "noSupported"+	toJSON NoSuchDomain = toJSON "noSuchDomain"+	toJSON InvalidParams = toJSON "invalidParams"+	toJSON Unavailable = toJSON "unavailable"++instance FromJSON ErrorType where+	parseJSON (Aeson.String s) =+		maybe (fail "Unknown Ripple federation error type.") return $+		lookup s [+			(T.pack "noSuchUser", NoSuchUser),+			(T.pack "noSupported", NoSupported),+			(T.pack "noSuchDomain", NoSuchDomain),+			(T.pack "invalidParams", InvalidParams),+			(T.pack "unavailable", Unavailable)+		]+	parseJSON _ = fail "Ripple federation error type is always a string."++newtype FederationResult a = FederationResult (Either Error a)++instance (FromJSON a) => FromJSON (FederationResult a) where+	parseJSON v@(Aeson.Object o) = FederationResult <$> do+		r <- o .:? T.pack "result"+		case r of+			Just x | x == T.pack "error" -> Left <$> Aeson.parseJSON v+			_ -> Right <$> Aeson.parseJSON v+	parseJSON _ = fail "Ripple federation results are always objects."++-- * Aliases: user@domain.tld++-- | destination\@domain+data Alias = Alias {+		destination :: Text,+		domain      :: Text+	} deriving (Eq)++instance Show Alias where+	show (Alias dest domain) = T.unpack dest ++ "@" ++ T.unpack domain++instance Read Alias where+	readsPrec _ = readParen False go+		where+		domainchars = ['a'..'z']++['A'..'Z']++['0'..'9']++['-','.']+		whitespace = [' ', '\t', '\n', '\r']+		go s = case span (/='@') (dropWhile (`elem` whitespace) s) of+			(dest, '@':rest) ->+				let (domain, end) = span (`elem` domainchars) rest in+				[(Alias (T.pack dest) (T.pack domain), end)]+			_ -> []++instance QueryLike Alias where+	toQuery (Alias dest domain) = toQuery [+			("type", T.pack "federation"),+			("destination", dest),+			("user", dest),+			("domain", domain)+		]++data ResolvedAlias = ResolvedAlias {+		alias  :: Alias,+		ripple :: RippleAddress,+		dt     :: Maybe Word32+	} deriving (Show, Eq)++instance ToJSON ResolvedAlias where+	toJSON (ResolvedAlias (Alias dest domain) ripple dt) = object [+		T.pack "federation_json" .= object ([+				T.pack "type" .= "federation_record",+				T.pack "destination" .= dest,+				T.pack "domain" .= domain,+				T.pack "destination_address" .= show ripple+			] ++ maybe [] (\x -> [T.pack "dt" .= x]) dt)+		]++instance FromJSON ResolvedAlias where+	parseJSON (Aeson.Object o) = do+		o' <- o .: T.pack "federation_json"+		dest <- o' .:? T.pack "destination"+		ultimateDest <- case dest of+			Just (Aeson.String s) -> return s+			_ -> o' .: T.pack "user"+		ResolvedAlias <$> (+				Alias ultimateDest <$>+				(o' .: T.pack "domain")+			)                                    <*>+			(o' .: T.pack "destination_address" >>= readZ) <*>+			(o' .:? T.pack "dt")+	parseJSON _ = fail "Ripple federation records are always objects."++-- * Resolve aliases++-- | Resolve an alias+resolve :: Alias -> IO (Either Error ResolvedAlias)+resolve a@(Alias u domain) | domain == T.pack "ripple.com" = runEitherT $ do+	FederationResult r <- EitherT $ runUnexceptionalIO $ runEitherT $+		get (URI "https:" (Just $ URIAuth "" "id.ripple.com" "") ("/v1/user/" ++ T.unpack u) "" "") a+	RippleNameResponse x <- hoistEither r+	return x+resolve a@(Alias _ domain) = runEitherT $ do+	txt <- EitherT (getRippleTxt domain)+	uri <- case lookup (T.pack "federation_url") txt of+		Just [url] -> hoistEither $ note+			(Error NoSupported (T.pack "federation_url in ripple.txt is invalid"))+			(parseAbsoluteURI $ T.unpack url)+		_ ->+			throwT $ Error NoSupported (T.pack "No federation_url in ripple.txt")++	FederationResult r <- EitherT $ runUnexceptionalIO $ runEitherT $ get uri a+	hoistEither r++-- | Lookup the ripple.txt for a domain+getRippleTxt ::+	Text -- ^ Domain to lookup+	-> IO (Either Error [(Text, [Text])])+getRippleTxt domain = runUnexceptionalIO $ runEitherT $+	tryOne (uri domain')             <|>+	tryOne (uri ("www." ++ domain')) <|>+	tryOne (uri ("ripple." ++ domain'))+	where+	domain' = T.unpack domain+	uri d = URI "https:" (Just $ URIAuth "" d "") "/ripple.txt" "" ""+	tryOne uri =+		(hoistEither =<<) $+		fmapLT (const $ Error Unavailable (T.pack "Network error")) $ fromIO $+		oneShotHTTP HttpStreams.GET uri+		(setContentLength 0 >> setAccept (BS8.pack "text/plain"))+		HttpStreams.emptyBody (parseResponse rippleTxtParser)++-- | Attoparsec parser for ripple.txt+rippleTxtParser :: Attoparsec.Parser [(Text, [Text])]+rippleTxtParser = some section+	where+	section = do+		h <- header >>= utf8+		ls <- many (Attoparsec.eitherP comment line)+		ls' <- mapM utf8 (rights ls)+		return (h, ls')+	utf8 bs = case T.decodeUtf8' bs of+		Right r -> return r+		Left e -> fail $ show e+	header = Attoparsec.skipSpace *>+		Attoparsec.char '[' *> Attoparsec.takeTill(==0x5D) <* Attoparsec.char ']'+	line = Attoparsec.skipSpace *> do+		c <- Attoparsec.peekChar+		guard (c /= Just '[')+		Attoparsec.takeTill Attoparsec.isEndOfLine <* Attoparsec.endOfLine+	comment = Attoparsec.skipSpace *> Attoparsec.char '#' *>+		Attoparsec.takeTill Attoparsec.isEndOfLine <* Attoparsec.endOfLine++-- * Internal Helpers++get :: (QueryLike a, FromJSON b) => URI -> a -> EitherT Error UnexceptionalIO b+get uri payload =+	(hoistEither =<<) $+	fmapLT (const $ Error Unavailable (T.pack "Network error")) $ fromIO $+	oneShotHTTP HttpStreams.GET uri'+	(setContentLength 0 >> setAccept (BS8.pack "application/json"))+	HttpStreams.emptyBody safeJSONresponse+	where+	uri' = uri { uriQuery = BS8.unpack $ renderQuery True (toQuery payload)}++safeJSONresponse :: (Aeson.FromJSON a) => Response -> InputStream ByteString -> IO (Either Error a)+safeJSONresponse resp i = runEitherT $ do+	v <- EitherT $ parseResponse Aeson.json' resp i+	case Aeson.fromJSON v of+		Aeson.Success a -> return a+		Aeson.Error e -> throwT $ Error Unavailable $+			T.pack $ "JSON parser error: " ++ e++parseResponse :: Attoparsec.Parser a -> Response -> InputStream ByteString -> IO (Either Error a)+parseResponse parser _ i = runUnexceptionalIO $ runEitherT $+	fmapLT (\e -> handle e (fromException e)) $ fromIO $+		parseFromStream parser i+	where+	parseError e = Error Unavailable (T.pack $ "Parse error: " ++ show e)+	handle _ (Just (ParseException e)) = parseError e+	handle e _ = Error Unavailable (T.pack $ "Exception: " ++ show e)++oneShotHTTP :: HttpStreams.Method -> URI -> RequestBuilder () -> (OutputStream Builder -> IO ()) -> (Response -> InputStream ByteString -> IO b) -> IO b+oneShotHTTP method uri req body handler = do+	req' <- buildRequest $ do+		http method (BS8.pack $ uriPath uri ++ uriQuery uri)+		req+	withConnection (establishConnection url) $ \conn -> do+		sendRequest conn req' body+		receiveResponse conn handler+	where+	url = BS8.pack $ show uri -- URI can only have ASCII, so should be safe++-- * Temporary stuff to handle centralised Ripple Names hack++newtype RippleNameResponse = RippleNameResponse ResolvedAlias++instance FromJSON RippleNameResponse where+	parseJSON (Aeson.Object o) = RippleNameResponse <$> (+		ResolvedAlias <$> (+				Alias                   <$>+				(o .: T.pack "username") <*>+				return (T.pack "ripple.com")+			)                                    <*>+			(o .: T.pack "address" >>= readZ) <*>+			return Nothing+		)+	parseJSON _ = fail "Ripple federation records are always objects."

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ ripple-federation.cabal view

@@ -0,0 +1,43 @@+name:            ripple-federation+version:         0.1+cabal-version:   >= 1.8+license:         OtherLicense+license-file:    COPYING+category:        Data+copyright:       © 2014 Stephen Paul Weber+author:          Stephen Paul Weber <singpolyma@singpolyma.net>+maintainer:      Stephen Paul Weber <singpolyma@singpolyma.net>+stability:       experimental+tested-with:     GHC == 7.4.1+synopsis:        Utilities and types to work with the Ripple federation protocol+homepage:        https://github.com/singpolyma/ripple-federation-haskell+bug-reports:     https://github.com/singpolyma/ripple-federation-haskell/issues+build-type:      Simple+description:+        To resolve federation names, etc.++extra-source-files:+        README++library+        exposed-modules:+                Ripple.Federation++        build-depends:+                base == 4.*,+                bytestring,+                text,+                errors,+                aeson,+                attoparsec,+                blaze-builder,+                network,+                http-types,+                http-streams,+                io-streams,+                unexceptionalio,+                base58address++source-repository head+        type:     git+        location: git://github.com/singpolyma/ripple-federation-haskell.git