module Alfred.Query
( jsonQuery
, xmlQuery
, xmlQueryLazy
, escapeString
, escapeText
, Query
, transformQuery
, Query'
) where
import Network.HTTP
import Network.BufferType
import Network.URI hiding (escapeString)
import Data.Aeson
import Data.Char
import qualified Data.Text as T
import Data.Text (Text)
import System.IO.Error
import Text.XML.Expat.Tree
type Query a = Query' Text a
type Query' q a = q -> IO (Either String a)
jsonQuery :: FromJSON a => Text -> Query a
jsonQuery = genericQuery mkJSONRequest result
where result res = case eitherDecodeStrict (rspBody res) of
Left msg -> return $ Left ("JSON decoding error: " ++ msg ++ "\n" ++
show (rspBody res))
Right res -> return (Right res)
mkJSONRequest :: BufferType ty => URI -> Request ty
mkJSONRequest url = setHeaders (mkRequest GET url) jsonHeaders
where jsonHeaders :: [Header]
jsonHeaders = [mkHeader HdrContentType "application/json"]
xmlQuery :: (GenericXMLString a, GenericXMLString b) => Text -> Query (Node a b)
xmlQuery = genericQuery mkXMLRequest result
where result res = case parse' defaultParseOptions (rspBody res) of
Left msg -> return $ Left ("XML decoding error: " ++ show msg
++ "\n" ++ show (rspBody res))
Right tree -> return (Right tree)
xmlQueryLazy :: (GenericXMLString a, GenericXMLString b) => Text -> Query (Node a b)
xmlQueryLazy = genericQuery mkXMLRequest result
where result res = let (tree, _) = parse defaultParseOptions (rspBody res)
in return (Right tree)
genericQuery :: HStream ty => (URI -> Request ty)
-> (Response ty -> IO (Either String b))
-> Text -> Query b
genericQuery mkRequest result base query =
case (parseURI $ T.unpack $ T.concat [base, escapeText query]) of
Nothing -> return $ Left "illformed url"
Just url -> catchIOError execute (return . Left . show)
where execute = do
res <- simpleHTTP (mkRequest url)
case res of
Left err -> return $ Left (show err)
Right res -> result res
mkXMLRequest :: BufferType ty => URI -> Request ty
mkXMLRequest url = setHeaders (mkRequest GET url) xmlHeaders
where xmlHeaders :: [Header]
xmlHeaders = [mkHeader HdrContentType "application/xml"]
transformQuery :: (a -> b) -> Query' q a -> Query' q b
transformQuery f = fmap (fmap (fmap f))
escapeString :: String -> String
escapeString = escapeURIString isAlphaNum
escapeText :: Text -> Text
escapeText = T.pack . escapeString . T.unpack