module Database.Neo4j.Batch.Types where
import Control.Exception.Base (throw)
import Data.Aeson ((.=), (.:))
import Data.Maybe (fromMaybe)
import Control.Monad.State (state, State, runState)
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as V
import qualified Network.HTTP.Types as HT
import Database.Neo4j.Graph
import Database.Neo4j.Http
import Database.Neo4j.Types
newtype BatchFuture a = BatchFuture Int
type CmdParser = J.Value -> Graph -> Graph
data BatchCmd = BatchCmd {cmdMethod :: HT.Method, cmdPath ::T.Text, cmdBody :: J.Value,
cmdParse :: CmdParser, cmdId :: Int}
defCmd :: BatchCmd
defCmd = BatchCmd{cmdMethod = HT.methodGet, cmdPath = "", cmdBody = "", cmdParse = \_ g -> g, cmdId = 1}
data BatchState = BatchState {commands :: [BatchCmd], batchId :: Int}
type Batch a = State BatchState a
getCmds :: Batch a -> [BatchCmd]
getCmds s = let (_, BatchState cmds _) = runState s (BatchState [] (1)) in reverse cmds
instance J.ToJSON (Batch a) where
toJSON b = J.toJSON $ getCmds b
instance J.ToJSON BatchCmd where
toJSON (BatchCmd m p b _ cId) = J.object ["method" .= TE.decodeUtf8 m, "to" .= p, "body" .= b, "id" .= cId]
tryParseBody :: J.FromJSON a => J.Value -> a
tryParseBody (J.Object jb) = let res = flip JT.parseEither jb $ \obj -> (obj .: "body") >>= J.parseJSON
in case res of
Right entity -> entity
Left e -> throw $ Neo4jParseException ("Error parsing entity: " ++ e)
tryParseBody _ = throw $ Neo4jParseException "Error expecting an object"
tryParseFrom :: J.FromJSON a => J.Value -> a
tryParseFrom (J.Object jb) = let res = flip JT.parseEither jb $ \obj -> (obj .: "from") >>= J.parseJSON
in case res of
Right entity -> entity
Left e -> throw $ Neo4jParseException ("Error parsing entity: " ++ e)
tryParseFrom _ = throw $ Neo4jParseException "Error expecting an object"
nextState :: BatchCmd -> Batch (BatchFuture a)
nextState cmd = state $ \(BatchState cmds cId) ->
(BatchFuture $ cId + 1, BatchState (cmd{cmdId = cId + 1} : cmds) (cId + 1))
parseBatchResponse :: J.Array -> Batch a -> Graph
parseBatchResponse jarr b = foldl (flip ($)) empty appliedParsers
where cmds = getCmds b
parsers = foldr (\cmd ps -> cmdParse cmd : ps) [] cmds
appliedParsers = zipWith ($) parsers (V.toList jarr)
exceptionByName :: Neo4jException -> T.Text -> T.Text -> Neo4jException
exceptionByName _ "NoSuchPropertyException" msg = Neo4jNoSuchProperty msg
exceptionByName def _ _ = def
parseException :: L.ByteString -> Neo4jException
parseException b = fromMaybe defaultException $ do
parsedobj <- J.decode b
msg <- flip JT.parseMaybe parsedobj $ \obj -> (obj .: "message") >>= J.parseJSON
parsedmsg <- J.decode (L.fromStrict $ TE.encodeUtf8 msg)
(errName, expl) <- flip JT.parseMaybe parsedmsg $ \obj -> do
expl <- obj .: "message"
errName <- obj .: "exception"
return (errName, expl)
return $ exceptionByName defaultException errName expl
where defaultException = Neo4jBatchException b
runBatch :: Batch a -> Neo4j Graph
runBatch b = Neo4j $ \conn -> do
res <- httpCreate500Explained conn "/db/data/batch" $ J.encode b
let arr = case res of
Left bodyErr -> throw $ parseException bodyErr
Right bodySuc -> bodySuc
return $ parseBatchResponse arr b