module Database.SPARQL.Protocol.Client
( select
, ask
, construct
, describe
, update
, RDFTerm(..)
, AskResult(..)
, SelectResult(..)
) where
import Control.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Applicative
import Data.Aeson
import Data.Aeson.Types
import Data.ByteString.Lazy
import Data.Map.Strict (Map)
import Data.Monoid
import Data.Text
import Network.Wreq hiding (asJSON)
import Network.HTTP.Client as HTTP
import GHC.Generics
data RDFTerm
= IRI Text
| Literal Text
| LiteralLang Text Text
| LiteralType Text Text
| Blank Text
deriving (Eq, Show)
instance FromJSON RDFTerm where
parseJSON = withObject "RDF term" $ \term -> msum
[ term `ofType` "uri" >> IRI <$> (term .: "value")
, term `ofType` "literal" >> Literal <$> (term .: "value")
, term `ofType` "literal" >> LiteralLang <$> (term .: "value") <*> (term .: "xml:lang" <|> term .: "lang")
, term `ofType` "literal" >> LiteralType <$> (term .: "value") <*> (term .: "datatype")
, term `ofType` "bnode" >> Blank <$> (term .: "value")
]
where
ofType :: Object -> Text -> Parser ()
ofType term expectedType = do
actualType <- term .: "type"
guard (actualType == expectedType)
newtype AskResult = AskResult Bool
deriving (Eq, Show)
instance FromJSON AskResult where
parseJSON = withObject "SPARQL result object"
$ \obj -> AskResult <$> (obj .: "boolean")
newtype SelectResult = SelectResult [Map Text RDFTerm]
deriving (Eq, Show)
instance FromJSON SelectResult where
parseJSON = withObject "SPARQL result"
$ fmap SelectResult . ((.: "results") >=> (.: "bindings"))
newtype RDFGraph = RDFGraph (Map Text (Map Text RDFTerm))
deriving (Eq, Show, Generic)
instance FromJSON RDFGraph
genericSelect
:: FromJSON a
=> String
-> ByteString
-> IO (Response a)
genericSelect url = postWith opts url >=> asJSON
where
opts = defaults
& header "Content-type" .~ ["application/sparql-query"]
& header "Accept" .~ ["application/sparql-results+json"]
select
:: String
-> ByteString
-> IO (Response SelectResult)
select = genericSelect
ask
:: String
-> ByteString
-> IO (Response AskResult)
ask = genericSelect
construct
:: String
-> ByteString
-> IO (Response RDFGraph)
construct url = postWith opts url >=> asJSON
where
opts = defaults
& header "Content-type" .~ ["application/sparql-query"]
& header "Accept" .~ ["application/rdf+json"]
describe
:: String
-> ByteString
-> IO (Response RDFGraph)
describe url = construct url . ("DESCRIBE " <>)
update
:: String
-> ByteString
-> IO (Response ())
update url = postWith opts url >=> asJSON
where
opts = defaults
& param "Content-type" .~ ["application/sparql-update"]
asJSON :: FromJSON a => Response ByteString -> IO (Response a)
asJSON resp = case eitherDecode' (HTTP.responseBody resp) of
Left err -> throwM (JSONError err)
Right val -> return (fmap (const val) resp)