packages feed

cypher 0.2 → 0.4

raw patch · 6 files changed

+232/−109 lines, 6 filesdep −OneTuple

Dependencies removed: OneTuple

Files

Data/Aeson/TH/Smart.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-} -- Shamelessly copied from Bryan O'Sullivan, 2011 --- EVENTUALLY MAKE THIS WORK BY GETTING THE CONSTRUCTOR BEFOREHAND.--- - module Data.Aeson.TH.Smart     ( deriveJSON @@ -37,7 +34,7 @@                            ) import Data.Maybe          ( Maybe(Nothing, Just) ) import Prelude             ( String, (-), Integer, fromIntegral, not,-                             error, filter, fst, snd, Bool(..), flip, maybe)+                             error, filter, fst, snd, Bool(..), flip, maybe, (>)) import Text.Printf         ( printf ) import Text.Show           ( show ) #if __GLASGOW_HASKELL__ < 700@@ -210,7 +207,7 @@                                     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])))+                 [e|\x-> if V.length x > 0 then Array x else Null|] `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]@@ -223,7 +220,7 @@              | (arg, (field, _, _)) <- zip args' ts              ]     let b = case withExp of-              Nothing -> [e|object|] `appE` ([e| filter (not . (==Null) . snd) |] `appE` listE js)+              Nothing -> [e|object|] `appE` ([e| filter (not . disposable . snd) |] `appE` listE js)               (Just wrapper) -> wrapper js     match (conP conName $ map varP args) (normalB b) [] -- Infix constructors.@@ -239,6 +236,10 @@ encodeArgs withExp withField (ForallC _ _ con) =     encodeArgs withExp withField con +disposable Null = True+disposable (Array x) = V.null x+disposable _ = False+ -------------------------------------------------------------------------------- -- FromJSON --------------------------------------------------------------------------------@@ -390,8 +391,8 @@     match (conP 'Object [varP obj])       (guardedB [tupSeq (conGuard mcon conName, foldl' (\a b -> infixApp a [|(<*>)|] b)                     (infixApp (conE conName) [|(<$>)|] x) xs)]) []-parseArgs tName _ (InfixC _ conName _) mcon = parseProduct tName conName 2 mcon-parseArgs tName withField (ForallC _ _ con) mcon = parseArgs tName withField con mcon+parseCon tName _ (InfixC _ conName _) mcon = parseProduct tName conName 2 mcon+parseCon tName withField (ForallC _ _ con) mcon = parseCon tName withField con mcon   -- | Generates code to parse the JSON encoding of an n-ary
+ Data/Default/NewTH.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Default.NewTH (deriveDefault) where++import Control.Applicative+import Data.Default+import Data.List+import Language.Haskell.TH++createInstance :: Bool -> Name -> [Name] -> Name -> [Type] -> Q Dec+createInstance b typeConstructorName typeVariables constructorName constructorArgumentTypes = do+	return $ InstanceD (if b then constraints typeVariables else [])+		(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 :: Bool -> Name -> [TyVarBndr] -> Name -> [Type] -> Q [Dec]+instanceQ b t vs c as = return <$> createInstance b t (map name vs) c as++name :: TyVarBndr -> Name+name (PlainTV n) = n+name (KindedTV n k) = n++deriveDefault :: Bool -> Name -> Q [Dec]+deriveDefault b n = do+	info <- reify n+	case info of+		TyConI (DataD _ qn tvars (con:_) _) -> case con of+			NormalC  conName ts -> instanceQ b qn tvars conName (map snd ts)+			RecC     conName ts -> instanceQ b qn tvars conName (map (\(v,s,t) -> t) ts)+			InfixC t conName t' -> instanceQ b 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
− Data/Default/TH.hs 
@@ -1,36 +0,0 @@-{-# 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
Database/Cypher.hs view
@@ -1,16 +1,30 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, FlexibleInstances #-} module Database.Cypher ( 	Cypher,-	Entity,+	Entity(..), 	CypherResult(..),+	LuceneQuery, 	runCypher, 	cypher,+	cypherGetNode,+	cypherCreate,+	cypherGet,+	cypherSet,+	luceneEncode,+	withCypherManager, 	CypherException(..),+	DBInfo(..), 	Hostname, 	Port,-	OneTuple(..)+	CypherVal(..),+	CypherVals(..),+	CypherCol(..),+	CypherCols(..),+	CypherMaybe(..),+	CypherUnit(..) 	) where +import Database.Cypher.Lucene import Data.Aeson import Data.Aeson.TH import Data.Aeson.Types@@ -19,22 +33,31 @@ 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 Control.Monad.IO.Class import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import Data.Text.Lazy.Encoding (encodeUtf8)+import qualified Data.HashMap.Strict as H+import Data.Text.Lazy.Builder+import Data.Aeson.Encode -data DBInfo = DBInfo Hostname Port Manager+-- | Information about your neo4j configuration needed to make requests over the REST api.+data DBInfo = DBInfo {+	cypher_hostname :: Hostname,+	cypher_port :: Port+} deriving (Show, Eq)+ type Hostname = S.ByteString type Port = Int+$(deriveJSON (drop 7) ''DBInfo)  -- | 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)+	uncypher :: ((DBInfo, Manager) -> ResourceT IO a) }  -- | Raw result data returned by Neo4j. Only use this if you care about column headers.@@ -43,6 +66,24 @@ 	resdata :: a } deriving (Show, Eq) +-- | A single result returned by Neo4j.+newtype CypherVal a = CypherVal a deriving (Eq, Show)++-- | A single column returned by Neo4j.+newtype CypherCol a = CypherCol a deriving (Eq, Show)++-- | Columns returned by Neo4j.+newtype CypherCols a = CypherCols a deriving (Eq, Show)++-- | Values returned by Neo4j.+newtype CypherVals a = CypherVals [a] deriving (Eq, Show)++-- | Possibly a value returned by Neo4j+data CypherMaybe a = CypherJust a | CypherNothing deriving (Eq, Show)++-- | No value returned from Neo4j+data CypherUnit = CypherUnit deriving (Show)+ data CypherRequest = CypherRequest { 	req_query :: Text, 	req_params :: Value@@ -50,27 +91,21 @@  -- | A neo4j node or edge data Entity a = Entity {-	entity_id :: Text,+	entity_id :: String,+	entity_properties :: String, 	entity_data :: a } deriving (Show, Eq)  instance FromJSON a => FromJSON (Entity a) where 	parseJSON (Object v) = Entity <$> 							v .: "self" <*>+							v .: "properties" <*> 							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) @@ -88,52 +123,45 @@ 			a <- cmd con 			uncypher (f a) con -class FromCypher a where-	fromCypher :: L.ByteString -> a+instance MonadIO Cypher where+	liftIO f = Cypher $ const (liftIO f) -instance FromCypher () where-	fromCypher _ = ()+instance FromJSON a => FromJSON (CypherVal a) where+	parseJSON x = do+		(CypherResult _ [[d]]) <- parseJSON x+		return $ CypherVal d -instance FromJSON a => FromCypher (CypherResult a) where-	fromCypher bs = -		case decode bs of-			Just x -> x-			Nothing -> throwClientParse bs+instance FromJSON a => FromJSON (CypherCol a) where+	parseJSON x = do+		(CypherResult _ [d]) <- parseJSON x+		return $ CypherCol d -instance FromJSON a => FromCypher [a] where-	fromCypher bs =- 		case decode bs of-			Just (CypherResult _ ds) -> ds-			_ -> throwClientParse bs+instance FromJSON a => FromJSON (CypherCols a) where+	parseJSON x = do+		(CypherResult _ d) <- parseJSON x+		return $ CypherCols d -instance FromJSON a => FromCypher (OneTuple a) where-	fromCypher bs =-		case decode bs of-			Just (CypherResult _ [d]) -> d-			_ -> throwClientParse bs+instance FromJSON a => FromJSON (CypherVals a) where+	parseJSON x = do+		(CypherResult _ d) <- parseJSON x+		liftM CypherVals (mapM safeHead d) -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 (CypherMaybe a) where+	parseJSON x = do+		(CypherResult _ ds) <- parseJSON x+		case ds of+			[[d]] -> return $ CypherJust d+			_ -> return CypherNothing -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 CypherUnit where parseJSON _ = return CypherUnit -instance FromJSON a => FromCypher (Maybe a) where-	fromCypher bs =-		case decode bs of-			Just (CypherResult _ [a]) -> Just a-			Just (CypherResult _ []) -> Nothing-			_ -> throwClientParse bs+safeHead :: [a] -> Parser a+safeHead [a] = return a+safeHead _ = mzero  -- | Perform a cypher query-cypher :: FromCypher a => Text -> Value -> Cypher a-cypher txt params = Cypher $ \(DBInfo h p m)-> do+cypher :: FromJSON 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),@@ -143,13 +171,77 @@ 				  } 	r <- httpLbs req m 	let sci = statusCode (responseStatus r)-	if 200 <= sci && sci < 300 then return (fromCypher (responseBody r))+	if 200 <= sci && sci < 300+		then (case decode (responseBody r) of+				Nothing -> throwClientParse (responseBody r)+				Just x-> return x) 		else throw $ CypherServerException (responseStatus r) (responseHeaders r) (responseBody r) +-- | Create a cypher node+cypherCreate :: (ToJSON a, FromJSON b) => a -> Cypher b+cypherCreate obj = Cypher $ \(DBInfo h p, m)-> do+	let req = def { host = h, port = p,+					path = "db/data/node",+					requestBody = RequestBodyLBS (encode obj),+					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 (case decode (responseBody r) of+				Nothing -> throwClientParse (responseBody r)+				Just x-> return x)+		else throw $ CypherServerException (responseStatus r) (responseHeaders r) (responseBody r)++-- | Get a cypher node+cypherGetNode :: FromJSON b => Entity b -> Cypher (Entity b)+cypherGetNode e = Cypher $ \(DBInfo h p, m)-> do+	req <- liftIO $ parseUrl (entity_id e)+	let req' = req { host = h, port = p,+					requestHeaders = headerAccept "application/json" : headerContentType "application/json" : requestHeaders def,+					method = "GET",+					checkStatus = (\_ _-> Nothing)+				  }+	r <- httpLbs req m+	let sci = statusCode (responseStatus r)+	if 200 <= sci && sci < 300+		then (case decode (responseBody r) of+				Nothing -> throwClientParse (responseBody r)+				Just x-> return x)+		else throw $ CypherServerException (responseStatus r) (responseHeaders r) (responseBody r)++-- | Set cypher properties. This currently cannot be done through cypher queries.+cypherSet :: (ToJSON a, ToJSON a1) => (Entity a) -> a1 -> Cypher ()+cypherSet e obj = Cypher $ \(DBInfo h p, m)-> do+	let Object o1 = toJSON (entity_data e)+	let Object o2 = toJSON obj+	let body = RequestBodyLBS $ encodeUtf8 $ toLazyText $ fromValue $ Object (o2 `H.union` o1)+	req <- liftIO $ parseUrl (entity_properties e)+	let req' = req { host = h, port = p,+					requestBody = body,+					requestHeaders = headerAccept "application/json" : headerContentType "application/json" : requestHeaders def,+					method = "PUT",+					checkStatus = (\_ _-> Nothing)+				  }+	r <- httpLbs req' m+	let sci = statusCode (responseStatus r)+	if 200 <= sci && sci < 300+		then return ()+		else (let e = CypherServerException (responseStatus r) (responseHeaders r) (responseBody r)+			 in traceShow e (throw e))++-- | Get the nodes matching the given lucene query+cypherGet :: (ToJSON a1, FromJSON a) => a1 -> Cypher a+cypherGet lc = cypher "start a = node:node_auto_index({lc}) return a" $ object ["lc" .= lc]++-- | Get the http connection manager for a Cypher monad+withCypherManager :: (Manager -> ResourceT IO a) -> Cypher a+withCypherManager f = Cypher (\(_,m)-> f m)+ -- | Execute some number of cypher queries-runCypher :: Cypher a -> Hostname -> Port -> IO a-runCypher c h p =+runCypher :: Cypher a -> DBInfo -> Manager -> IO a+runCypher c dbi m = 	runResourceT $ do-    	manager <- liftIO $ newManager def-    	uncypher c (DBInfo h p manager)-+    	uncypher c (dbi, m)
Database/Cypher/Lucene.hs view
@@ -1,21 +1,51 @@ {-# LANGUAGE BangPatterns, OverloadedStrings #-} -- Code shamelessly copied from Data.Aeson.Encode by MailRank, Inc. -module Database.Cypher.Lucene (luceneEncode) where+module Database.Cypher.Lucene (+  luceneEncode, LuceneQuery,+  (.>.), (.<.), (.=.), (.&.), (.|.), (.-.),+  to, xto+  ) 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.Text.Lazy.Encoding as LE import qualified Data.HashMap.Strict as H import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified Data.Vector as V +type LuceneQuery = L.ByteString +(.>.) :: ToJSON a => T.Text -> a -> LuceneQuery+t .>. o = L.fromChunks[TE.encodeUtf8 t] <> LE.encodeUtf8 " > " <> luceneEncode o++(.<.) :: ToJSON a => T.Text -> a -> LuceneQuery+t .<. o = L.fromChunks[TE.encodeUtf8 t] <> LE.encodeUtf8 " < " <> luceneEncode o++(.=.) :: ToJSON a => T.Text -> a -> LuceneQuery+t .=. o = L.fromChunks[TE.encodeUtf8 t] <> LE.encodeUtf8 " = " <> luceneEncode o++(.&.) :: LuceneQuery -> LuceneQuery -> LuceneQuery+a .&. b =  a <> LE.encodeUtf8 " AND " <> b++(.|.) :: LuceneQuery -> LuceneQuery -> LuceneQuery+a .|. b = a <> LE.encodeUtf8 " OR " <> b++(.-.) :: LuceneQuery -> LuceneQuery -> LuceneQuery+a .-. b = a <> LE.encodeUtf8 " NOT " <> b++to :: ToJSON a => a -> a -> LuceneQuery+a `to` b = LE.encodeUtf8 "[" <> luceneEncode a <> LE.encodeUtf8 " TO " <> luceneEncode b <> LE.encodeUtf8 "]"++xto :: ToJSON a => a -> a -> LuceneQuery+a `xto` b = LE.encodeUtf8 "{" <> luceneEncode a <> LE.encodeUtf8 " TO " <> luceneEncode b <> LE.encodeUtf8 "}"+ fromValue :: Value -> Builder fromValue Null = mempty fromValue (Bool b) = if b then "true" else "false"@@ -59,5 +89,6 @@     | 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+luceneEncode :: ToJSON a => a -> LuceneQuery+luceneEncode = LE.encodeUtf8 . toLazyText . fromValue . toJSON+
cypher.cabal view
@@ -7,7 +7,7 @@ -- 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.2+Version:             0.4  -- A short (one-line) description of the package. Synopsis:            Haskell bindings for the neo4j "cypher" query language@@ -47,7 +47,7 @@  Library   -- Modules exported by the library.-  Exposed-modules:     Database.Cypher, Database.Cypher.Lucene, Data.Aeson.TH.Smart, Data.Default.TH+  Exposed-modules:     Database.Cypher, Database.Cypher.Lucene, Data.Aeson.TH.Smart, Data.Default.NewTH      -- Packages needed in order to build this package.   Build-depends:         base < 5@@ -61,7 +61,6 @@                        , vector <1                        , unordered-containers <1                        , attoparsec <1-                       , OneTuple <1                        , data-default <1                        , template-haskell >= 2.7