module Database.Cypher (
Cypher,
Entity(..),
CypherResult(..),
LuceneQuery,
runCypher,
cypher,
cypherGetNode,
cypherCreate,
cypherGet,
cypherSet,
luceneEncode,
withCypherManager,
CypherException(..),
DBInfo(..),
Hostname,
Port,
CypherVal(..),
CypherVals(..),
CypherCol(..),
CypherCols(..),
CypherMaybe(..),
CypherUnit(..)
) where
import Database.Cypher.Lucene
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 Control.Exception
import Control.Applicative
import Control.Monad
import Data.Monoid
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
import Data.List (elemIndices)
data DBInfo = DBInfo {
cypher_hostname :: Hostname,
cypher_port :: Port
} deriving (Show, Eq)
type Hostname = S.ByteString
type Port = Int
$(deriveJSON (drop 7) ''DBInfo)
newtype Cypher a = Cypher {
uncypher :: ((DBInfo, Manager) -> ResourceT IO a)
}
data CypherResult a = CypherResult {
rescolumns :: [Text],
resdata :: a
} deriving (Show, Eq)
newtype CypherVal a = CypherVal a deriving (Eq, Show)
newtype CypherCol a = CypherCol a deriving (Eq, Show)
newtype CypherCols a = CypherCols a deriving (Eq, Show)
newtype CypherVals a = CypherVals [a] deriving (Eq, Show)
data CypherMaybe a = CypherJust a | CypherNothing deriving (Eq, Show)
data CypherUnit = CypherUnit deriving (Show)
data CypherRequest = CypherRequest {
req_query :: Text,
req_params :: Value
} deriving (Show, Eq)
data Entity a = Entity {
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 a = toJSON (read x :: Int) where
(_, _:x) = splitAt (last (elemIndices '/' (entity_id a))) (entity_id a)
$(deriveJSON (drop 3) ''CypherResult)
$(deriveJSON (drop 4) ''CypherRequest)
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
instance MonadIO Cypher where
liftIO f = Cypher $ const (liftIO f)
instance FromJSON a => FromJSON (CypherVal a) where
parseJSON x = do
(CypherResult _ [[d]]) <- parseJSON x
return $ CypherVal d
instance FromJSON a => FromJSON (CypherCol a) where
parseJSON x = do
(CypherResult _ [d]) <- parseJSON x
return $ CypherCol d
instance FromJSON a => FromJSON (CypherCols a) where
parseJSON x = do
(CypherResult _ d) <- parseJSON x
return $ CypherCols d
instance FromJSON a => FromJSON (CypherVals a) where
parseJSON x = do
(CypherResult _ d) <- parseJSON x
liftM CypherVals (mapM safeHead d)
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 CypherUnit where parseJSON _ = return CypherUnit
safeHead :: [a] -> Parser a
safeHead [a] = return a
safeHead _ = mzero
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),
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)
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)
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)
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 throw e)
cypherGet :: (ToJSON a1, FromJSON a) => a1 -> Cypher a
cypherGet lc = cypher "start a = node:node_auto_index({lc}) return a" $ object ["lc" .= lc]
withCypherManager :: (Manager -> ResourceT IO a) -> Cypher a
withCypherManager f = Cypher (\(_,m)-> f m)
runCypher :: Cypher a -> DBInfo -> Manager -> IO a
runCypher c dbi m =
runResourceT $ do
uncypher c (dbi, m)