diff --git a/alfred.cabal b/alfred.cabal --- a/alfred.cabal +++ b/alfred.cabal @@ -1,7 +1,7 @@ Name: alfred -Version: 0.1 +Version: 0.2 Synopsis: utility library for Alfred version 2 -Description: A utility library for writing workflows for Alfred version 2. +Description: A utility library for writing workflows for Alfred version 2 (). Category: Utils @@ -20,6 +20,7 @@ Exposed-Modules: Alfred Alfred.Query - Build-Depends: base == 4.*, aeson >= 0.7, bytestring, text >= 1.0, xmlgen, network, HTTP + Build-Depends: base == 4.*, aeson >= 0.7, bytestring, text >= 1.0, xmlgen, network, HTTP, + hexpat >= 0.20 hs-source-dirs: src ghc-options: -W diff --git a/src/Alfred.hs b/src/Alfred.hs --- a/src/Alfred.hs +++ b/src/Alfred.hs @@ -27,13 +27,14 @@ -- -- suggestURL = "http://suggestqueries.google.com/complete/search?output=toolbar&client=firefox&hl=en&q=" -- --- mkItems :: (Text, [Text]) -> [Item] --- mkItems = mkSearchItems MkSearch { +-- mkItems :: Renderer [Text] +-- mkItems = searchRenderer Search { -- searchURL = \s -> T.concat ["https://www.google.com/search?q=", s], -- notFound = \s -> T.concat ["No suggestion. Google for ", s, "."], +-- suggestError = \s -> T.concat ["Could not load suggestions! Google for ", s, "."], -- found = \s -> T.concat ["Search results for ", s]} --- --- main = runScript runQuery mkItems +-- +-- main = runScript (transformQuery snd runQuery) mkItems -- @ -- -- @@ -42,19 +43,24 @@ module Alfred ( Item (..) + , item , Icon (..) + , Renderer + , Renderer' , runScript , runScript' - , mkSearchItems - , MkSearch (..)) where + , searchRenderer + , Search (..)) where import Text.XML.Generator import qualified Data.ByteString as B import Data.Text (Text) +import qualified Data.Text as T import Data.ByteString (ByteString) import Data.Monoid import System.Environment import Data.List +import Control.Applicative import Alfred.Query @@ -72,6 +78,11 @@ , icon :: Maybe Icon } +-- | Default item. +item :: Item +item = Item {uid=Nothing,arg=undefined,isFile=False,valid=Nothing, + autocomplete=Nothing,title=undefined, subtitle=undefined, + icon=Just (IconFile "icon.png")} -- | A list of items. type Items = [Item] @@ -118,32 +129,38 @@ printItems :: Items -> IO () printItems = B.putStr . renderItems +-- | This type represents rendering functions as used by 'runScript'. +type Renderer a = Renderer' Text a +-- | This type represents rendering functions as used by 'runScript''. +type Renderer' q a = (q -> Either String a -> Items) + -- | This function runs a script consisting of a query function and a -- rendering function. The query function takes string parameters and -- produces an output that is then passed to the rendering function to -- produce items that are then passed to Alfred. -runScript' :: ([String] -> IO a) -- ^ query function - -> (a -> Items) -- ^ rendering function +runScript' :: ([Text] -> q) + -> Query' q a -- ^ query function + -> Renderer' q a -- ^ rendering function -> IO () -runScript' runQuery mkItems = do - args <- getArgs +runScript' inp runQuery mkItems = do + args <- (inp . map T.pack) <$> getArgs res <- runQuery args - printItems $ mkItems res + printItems $ mkItems args res -- | This function runs a script consisting of a query function and a -- rendering function. The query function takes string parameters and -- produces an output that is then passed to the rendering function to -- produce items that are then passed to Alfred. -runScript :: (String -> IO a) -- ^ query function - -> (a -> Items) -- ^ rendering function +runScript :: Query a -- ^ query function + -> Renderer a -- ^ rendering function -> IO () -runScript runQuery = runScript' (runQuery . concat . intersperse " ") +runScript = runScript' (T.concat . intersperse " ") -- | This data type represents standard search scripts used by --- 'mkSearchItems'. -data MkSearch = MkSearch {searchURL, found, notFound :: Text -> Text} +-- 'searchRenderer'. +data Search = Search {searchURL, found, notFound, suggestError :: Text -> Text} -- | This function produces a rendering function for standard search @@ -152,26 +169,28 @@ -- -- @ -- mkItems :: (Text, [Text]) -> Items --- mkItems = mkSearchItems MkSearch { +-- mkItems = mkSearchItems Search { -- searchURL = \s -> T.concat ["https://www.google.com/search?q=", s], -- notFound = \s -> T.concat ["No suggestion. Google for ", s, "."], -- found = \s -> T.concat ["Search results for ", s]} -- @ -- -mkSearchItems :: MkSearch -> (Text, [Text]) -> Items -mkSearchItems MkSearch {searchURL, found, notFound} suggs = +searchRenderer :: Search -> Renderer [Text] +searchRenderer Search {suggestError, searchURL} s (Left _) = + [Item {uid=Nothing,arg=searchURL (escapeText s),isFile=False, + valid=Nothing,autocomplete=Nothing,title=s, + subtitle=suggestError s,icon=Just (IconFile "icon.png")}] +searchRenderer Search {searchURL, found, notFound} s (Right suggs) = case suggs of - (s,[]) -> [Item {uid=Nothing,arg=searchURL (escapeText s),isFile=False, + [] -> [Item {uid=Nothing,arg=searchURL2 (escapeText s),isFile=False, valid=Nothing,autocomplete=Nothing,title=s, subtitle=notFound s,icon=Just (IconFile "icon.png")}] - (s,res@(r:_)) -> first ++ map mkItem res - where first = if s == r then [] - else [Item {uid=Nothing,arg=searchURL (escapeText s),isFile=False, - valid=Nothing,autocomplete=Just r, title=s, subtitle=found s, - icon=Just (IconFile "icon.png")}] + res -> map mkItem res where mkItem :: Text -> Item - mkItem s = Item {uid=Nothing,arg=searchURL (escapeText s),isFile=False,valid=Nothing, - autocomplete=Just s, title=s, subtitle=found s,icon=Just (IconFile "icon.png")} - + mkItem t = Item {uid=Nothing,arg=arg,isFile=False,valid=Nothing, + autocomplete=Just t, title=t, subtitle=found t,icon=Just (IconFile "icon.png")} + where arg = T.concat ["\"",searchURL (escapeText t),"\" \"", searchURL (escapeText s), "\""] + searchURL2 s = T.concat ["\"",url,"\" \"", url, "\""] + where url = searchURL s diff --git a/src/Alfred/Query.hs b/src/Alfred/Query.hs --- a/src/Alfred/Query.hs +++ b/src/Alfred/Query.hs @@ -1,20 +1,41 @@ -module Alfred.Query (jsonQuery,escapeString,escapeText) where +{-# LANGUAGE TypeSynonymInstances #-} +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.ByteString (ByteString) import Data.Char import qualified Data.Text as T import Data.Text (Text) +import System.IO.Error +import Text.XML.Expat.Tree +-- | Type representing queries for use in 'Alfred.runScript'. +type Query a = Query' Text a + +-- | Alternative type representing queries for use in +-- 'Alfred.runScript''. +type Query' q a = q -> IO (Either String a) + + -- | This function performs a query by performing an HTTP GET request -- at the url obtained by concatenating the first argument with the --- second one (after escaping it). The first argument is intended to --- be the base url and the second one the query string. The result is --- then parsed as a JSON object. For example, --- for a Google search: +-- second one (after escaping it). The returned query takes a string +-- as an argument and appends it to the base url to obtain the url +-- that is used for the query. The result is then parsed as a JSON +-- object. For example, for a Google search: -- -- @ -- runQuery :: String -> IO (Text,[Text]) @@ -24,23 +45,79 @@ -- @ -- -jsonQuery :: FromJSON a => String -> String -> IO a -jsonQuery base query = - case (parseURI $ base ++ escapeString query) of - Nothing -> error "illformed url" - Just url -> do res <- simpleHTTP (mkJSONRequest url) - case res of - Left err -> error (show err) - Right res -> case eitherDecodeStrict (rspBody res) of - Left msg -> error ("JSON decoding error: " ++ msg ++ "\n" ++ +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 res + Right res -> return (Right res) -mkJSONRequest :: URI -> Request ByteString + +-- | Constructions a request for doing an XML query. + +mkJSONRequest :: BufferType ty => URI -> Request ty mkJSONRequest url = setHeaders (mkRequest GET url) jsonHeaders + where jsonHeaders :: [Header] + jsonHeaders = [mkHeader HdrContentType "application/json"] -jsonHeaders :: [Header] -jsonHeaders = [mkHeader HdrContentType "application/json"] +-- | This function performs a query by performing an HTTP GET request +-- at the url obtained by concatenating the first argument with the +-- second one (after escaping it). The returned query takes a string +-- as an argument and appends it to the base url to obtain the url +-- that is used for the query. The result is then parsed as an XML +-- document. For example, for a DBLP search: +-- +-- @ +-- runQuery :: Query (Node Text Text) +-- runQuery query = xmlQuery suggestURL query +-- +-- suggestURL = "http://dblp.uni-trier.de/search/author?xauthor=" +-- @ +-- + + +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) + +-- | 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) + in return (Right tree) + +-- | Generic function to construct queries. +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 + + + +-- | Constructions a request for doing a JSON query. + +mkXMLRequest :: BufferType ty => URI -> Request ty +mkXMLRequest url = setHeaders (mkRequest GET url) xmlHeaders + where xmlHeaders :: [Header] + xmlHeaders = [mkHeader HdrContentType "application/xml"] + + +-- | Functorial map for 'Query''. +transformQuery :: (a -> b) -> Query' q a -> Query' q b +transformQuery f = fmap (fmap (fmap f)) -- | Escapes the string for use in a URL. escapeString :: String -> String