alfred 0.4 → 0.5
raw patch · 4 files changed
+34/−32 lines, 4 filesdep +http-conduitdep +http-typesdep −HTTPPVP ok
version bump matches the API change (PVP)
Dependencies added: http-conduit, http-types
Dependencies removed: HTTP
API changes (from Hackage documentation)
Files
- CHANGES.txt +4/−0
- alfred.cabal +5/−3
- src/Alfred.hs +1/−2
- src/Alfred/Query.hs +24/−27
+ CHANGES.txt view
@@ -0,0 +1,4 @@+0.5+-----+* use http-conduit instead of HTTP package+* add support for queries via HTTPS (thanks to http-conduit)
alfred.cabal view
@@ -1,5 +1,5 @@ Name: alfred-Version: 0.4+Version: 0.5 Synopsis: utility library for Alfred version 2 Description: A utility library for writing workflows for Alfred version 2@@ -15,6 +15,8 @@ Build-Type: Simple Cabal-Version: >=1.9.2 +Extra-Source-Files: CHANGES.txt+ source-repository head type: git location: https://github.com/pa-ba/alfred.git@@ -32,7 +34,7 @@ else build-depends: network < 2.6 - Build-Depends: base == 4.*, aeson >= 0.7, bytestring, text >= 1.0, xmlgen, HTTP,- hexpat >= 0.20+ Build-Depends: base == 4.*, aeson >= 0.7, bytestring, text >= 1.0, xmlgen,+ hexpat >= 0.20, http-conduit >= 2.0, http-types hs-source-dirs: src ghc-options: -W
src/Alfred.hs view
@@ -22,7 +22,6 @@ -- import Alfred.Query -- import qualified Data.Text as T -- import Data.Text (Text)--- import Data.Text.Encoding -- -- runQuery :: Query (Text,[Text]) -- runQuery = jsonQuery suggestURL@@ -218,7 +217,7 @@ -- simpleSearch = Search { -- searchURL = \s -> T.concat ["http://dblp.uni-trier.de/search/author?author=", s], -- notFound = \s -> T.concat ["No suggestion. Search DBLP for ", s, "."],--- found = \s -> T.concat ["Open bibliography of ", s]},+-- found = \(s,_) -> T.concat ["Open bibliography of ", s]}, -- resultURL = \(_,r) -> T.concat ["http://dblp.uni-trier.de/pers/hd/",r,".html"], -- resultTitle = fst} -- @
src/Alfred/Query.hs view
@@ -28,13 +28,14 @@ ) where import Data.Aeson-import Network.BufferType-import Network.HTTP+import Network.HTTP.Conduit+import Network.HTTP.Types hiding (Query)+ import Network.URI hiding (escapeString) import qualified Data.Text as T -import Data.ByteString+import Data.ByteString.Lazy import Data.Text (Text) import System.IO.Error @@ -84,18 +85,18 @@ jsonQuery' :: FromJSON a => (ByteString -> ByteString) -> Text -> Query a jsonQuery' convert = genericQuery mkJSONRequest result- where result res = case eitherDecodeStrict (convert $ rspBody res) of+ where result res = case eitherDecode (convert $ responseBody res) of Left msg -> return $ Left $ T.concat- ["JSON decoding error: ", T.pack msg, "\n", T.pack $ show $ rspBody res]+ ["JSON decoding error: ", T.pack msg, "\n", T.pack $ show $ responseBody res] Right res -> return (Right res) -- | Constructions a request for doing an XML query. -mkJSONRequest :: BufferType ty => URI -> Request ty-mkJSONRequest url = setHeaders (mkRequest GET url) jsonHeaders+mkJSONRequest :: Request -> Request+mkJSONRequest req = req {requestHeaders=jsonHeaders} where jsonHeaders :: [Header]- jsonHeaders = [mkHeader HdrContentType "application/json; charset=utf-8"]+ jsonHeaders = (hContentType, "application/json; charset=utf-8") : requestHeaders req -- | This function performs a query by performing an HTTP GET request -- at the url obtained by concatenating the first argument with the@@ -115,41 +116,37 @@ 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 $ T.concat- ["XML decoding error: ", T.pack $ show msg ,"\n", T.pack $ show (rspBody res)]- Right tree -> return (Right tree)+ where result res = let (tree, err) = parse defaultParseOptions (responseBody res) in+ case err of+ Just msg -> return $ Left $ T.concat+ ["XML decoding error: ", T.pack $ show msg ,"\n", T.pack $ show (responseBody res)]+ Nothing -> return (Right tree) -- | Lazy variant of 'xmlQueryLazy'. This function may be useful if -- results tend to be lengthy and only a small prefix of the result is -- used. xmlQueryLazy :: (GenericXMLString a, GenericXMLString b) => Text -> Query (Node a b) xmlQueryLazy = genericQuery mkXMLRequest result- where result res = let (tree, _) = parse defaultParseOptions (rspBody res)+ where result res = let (tree, _) = parse defaultParseOptions (responseBody res) in return (Right tree) -- | Generic function to construct queries.-genericQuery :: HStream ty => (URI -> Request ty)- -> (Response ty -> IO (Either Text b))+genericQuery :: (Request -> Request)+ -> (Response ByteString -> IO (Either Text b)) -> Text -> Query b-genericQuery mkRequest result base query = let urlText = T.concat [base, escapeText query] in- case (parseURI $ T.unpack urlText) of+genericQuery modRequest result base query = let urlText = T.concat [base, escapeText query] in+ case (parseUrl $ T.unpack urlText) of Nothing -> return $ Left $ T.concat ["illformed url: ", urlText]- Just url -> catchIOError execute (return . Left . T.pack . show)- where execute = do- res <- simpleHTTP (mkRequest url)- case res of- Left err -> return $ Left $ T.pack (show err)- Right res -> result res-+ Just req -> catchIOError execute (return . Left . T.pack . show)+ where execute = withManager (\man -> (httpLbs (modRequest req) man)) >>= result -- | Constructions a request for doing a JSON query. -mkXMLRequest :: BufferType ty => URI -> Request ty-mkXMLRequest url = setHeaders (mkRequest GET url) xmlHeaders+mkXMLRequest :: Request -> Request+mkXMLRequest req = req {requestHeaders=xmlHeaders} where xmlHeaders :: [Header]- xmlHeaders = [mkHeader HdrContentType "application/xml"]+ xmlHeaders = (hContentType, "application/xml") : requestHeaders req -- | Functorial map for 'Query''.