diff --git a/Data/Aeson/TH/Smart.hs b/Data/Aeson/TH/Smart.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/TH/Smart.hs @@ -0,0 +1,611 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-} +-- Shamelessly copied from Bryan O'Sullivan, 2011 + +module Data.Aeson.TH.Smart + ( deriveJSON + + , deriveToJSON + , deriveFromJSON + + , mkToJSON + , mkParseJSON + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from aeson: +import Data.Aeson ( toJSON, Object, object, (.=), (.:) + , ToJSON, toJSON + , FromJSON, parseJSON + ) +import Data.Aeson.Types ( Value(..), Parser ) +-- from base: +import Control.Applicative ( pure, (<$>), (<*>) ) +import Control.Monad ( return, mapM, liftM2, fail ) +import Data.Bool ( otherwise) +import Data.Default ( def, Default ) +import Data.Eq ( (==) ) +import Data.Function ( ($), (.), id ) +import Data.Functor ( fmap ) +import Data.List ( (++), foldl, foldl', intercalate + , length, map, zip, genericLength + ) +import Data.Maybe ( Maybe(Nothing, Just) ) +import Prelude ( String, (-), Integer, fromIntegral, not, error, filter, fst, snd, Bool(..), flip, concat) +import Text.Printf ( printf ) +import Text.Show ( show ) +#if __GLASGOW_HASKELL__ < 700 +import Control.Monad ( (>>=) ) +import Prelude ( fromInteger ) +#endif +-- from unordered-containers: +import qualified Data.HashMap.Strict as H ( lookup, toList, size ) +-- from template-haskell: +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +-- from text: +import qualified Data.Text as T ( Text, pack, unpack ) +-- from vector: +import qualified Data.Vector as V ( unsafeIndex, null, length, create, filter) +import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite ) + +-------------------------------------------------------------------------------- +-- Convenience +-------------------------------------------------------------------------------- + +-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given +-- data type. +-- +-- This is a convienience function which is equivalent to calling both +-- 'deriveToJSON' and 'deriveFromJSON'. +deriveJSON :: (String -> String) + -- ^ Function to change field names. + -> Name + -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON' + -- instances. + -> Q [Dec] +deriveJSON withField name = + liftM2 (++) + (deriveToJSON withField name) + (deriveFromJSON withField name) + + +-------------------------------------------------------------------------------- +-- ToJSON +-------------------------------------------------------------------------------- + +{- +TODO: Don't constrain phantom type variables. + +data Foo a = Foo Int +instance (ToJSON a) ⇒ ToJSON Foo where ... + +The above (ToJSON a) constraint is not necessary and perhaps undesirable. +-} + +-- | Generates a 'ToJSON' instance declaration for the given data type. +-- +-- Example: +-- +-- @ +-- data Foo = Foo 'Char' 'Int' +-- $('deriveToJSON' 'id' ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- instance 'ToJSON' Foo where +-- 'toJSON' = +-- \value -> case value of +-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do +-- mv <- 'VM.unsafeNew' 2 +-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1) +-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2) +-- return mv +-- @ +deriveToJSON :: (String -> String) + -- ^ Function to change field names. + -> Name + -- ^ Name of the type for which to generate a 'ToJSON' instance + -- declaration. + -> Q [Dec] +deriveToJSON withField name = + withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons + where + fromCons :: [TyVarBndr] -> [Con] -> Q Dec + fromCons tvbs cons = + instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames) + (classType `appT` instanceType) + [ funD 'toJSON + [ clause [] + (normalB $ consToJSON withField cons) + [] + ] + ] + where + classType = conT ''ToJSON + typeNames = map tvbName tvbs + instanceType = foldl' appT (conT name) $ map varT typeNames + +-- | Generates a lambda expression which encodes the given data type as JSON. +-- +-- Example: +-- +-- @ +-- data Foo = Foo Int +-- @ +-- +-- @ +-- encodeFoo :: Foo -> 'Value' +-- encodeFoo = $('mkToJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- \value -> case value of Foo arg1 -> 'toJSON' arg1 +-- @ +mkToJSON :: (String -> String) -- ^ Function to change field names. + -> Name -- ^ Name of the type to encode. + -> Q Exp +mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons) + +-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code +-- to generate the JSON encoding of a number of constructors. All constructors +-- must be from the same type. +consToJSON :: (String -> String) + -- ^ Function to change field names. + -> [Con] + -- ^ Constructors for which to generate JSON generating code. + -> Q Exp +consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: " + ++ "Not a single constructor given!" +-- A single constructor is directly encoded. The constructor itself may be +-- forgotten. +consToJSON withField [con] = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + [encodeArgs Nothing withField con] + +consToJSON withField cons = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + [ encodeArgs (Just $ wrap $ [|String . T.pack|] `appE` conNameExp con) withField con + | con <- cons + ] + where + wrap :: Q Exp -> [Q Exp] -> Q Exp + wrap name exps = + [e|object|] `appE` ([e| filter (not .(==Null) . snd )|] `appE` + listE (infixApp (litE $ stringL "constructor") [e|(.=)|] name : exps)) + +-- | Generates code to generate the JSON encoding of a single constructor. +encodeArgs :: Maybe ([Q Exp] -> Q Exp) -> (String -> String) -> Con -> Q Match +encodeArgs _ _ c@(NormalC conName []) = + match (conP conName []) (normalB $ [e|toJSON|] `appE` ([|T.pack|] `appE` conNameExp c)) [] +encodeArgs wrapper _ (NormalC conName ts) = do + let len = length ts + args <- mapM newName ["arg" ++ show n | n <- [1..len]] + let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of + -- Single argument is directly converted. + [e] -> e + -- Multiple arguments are converted to a JSON array. + es -> do + mv <- newName "mv" + let newMV = bindS (varP mv) + ([e|VM.unsafeNew|] `appE` + litE (integerL $ fromIntegral len)) + stmts = [noBindS $ + [e|VM.unsafeWrite|] `appE` + (varE mv) `appE` + litE (integerL ix) `appE` e | (ix, e) <- zip [(0::Integer)..] es] + ret = noBindS $ [e|return|] `appE` varE mv + fltr = [e| V.filter (not . (== Null))|] + [e|Array|] `appE` (fltr `appE` (varE 'V.create `appE` doE (newMV:stmts++[ret]))) + let b = case wrapper of + Nothing -> js + (Just wrapper') -> wrapper' [infixApp (litE (stringL "value")) [e|(.=)|] js] + match (conP conName $ map varP args) (normalB b) [] +-- Records. +encodeArgs withExp withField (RecC conName ts) = do + args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]] + let args' = map (([e|toJSON|] `appE`) . varE) args + let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field) [e|(.=)|] arg + | (arg, (field, _, _)) <- zip args' ts + ] + let b = case withExp of + Nothing -> [e|object|] `appE` ([e| filter (not . (==Null) . snd) |] `appE` listE js) + (Just wrapper) -> wrapper js + match (conP conName $ map varP args) (normalB b) [] +-- Infix constructors. +encodeArgs withExp _ (InfixC _ conName _) = do + al <- newName "argL" + ar <- newName "argR" + let l = listE [[e|toJSON|] `appE` varE a | a <- [al,ar]] + let b = case withExp of + Nothing -> [e|toJSON|] `appE` l + (Just wrapper) -> wrapper [infixApp (litE $ stringL "value") [e|(.=)|] l] + match (infixP (varP al) conName (varP ar)) (normalB b) [] +-- Existentially quantified constructors. +encodeArgs withExp withField (ForallC _ _ con) = + encodeArgs withExp withField con + + +-------------------------------------------------------------------------------- +-- FromJSON +-------------------------------------------------------------------------------- + +-- | Generates a 'FromJSON' instance declaration for the given data type. +-- +-- Example: +-- +-- @ +-- data Foo = Foo Char Int +-- $('deriveFromJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- instance 'FromJSON' Foo where +-- 'parseJSON' = +-- \value -> case value of +-- 'Array' arr -> +-- if (V.length arr == 2) +-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0) +-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1) +-- else fail \"\\" +-- other -> fail \"\\" +-- @ +deriveFromJSON :: (String -> String) + -- ^ Function to change field names. + -> Name + -- ^ Name of the type for which to generate a 'FromJSON' instance + -- declaration. + -> Q [Dec] +deriveFromJSON withField name = + withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons + where + fromCons :: [TyVarBndr] -> [Con] -> Q Dec + fromCons tvbs cons = + instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames) + (classType `appT` instanceType) + [ funD 'parseJSON + [ clause [] + (normalB $ consFromJSON name withField cons) + [] + ] + ] + where + classType = conT ''FromJSON + typeNames = map tvbName tvbs + instanceType = foldl' appT (conT name) $ map varT typeNames + +-- | Generates a lambda expression which parses the JSON encoding of the given +-- data type. +-- +-- Example: +-- +-- @ +-- data Foo = Foo 'Int' +-- @ +-- +-- @ +-- parseFoo :: 'Value' -> 'Parser' Foo +-- parseFoo = $('mkParseJSON' id ''Foo) +-- @ +-- +-- This will splice in the following code: +-- +-- @ +-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg +-- @ +mkParseJSON :: (String -> String) -- ^ Function to change field names. + -> Name -- ^ Name of the encoded type. + -> Q Exp +mkParseJSON withField name = + withType name (\_ cons -> consFromJSON name withField cons) + +-- if it's 1ary flat constrcutor, it's just the constructor name, no matter how many +-- if there's many nary constructors, we make an object with value and constructor records +-- if there's many record constructors, we add a record with the constructor value + +-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates +-- code to parse the JSON encoding of a number of constructors. All constructors +-- must be from the same type. +consFromJSON :: Name + -- ^ Name of the type to which the constructors belong. + -> (String -> String) + -- ^ Function to change field names. + -> [Con] + -- ^ Constructors for which to generate JSON parsing code. + -> Q Exp +consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: " + ++ "Not a single constructor given!" +consFromJSON tName withField [con] = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + (parseArgs tName withField False con) + +consFromJSON tName withField cons = do + value <- newName "value" + lam1E (varP value) + $ caseE (varE value) + $ concat [parseArgs tName withField True con | con <- cons] + + +objectWrapper :: Name -> Name -> (Name -> Name -> ExpQ) -> [Q Match] +objectWrapper tName conName expr = + [ do obj <- newName "arg" + strcon <- newName "strcon" + val <- newName "val" + flip (match (conP 'Object [varP obj])) [] $ normalB $ doE [ + bindS (varP strcon) ([e|(.: "constructor")|] `appE` (varE obj)) + , bindS (varP val) ([e|(.: "value")|] `appE` (varE obj)) + , guardConName conName val + , noBindS (expr conName val)] + , matchFailed tName conName "Object" + ] + +recWrapper :: Name -> Name -> (String -> String) -> Name -> [VarStrictType] -> [ExpQ] +recWrapper tName conName withField obj ts = + [ do + b <- isInstance ''Default [ty] + [|lookupField|] + `appE` (if b then [| Just def |] else [| Nothing|]) + `appE` (litE $ stringL $ show tName) + `appE` (litE $ stringL $ nameBase conName) + `appE` (varE obj) + `appE` ( [e|T.pack|] + `appE` + fieldNameExp withField field + ) + | (field, _, ty) <- ts] + + +-- | Generates code to parse the JSON encoding of a single constructor. +parseArgs :: Name -- ^ Name of the type to which the constructor belongs. + -> (String -> String) -- ^ Function to change field names. + -> Bool -- ^ Whether there are multiple constructors + -> Con -- ^ Constructor for which to generate JSON parsing code. + -> [Q Match] +-- Nullary constructors. +parseArgs tName _ _ (NormalC conName []) = + [ do str <- newName "str" + match (conP 'String [varP str]) + ( normalB $ + caseE (varE str) + [ match (litP $ stringL $ nameBase conName) (normalB $ [e|return|] `appE` conE conName) [] + , match wildP (normalB $ wrongEnumerationError tName str) [] + ] + ) [] + , matchFailed tName conName "String" + ] +-- Unary constructors. +parseArgs _ _ False (NormalC conName [_]) = + [ do arg <- newName "arg" + match (varP arg) + ( normalB $ infixApp (conE conName) + [e|(<$>)|] + ([e|parseJSON|] `appE` varE arg) + ) + [] + ] +parseArgs tName _ True (NormalC conName [_]) = + objectWrapper tName conName (\con val-> infixApp (conE con) [e|(<$>)|] ([e|parseJSON|] `appE` varE val)) + +-- Polyadic constructors. +parseArgs tName _ False (NormalC conName ts) = parseProduct tName conName $ genericLength ts +parseArgs tName _ True (NormalC conName ts) = + objectWrapper tName conName (\con val-> caseE (varE val) (parseProduct tName con $ genericLength ts)) + +-- Records. +parseArgs tName withField False (RecC conName ts) = + [ do obj <- newName "recObj" + let x:xs = recWrapper tName conName withField obj ts + match (conP 'Object [varP obj]) + ( normalB $ ( foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) + xs + ) + ) + [] + , matchFailed tName conName "Object" + ] + +parseArgs tName withField True (RecC conName ts) = + [ do obj <- newName "recObj" + let xs = recWrapper tName conName withField obj ts + x = [|lookupField Nothing|] + `appE` (litE $ stringL $ show tName) + `appE` (litE $ stringL $ nameBase conName) + `appE` (varE obj) + `appE` (litE $ stringL "constructor") + match (conP 'Object [varP obj]) + ( normalB $ ( foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) + xs + ) + ) + [] + , matchFailed tName conName "Object" + ] + +-- Infix constructors. Apart from syntax these are the same as +-- polyadic constructors. +parseArgs tName _ False (InfixC _ conName _) = parseProduct tName conName 2 + +parseArgs tName _ True (InfixC _ conName _) = + objectWrapper tName conName (\con val -> caseE (varE val) (parseProduct tName con 2)) + +-- Existentially quantified constructors. We ignore the quantifiers +-- and proceed with the contained constructor. +parseArgs tName withField b (ForallC _ _ con) = parseArgs tName withField b con + + +-- | Generates code to parse the JSON encoding of an n-ary +-- constructor. +parseProduct :: Name -- ^ Name of the type to which the constructor belongs. + -> Name -- ^ 'Con'structor name. + -> Integer -- ^ 'Con'structor arity. + -> [Q Match] +parseProduct tName conName numArgs = + [ do arr <- newName "arr" + -- List of: "parseJSON (arr `V.unsafeIndex` )" + let x:xs = [ [|parseJSON|] + `appE` + infixApp (varE arr) + [|V.unsafeIndex|] + (litE $ integerL ix) + | ix <- [0 .. numArgs - 1] + ] + match (conP 'Array [varP arr]) + (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr) + [|(==)|] + (litE $ integerL numArgs) + ) + ( foldl' (\a b -> infixApp a [|(<*>)|] b) + (infixApp (conE conName) [|(<$>)|] x) + xs + ) + ( parseTypeMismatch tName conName + (litE $ stringL $ "Array of length " ++ show numArgs) + ( infixApp (litE $ stringL $ "Array of length ") + [|(++)|] + ([|show . V.length|] `appE` varE arr) + ) + ) + ) + [] + , matchFailed tName conName "Array" + ] + +lookupField :: (FromJSON a) => Maybe a -> String -> String -> Object -> T.Text -> Parser a +lookupField d tName rec obj key = + case H.lookup key obj of + Nothing -> case d of + Nothing -> unknownFieldFail tName rec (T.unpack key) + Just x -> return x + Just v -> parseJSON v + +-------------------------------------------------------------------------------- +-- Parsing errors +-------------------------------------------------------------------------------- + +matchFailed :: Name -> Name -> String -> MatchQ +matchFailed tName conName expected = do + other <- newName "other" + match (varP other) + ( normalB $ parseTypeMismatch tName conName + (litE $ stringL expected) + ([|valueConName|] `appE` varE other) + ) + [] + +parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ +parseTypeMismatch tName conName expected actual = + foldl appE + [|parseTypeMismatch'|] + [ litE $ stringL $ nameBase conName + , litE $ stringL $ show tName + , expected + , actual + ] + +wrongEnumerationError :: Name -> Name -> ExpQ +wrongEnumerationError tName str = + [|wrongEnumerationError'|] `appE` (litE $ stringL $ nameBase tName) `appE` ([|T.unpack|] `appE` varE str) + +unknownFieldFail :: String -> String -> String -> Parser fail +unknownFieldFail tName rec key = + fail $ printf "When parsing the record %s of type %s the key %s was not present." + rec tName key + +noObjectFail :: String -> String -> Parser fail +noObjectFail t o = + fail $ printf "When parsing %s expected Object but got %s." t o + +wrongPairCountFail :: String -> String -> Parser fail +wrongPairCountFail t n = + fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs." + t n + +conNotFoundFail :: String -> [String] -> String -> Parser fail +conNotFoundFail t cs o = + fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s." + t (intercalate ", " cs) o + +parseTypeMismatch' :: String -> String -> String -> String -> Parser fail +parseTypeMismatch' tName conName expected actual = + fail $ printf "When parsing the constructor %s of type %s expected %s but got %s." + conName tName expected actual + +wrongEnumerationError' :: String -> String -> Parser fail +wrongEnumerationError' tName str = fail $ printf (str ++ " is not a data constructor for type " ++ tName) + +-------------------------------------------------------------------------------- +-- Utility functions +-------------------------------------------------------------------------------- + +-- | Boilerplate for top level splices. +-- +-- The given 'Name' must be from a type constructor. Furthermore, the +-- type constructor must be either a data type or a newtype. Any other +-- value will result in an exception. +withType :: Name + -> ([TyVarBndr] -> [Con] -> Q a) + -- ^ Function that generates the actual code. Will be applied + -- to the type variable binders and constructors extracted + -- from the given 'Name'. + -> Q a + -- ^ Resulting value in the 'Q'uasi monad. +withType name f = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD _ _ tvbs cons _ -> f tvbs cons + NewtypeD _ _ tvbs con _ -> f tvbs [con] + other -> error $ "Data.Aeson.TH.withType: Unsupported type: " + ++ show other + _ -> error "Data.Aeson.TH.withType: I need the name of a type." + +-- | Extracts the name from a constructor. +getConName :: Con -> Name +getConName (NormalC name _) = name +getConName (RecC name _) = name +getConName (InfixC _ name _) = name +getConName (ForallC _ _ con) = getConName con + +guardConName :: Name -> Name -> Q Stmt +guardConName conName varName = noBindS (infixApp (litE $ stringL $ nameBase conName) [e|(==)|] (varE varName)) + +-- | Extracts the name from a type variable binder. +tvbName :: TyVarBndr -> Name +tvbName (PlainTV name ) = name +tvbName (KindedTV name _) = name + +-- | Makes a string literal expression from a constructor's name. +conNameExp :: Con -> Q Exp +conNameExp = litE . stringL . nameBase . getConName + +-- | Creates a string literal expression from a record field name. +fieldNameExp :: (String -> String) -- ^ Function to change the field name. + -> Name + -> Q Exp +fieldNameExp f = litE . stringL . f . nameBase + +-- | The name of the outermost 'Value' constructor. +valueConName :: Value -> String +valueConName (Object _) = "Object" +valueConName (Array _) = "Array" +valueConName (String _) = "String" +valueConName (Number _) = "Number" +valueConName (Bool _) = "Boolean" +valueConName Null = "Null" diff --git a/Data/Default/TH.hs b/Data/Default/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Default/TH.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Default.TH (deriveDefault) where + +import Control.Applicative +import Data.Default +import Data.List +import Language.Haskell.TH + +createInstance :: Name -> [Name] -> Name -> [Type] -> Q Dec +createInstance typeConstructorName typeVariables constructorName constructorArgumentTypes = do + let reqs = constraints typeVariables + return $ InstanceD reqs + (AppT (ConT ''Default) (foldl' (\x y -> AppT x (VarT y)) (ConT typeConstructorName) typeVariables)) + [FunD 'def [Clause [] (NormalB (foldl' (\x _ -> AppE x (VarE 'def)) (ConE constructorName) constructorArgumentTypes)) []]] + +constraints :: [Name] -> [Pred] +constraints = map (ClassP ''Default . return . VarT) + +instanceQ :: Name -> [TyVarBndr] -> Name -> [Type] -> Q [Dec] +instanceQ t vs c as = return <$> createInstance t (map name vs) c as + +name :: TyVarBndr -> Name +name (PlainTV n) = n +name (KindedTV n k) = n + +deriveDefault :: Name -> Q [Dec] +deriveDefault n = do + info <- reify n + case info of + TyConI (DataD _ qn tvars (con:_) _) -> case con of + NormalC conName ts -> instanceQ qn tvars conName (map snd ts) + RecC conName ts -> instanceQ qn tvars conName (map (\(v,s,t) -> t) ts) + InfixC t conName t' -> instanceQ qn tvars conName (map snd [t, t']) + _ -> fail $ "Dunno how to derive Default instances for existential types" + TyConI (DataD _ _ _ [] _) -> fail $ "Really? You want to derive a Default instance for an uninhabited type?" + _ -> fail $ "Couldn't derive a Default instance; didn't know what to do with " ++ pprint info diff --git a/Database/Cypher.hs b/Database/Cypher.hs new file mode 100644 --- /dev/null +++ b/Database/Cypher.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, FlexibleInstances #-} +module Database.Cypher ( + Cypher, + Entity, + CypherResult(..), + runCypher, + cypher, + CypherException(..), + Hostname, + Port, + OneTuple(..) + ) where + +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Network.HTTP.Conduit +import Network.HTTP.Types +import Data.Conduit +import Data.Typeable +import Data.Text (Text) +import Data.Tuple.OneTuple +import Control.Exception +import Control.Applicative +import Control.Monad +import Data.Monoid +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +data DBInfo = DBInfo Hostname Port Manager +type Hostname = S.ByteString +type Port = Int + +-- | All interaction with Neo4j is done through the Cypher monad. Use 'cypher' to add a query to the monad. +newtype Cypher a = Cypher { + uncypher :: (DBInfo -> ResourceT IO a) +} + +-- | Raw result data returned by Neo4j. Only use this if you care about column headers. +data CypherResult a = CypherResult { + rescolumns :: [Text], + resdata :: a +} deriving (Show, Eq) + +data CypherRequest = CypherRequest { + req_query :: Text, + req_params :: Value +} deriving (Show, Eq) + +-- | A neo4j node or edge +data Entity a = Entity { + entity_id :: Text, + entity_data :: a +} deriving (Show, Eq) + +instance FromJSON a => FromJSON (Entity a) where + parseJSON (Object v) = Entity <$> + v .: "self" <*> + v .: "data" + parseJSON _ = mempty + +instance ToJSON (Entity a) where + toJSON = toJSON . entity_id + +instance FromJSON a => FromJSON (OneTuple a) where + parseJSON x = do + [l] <- parseJSON x + return $ OneTuple l + +instance ToJSON a => ToJSON (OneTuple a) where + toJSON = toJSON . (\x->[x]) + +$(deriveJSON (drop 3) ''CypherResult) +$(deriveJSON (drop 4) ''CypherRequest) + +-- | An error in handling a Cypher query, either in communicating with the server or parsing the result +data CypherException = CypherServerException Status ResponseHeaders L.ByteString | + CypherClientParseException S.ByteString deriving (Show, Typeable) +instance Exception CypherException + +throwClientParse bs = throw $ CypherClientParseException $ S.concat $ L.toChunks bs + +instance Monad Cypher where + return a = Cypher (const (return a)) + (Cypher cmd) >>= f = + Cypher $ \con-> do + a <- cmd con + uncypher (f a) con + +class FromCypher a where + fromCypher :: L.ByteString -> a + +instance FromCypher () where + fromCypher _ = () + +instance FromJSON a => FromCypher (CypherResult a) where + fromCypher bs = + case decode bs of + Just x -> x + Nothing -> throwClientParse bs + +instance FromJSON a => FromCypher [a] where + fromCypher bs = +  case decode bs of + Just (CypherResult _ ds) -> ds + _ -> throwClientParse bs + +instance FromJSON a => FromCypher (OneTuple a) where + fromCypher bs = + case decode bs of + Just (CypherResult _ [d]) -> d + _ -> throwClientParse bs + +instance (FromJSON a, FromJSON b) => FromCypher (a,b) where + fromCypher bs = + case decode bs of + Just (CypherResult _ [d]) -> d + _ -> throwClientParse bs + +instance (FromJSON a, FromJSON b, FromJSON c) => FromCypher (a,b,c) where + fromCypher bs = + case decode bs of + Just (CypherResult _ [d]) -> d + _ -> throwClientParse bs + +instance FromJSON a => FromCypher (Maybe a) where + fromCypher bs = + case decode bs of + Just (CypherResult _ [a]) -> Just a + Just (CypherResult _ []) -> Nothing + _ -> throwClientParse bs + +-- | Perform a cypher query +cypher :: FromCypher a => Text -> Value -> Cypher a +cypher txt params = Cypher $ \(DBInfo h p m)-> do + let req = def { host = h, port = p, + path = "db/data/cypher", + requestBody = RequestBodyLBS (encode $ CypherRequest txt params), + requestHeaders = headerAccept "application/json" : headerContentType "application/json" : requestHeaders def, + method = "POST", + checkStatus = (\_ _-> Nothing) + } + r <- httpLbs req m + let sci = statusCode (responseStatus r) + if 200 <= sci && sci < 300 then return (fromCypher (responseBody r)) + else throw $ CypherServerException (responseStatus r) (responseHeaders r) (responseBody r) + +-- | Execute some number of cypher queries +runCypher :: Cypher a -> Hostname -> Port -> IO a +runCypher c h p = + runResourceT $ do + manager <- liftIO $ newManager def + uncypher c (DBInfo h p manager) + diff --git a/Database/Cypher/Lucene.hs b/Database/Cypher/Lucene.hs new file mode 100644 --- /dev/null +++ b/Database/Cypher/Lucene.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +-- Code shamelessly copied from Data.Aeson.Encode by MailRank, Inc. + +module Database.Cypher.Lucene (luceneEncode) where +import Data.Aeson.Types (ToJSON(..), Value(..)) +import Data.Attoparsec.Number (Number(..)) +import Data.Monoid +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text.Lazy.Builder +import Data.Text.Lazy.Builder.Int (decimal) +import Data.Text.Lazy.Builder.RealFloat (realFloat) +import Numeric (showHex) +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Vector as V + + +fromValue :: Value -> Builder +fromValue Null = mempty +fromValue (Bool b) = if b then "true" else "false" +fromValue (Number n) = fromNumber n +fromValue (String s) = string s +fromValue (Array v) + | V.null v = mempty + | otherwise = singleton '(' <> + fromValue (V.unsafeHead v) <> + V.foldr f (singleton ')') (V.unsafeTail v) + where f a z = " OR " <> fromValue a <> z +fromValue (Object m) = + case H.toList m of + (x:xs) -> one x <> foldr f mempty xs + _ -> mempty + where f a z = let n = one a in if n == "" then z else " AND " <> n <> z + one (k,v) = let n = fromValue v in if n == "" then n else fromText k <> singleton ':' <> n + +string :: T.Text -> Builder +string s = singleton '"' <> quote s <> singleton '"' + where + quote q = case T.uncons t of + Nothing -> fromText h + Just (!c,t') -> fromText h <> escape c <> quote t' + where (h,t) = {-# SCC "break" #-} T.break isEscape q + isEscape c = c == '\"' || c == '\\' || c < '\x20' + escape '\"' = "\\\"" + escape '\\' = "\\\\" + escape '\n' = "\\n" + escape '\r' = "\\r" + escape '\t' = "\\t" + escape c + | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h + | otherwise = singleton c + where h = showHex (fromEnum c) "" + +fromNumber :: Number -> Builder +fromNumber (I i) = decimal i +fromNumber (D d) + | isNaN d || isInfinite d = "null" + | otherwise = realFloat d + +-- | Convert an object to a Lucene query encoded as an 'L.ByteString'. +luceneEncode :: ToJSON a => a -> L.ByteString +luceneEncode = encodeUtf8 . toLazyText . fromValue . toJSON diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Sam Anklesaria, Lasso Inc + +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 Sam Anklesaria 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/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/cypher.cabal b/cypher.cabal new file mode 100644 --- /dev/null +++ b/cypher.cabal @@ -0,0 +1,73 @@ +-- cypher.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: cypher + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: Haskell bindings for the neo4j "cypher" query language +Description: haskell-cypher makes it easy to send cypher commands to neo4j servers over their REST API. + Additionally, it allows users to parse haskell datatypes from "cypher" queries. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Sam Anklesaria + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: amsay@amsay.net + +-- A copyright notice. +-- Copyright: + +Category: Database + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + +source-repository head + type: git + location: git://github.com/lassoinc/haskell-cypher.git + +Library + -- Modules exported by the library. + Exposed-modules: Database.Cypher, Database.Cypher.Lucene, Data.Aeson.TH.Smart, Data.Default.TH + + -- Packages needed in order to build this package. + Build-depends: base < 5 + , aeson + , http-conduit + , transformers + , conduit + , text + , bytestring + , http-types <1 + , vector <1 + , unordered-containers <1 + , attoparsec <1 + , OneTuple <1 + , data-default <1 + , template-haskell >= 2.7 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: +