1. Doug Burke
  2. astrosearch

Source

astrosearch / HQuery.hs

{-# LANGUAGE OverloadedStrings #-}

{-
Experiment with SPARQL queries.

Usage:

  hquery <endpoint>
  hquery <endpoint> raw [format]

where format is one of

  turtle ntriples rdfxml trig trix

-}

module Main where

import qualified Data.Text as T
import qualified Data.Text.IO as T
-- import qualified Data.Text.Lazy.IO as TL

import Control.Monad (when)

import Data.List (intercalate)

import System.Console.Haskeline
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.IO (stderr, hPutStrLn)

import Database.HaSparqlClient

mkService :: String -> Query -> Service
mkService epoint qry = Sparql epoint qry [] [] []

prefixes :: [Query]
prefixes = [ "prefix sioc: <http://rdfs.org/sioc/ns#>"
           , "prefix sioct: <http://rdfs.org/sioc/types#>"
           , "prefix foaf: <http://xmlns.com/foaf/0.1/>"
           , "prefix dcterms: <http://purl.org/dc/terms/>"
           , "prefix tw: <http://purl.org/net/djburke/demo/twitter#>"
           , "prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#>"
           , "prefix lode: <http://linkedevents.org/ontology/>"
           , ""
           ]
           
showBinding :: BindingValue -> String
showBinding (URI s) = '<' : T.unpack s ++ ">"
showBinding (Literal s) = T.unpack s
showBinding (LangLiteral s l)  = T.unpack s ++ "@@" ++ T.unpack l
showBinding (TypedLiteral s "http://www.w3.org/2001/XMLSchema#boolean") = show (T.toLower s == "true")
showBinding (TypedLiteral s "http://www.w3.org/2001/XMLSchema#integer") = T.unpack s
showBinding (TypedLiteral s "http://www.w3.org/2001/XMLSchema#double") = T.unpack s
showBinding (TypedLiteral s "http://www.w3.org/2001/XMLSchema#dateTime") = T.unpack s
showBinding (TypedLiteral s t) = T.unpack s ++ "^^" ++ T.unpack t
showBinding (BNode s) = "bnode:" ++ T.unpack s
showBinding Unbound = "<UNBOUND>"

showResult :: [BindingValue] -> String
showResult = unwords . map showBinding

out :: String -> IO ()
out = hPutStrLn stderr

displayPrefixes :: IO ()
displayPrefixes = mapM_ out prefixes

-- return user input until control-d
getBody :: IO [Query]
getBody = 
  runInputT defaultSettings loop
    where 
      loop :: InputT IO [Query]
      loop = do
        minput <- getInputLine ""
        case minput of
          Nothing -> return []
          Just input -> do 
            inputs <- loop
            return $ input : inputs
                                 
allowedTypes :: [(String, MIMEType)]
allowedTypes = 
  [("turtle", mtTurtle),
   ("ntriples", mtNTriples),
   ("rdfxml", mtRDFXML),
   ("trig", mtTriG),
   ("trix", mtTriX)]

usage :: IO ()
usage = do
  pName <- getProgName
  hPutStrLn stderr $ "Usage: " ++ pName ++ " <endpoint>"
  hPutStrLn stderr $ "       " ++ pName ++ " <endpoint> raw [type]"
  hPutStrLn stderr   "\nwhere method is one of"
  hPutStrLn stderr $ "\n  " ++ unwords (map fst allowedTypes)
  hPutStrLn stderr   ""
  exitFailure
  
main :: IO ()
main = do
  args <- getArgs
  case args of
    [e] -> doSelect e
    (e:"raw":[]) -> doRaw e "text/turtle"
    (e:"raw":name:[]) -> case lookup name allowedTypes of
      Just fmt -> doRaw e fmt
      _ -> usage
      
    _ -> usage
    
getQuery :: IO [String]
getQuery = do
  displayPrefixes
  out "# ?user a sioc:UserAccount . ?tweet a sioct:MicroblogPost ; sioc:has_creator ?user .\n"
  body <- getBody
  when (all null body) $ do
    out "No query specified."
    exitFailure
  
  return body
  
doSelect :: String -> IO ()
doSelect epoint = do
  body <- getQuery
  let srv = mkService epoint $ unwords $ prefixes ++ body
  doSelectQuery srv HGET

doSelectQuery :: Service -> Method -> IO ()
doSelectQuery src m = do
  out $ "*** Running select query: " ++ show m
  sel <- runSelectQuery src m
  case sel of
    Left emsg -> out $ "ERROR: " ++ emsg
    Right rs -> do
      out "*** Results"
      mapM_ (putStrLn . showResult) rs
      out "***"
  
doRaw :: String -> MIMEType -> IO ()
doRaw epoint fmt = do
  body <- getQuery
  let srv = mkService epoint $ unwords $ prefixes ++ body
  doRawQuery srv HGET fmt

doRawQuery :: Service -> Method -> MIMEType -> IO ()
doRawQuery src m fmt = do
  out $ "*** Running raw query: " ++ show m
  sel <- runQuery src m [fmt]
  case sel of
    Left emsg -> out $ "ERROR: " ++ emsg
    Right rs -> do
      out "*** Results"
      -- TL.putStrLn rs
      T.putStrLn rs
      out "***"