diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for arxiv-client + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Eiko + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +## Arxiv-client + +A simple arxiv-client API library for searching, querying, and downloading pdf, source from arXiv.org. + +This is a library, and the command line interface (cli) application wrapping this library is provided by the `arxiv-client-cli` package. + +## Library Guide + +Two query ASTs are defined: + +* The primitive `Term`, `ArxivQuery` and their builder functions are defined in `Arxiv.Query`. Suitable for building queries programmatically using functions. + +* The higher-level `QueryTerm` which is algebraic query, defined in `Arxiv.Query.Algebraic` and `Arxiv.Query.Parser`, suitable for parsing from user input. diff --git a/arxiv-client.cabal b/arxiv-client.cabal new file mode 100644 --- /dev/null +++ b/arxiv-client.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.0 +name: arxiv-client +version: 0.1.0.0 +synopsis: Tiny client for the arXiv Atom API with a simple query DSL +description: This library provides a tiny client for the arXiv Atom API, allowing users to perform searches, retrieve metadata and download academic papers hosted on arXiv.org. It features a simple domain-specific language for constructing queries, making it easy to filter and sort results based on various criteria such as author, title, abstract, categories, and submission dates. +license: BSD-3-Clause +license-file: LICENSE +author: Eiko +maintainer: eikochanowo@outlook.com +-- copyright: +category: Network, Arxiv, API, DSL +build-type: Simple +extra-doc-files: CHANGELOG.md + , README.md +tested-with: GHC == 9.12.2 +source-repository head + type: git + location: https://github.com/Eiko-Tokura/arxiv-client.git +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: + Arxiv.Entry + , Arxiv.Client + , Arxiv.Download + , Arxiv.Query + , Arxiv.Query.Parser + , Arxiv.Query.Algebraic + , Arxiv.Filters + hs-source-dirs: src + build-depends: + base >=4 && <5 + , aeson >=2 && <2.3 + , text >=2.0 && <2.2 + , bytestring >=0.10 && <0.13 + , time >=1.11 && <1.15 + , req >=3.13 && <3.14 + , xml-conduit >=1.10 && <1.11 + , megaparsec >=9.5 && <9.8 + , modern-uri >=0.3 && <0.4 + , directory >=1.3 && <1.4 + hs-source-dirs: src + default-language: GHC2021 + +test-suite arxiv-client-test + import: warnings + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , arxiv-client + , text diff --git a/src/Arxiv/Client.hs b/src/Arxiv/Client.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Client.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings, OverloadedRecordDot #-} + +module Arxiv.Client + ( queryArxiv + , queryArxivIO + , queryArxivRaw + , queryArxivRawIO + , buildRequestUrlText + , downloadTo + ) where + +import Control.Applicative ((<|>), asum) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Maybe (listToMaybe, fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as LBS +import Data.Time (UTCTime, parseTimeM, defaultTimeLocale) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Arxiv.Query +import Arxiv.Entry +import Network.HTTP.Req +import qualified Text.XML as X +import Text.XML.Cursor +import qualified Text.URI as URI + +axisLocal :: Text -> Axis +axisLocal ln = element (nNamespace ln) + +-- Build the query string for debugging (best-effort). +buildRequestUrlText :: ArxivQuery -> Text +buildRequestUrlText q = + let base = "http://export.arxiv.org/api/query?" + kv k v = k <> "=" <> v + joinAmp = T.intercalate "&" + parts = + [ kv "search_query" (renderSearchQuery q) + , kv "start" (tshow (qStart q)) + , kv "max_results" (tshow (qMax q)) + ] <> + maybe [] (\sb -> [kv "sortBy" (sortByText sb)]) (qSortBy q) <> + maybe [] (\so -> [kv "sortOrder" (sortOrderText so)]) (qSortOrder q) <> + [kv "id_list" (T.intercalate "," (qIdList q)) | not (null (qIdList q))] + in base <> joinAmp parts + +-- Raw response (XML bytes) + parsed entries, for debugging. +queryArxivRaw :: (MonadHttp m, MonadIO m) => ArxivQuery -> m (LBS.ByteString, [ArxivEntry]) +queryArxivRaw q = do + let baseUrl = https "export.arxiv.org" /: "api" /: "query" + mkParam name val = name =: (val :: Text) + params = + mkParam "search_query" (renderSearchQuery q) + <> mkParam "start" (tshow (qStart q)) + <> mkParam "max_results" (tshow (qMax q)) + <> maybe mempty (\sb -> "sortBy" =: sortByText sb) (qSortBy q) + <> maybe mempty (\so -> "sortOrder" =: sortOrderText so) (qSortOrder q) + <> (if null (qIdList q) then mempty else "id_list" =: T.intercalate "," (qIdList q)) + r <- req GET baseUrl NoReqBody lbsResponse params + let bs = responseBody r + pure (bs, parseFeed bs) + +-- queryArxiv now just calls queryArxivRaw and returns parsed entries. +queryArxiv :: (MonadHttp m, MonadIO m) => ArxivQuery -> m [ArxivEntry] +queryArxiv q = snd <$> queryArxivRaw q +----------------------------- + +queryArxivRawIO :: ArxivQuery -> IO (LBS.ByteString, [ArxivEntry]) +queryArxivRawIO q = runReq defaultHttpConfig (queryArxivRaw q) + +-- | Run in IO. +queryArxivIO :: ArxivQuery -> IO [ArxivEntry] +queryArxivIO q = runReq defaultHttpConfig (queryArxiv q) + +tshow :: Show a => a -> Text +tshow = T.pack . show + +sortByText :: SortBy -> Text +sortByText Relevance = "relevance" +sortByText LastUpdatedDate = "lastUpdatedDate" +sortByText SubmittedDate = "submittedDate" + +sortOrderText :: SortOrder -> Text +sortOrderText Asc = "ascending" +sortOrderText Desc = "descending" + +nNamespace :: Text -> X.Name +nNamespace local = X.Name local (Just "http://www.w3.org/2005/Atom") Nothing + +nAttr :: Text -> X.Name +nAttr local = X.Name local Nothing Nothing + +parseFeed :: LBS.ByteString -> [ArxivEntry] +parseFeed lbs = + let doc = X.parseLBS_ X.def lbs + rootCur = fromDocument doc + -- Descendant axis + local-name match (namespace-agnostic). + entries = rootCur $// axisLocal "entry" + in mapMaybe cursorToEntry entries + +contents :: Cursor -> [Text] +contents cur = case cur.node of + X.NodeContent t -> [t] + _ -> case cur $/ content of + [] -> [] + ts -> ts + +-- | Safely take the first concatenated text of an element. +txtFirstOf :: Cursor -> Text -> Maybe Text +txtFirstOf cur local = + case concatMap contents (cur $// axisLocal local) of + [] -> Nothing + xs -> Just (T.strip (T.concat xs)) + +cursorToEntry :: Cursor -> Maybe ArxivEntry +cursorToEntry e = do + title' <- txtFirstOf e "title" + summary' <- txtFirstOf e "summary" + idURL <- txtFirstOf e "id" + published' <- txtFirstOf e "published" >>= parseTime + updated' <- txtFirstOf e "updated" >>= parseTime + + -- Authors: for each , concat all text nodes. Missing -> "". + let authors' = + [ T.strip . T.concat $ concatMap contents (aCur $/ laxElement "name") + | aCur <- e $// axisLocal "author" + ] + + cats = + (e $// axisLocal "category") >>= attribute (nAttr "term") + + -- pick by attribute match + pickLink :: Text -> Text -> Maybe Text + pickLink attrName attrVal = + let links = e $// (axisLocal "link" >=> attributeIs (nAttr attrName) attrVal) + in listToMaybe (links >>= attribute (nAttr "href")) + + arxId = lastSegment idURL + + absL = fromMaybe ("https://arxiv.org/abs/" <> arxId) + (pickLink "rel" "alternate") + + pdfL = fromMaybe ("https://arxiv.org/pdf/" <> arxId <> ".pdf") + ( pickLink "title" "pdf" + <|> pickLink "type" "application/pdf" + ) + + srcL = "https://arxiv.org/src/" <> arxId + + pure ArxivEntry + { arxivId = arxId + , absUrl = absL + , pdfUrl = pdfL + , sourceUrl = srcL + , title = title' + , summary = summary' + , authors = authors' + , categories= cats + , published = published' + , updated = updated' + } + +parseTime :: Text -> Maybe UTCTime +parseTime t = --iso8601ParseM . T.unpack + let s = T.unpack (T.strip t) + in asum + [ iso8601ParseM s + , parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" s + , parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" s + , parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Ez" s + , parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Ez" s + ] + +lastSegment :: Text -> Text +lastSegment url = + case reverse (T.splitOn "/" (T.takeWhile (/= '#') url)) of + (x:_) | not (T.null x) -> x + _ -> url + +-- | Download any http/https URL to a file, using 'modern-uri'. +downloadTo :: (MonadHttp m, MonadIO m) => Text -> FilePath -> m () +downloadTo urlT fp = + case URI.mkURI urlT of + Left _err -> error "downloadTo: invalid URL" + Right uri -> + case useHttpsURI uri of + Just (u, opt) -> do + r <- req GET u NoReqBody lbsResponse opt + liftIO (LBS.writeFile fp (responseBody r)) + Nothing -> + case useHttpURI uri of + Just (u, opt) -> do + r <- req GET u NoReqBody lbsResponse opt + liftIO (LBS.writeFile fp (responseBody r)) + Nothing -> + error "downloadTo: unsupported scheme (expect http/https)" diff --git a/src/Arxiv/Download.hs b/src/Arxiv/Download.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Download.hs @@ -0,0 +1,64 @@ +-- | Convenient functions for downloading arXiv papers. +module Arxiv.Download where + +import Arxiv.Entry +import Control.Monad +import Network.HTTP.Req +import Text.URI (mkURI) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BL +import System.Directory (doesFileExist) + +downloadPdf :: ArxivEntry -> IO BL.ByteString +downloadPdf entry = runReq defaultHttpConfig $ do + let url = pdfUrl entry + uri <- mkURI url + case useURI uri of + Just (Left (httpUrl, options)) -> do + response <- req GET httpUrl NoReqBody lbsResponse options + return (responseBody response) + Just (Right (httpsUrl, options)) -> do + response <- req GET httpsUrl NoReqBody lbsResponse options + return (responseBody response) + Nothing -> error $ "Invalid URL: " ++ T.unpack url + +-- | Usage: +-- @defaultFileName ".pdf" entry@ +defaultFileName :: String -> ArxivEntry -> FilePath +defaultFileName suffix entry = toValidFileName (T.unpack (title entry)) ++ "-" ++ T.unpack (arxivId entry) ++ suffix + +toValidFileName :: String -> String +toValidFileName = concatMap replaceInvalid + where + replaceInvalid c + | c `elem` ['a'..'z'] || c `elem` ['A'..'Z'] || c `elem` ['0'..'9'] = [c] + | c `elem` " ._-" = [c] + | otherwise = "_" + +-- | Detect if the file is already exists before downloading. +downloadPdfToFile :: ArxivEntry -> FilePath -> IO () +downloadPdfToFile entry filePath = do + fileExists <- doesFileExist filePath + unless fileExists $ do + pdfData <- downloadPdf entry + BL.writeFile filePath pdfData + +downloadSource :: ArxivEntry -> IO BL.ByteString +downloadSource entry = runReq defaultHttpConfig $ do + let url = sourceUrl entry + uri <- mkURI url + case useURI uri of + Just (Left (httpUrl, options)) -> do + response <- req GET httpUrl NoReqBody lbsResponse options + return (responseBody response) + Just (Right (httpsUrl, options)) -> do + response <- req GET httpsUrl NoReqBody lbsResponse options + return (responseBody response) + Nothing -> error $ "Invalid URL: " ++ T.unpack url + +downloadSourceToFile :: ArxivEntry -> FilePath -> IO () +downloadSourceToFile entry filePath = do + fileExists <- doesFileExist filePath + unless fileExists $ do + srcData <- downloadSource entry + BL.writeFile filePath srcData diff --git a/src/Arxiv/Entry.hs b/src/Arxiv/Entry.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Entry.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module Arxiv.Entry + ( ArxivEntry(..) + , arxivIdNoVersion + ) where + +import Data.Aeson +import Data.Text (Text) +import Data.Time (UTCTime) +import qualified Data.Text as T +import GHC.Generics (Generic) + +-- | Parsed arXiv entry from the Atom feed. +data ArxivEntry = ArxivEntry + { arxivId :: !Text -- ^ e.g. \"2401.01234v2\" + , absUrl :: !Text -- ^ https://arxiv.org/abs/ + , pdfUrl :: !Text -- ^ https://arxiv.org/pdf/.pdf + , sourceUrl :: !Text -- ^ https://arxiv.org/src/ (tarball of sources) + , title :: !Text + , summary :: !Text -- ^ abstract + , authors :: ![Text] -- ^ author names + , categories :: ![Text] -- ^ arXiv subjects, e.g. \"math.NT\" + , published :: !UTCTime + , updated :: !UTCTime + } deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | Drop a trailing version suffix (...vN) if present. +arxivIdNoVersion :: Text -> Text +arxivIdNoVersion t = case T.breakOnEnd "v" t of + (prefix, ver) | not (T.null prefix) && T.all (`elem` ['0'..'9']) ver -> T.dropEnd (T.length ver + 1) t + _ -> T.takeWhile (/= 'v') t diff --git a/src/Arxiv/Filters.hs b/src/Arxiv/Filters.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Filters.hs @@ -0,0 +1,41 @@ +module Arxiv.Filters + ( publishedBetween + , publishedAfter + , publishedBefore + , hasCategory + , authorContains + , titleContains + , abstractContains + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Arxiv.Entry + +publishedBetween :: UTCTime -> UTCTime -> [ArxivEntry] -> [ArxivEntry] +publishedBetween a b = filter (\e -> published e >= a && published e <= b) + +publishedAfter :: UTCTime -> [ArxivEntry] -> [ArxivEntry] +publishedAfter t = filter (\e -> published e >= t) + +publishedBefore :: UTCTime -> [ArxivEntry] -> [ArxivEntry] +publishedBefore t = filter (\e -> published e <= t) + +hasCategory :: Text -> [ArxivEntry] -> [ArxivEntry] +hasCategory cat = filter (\e -> cat `elem` categories e) + +authorContains :: Text -> [ArxivEntry] -> [ArxivEntry] +authorContains needle = + let n = T.toCaseFold needle + in filter (any (T.isInfixOf n . T.toCaseFold) . authors) + +titleContains :: Text -> [ArxivEntry] -> [ArxivEntry] +titleContains needle = + let n = T.toCaseFold needle + in filter (\e -> n `T.isInfixOf` T.toCaseFold (title e)) + +abstractContains :: Text -> [ArxivEntry] -> [ArxivEntry] +abstractContains needle = + let n = T.toCaseFold needle + in filter (\e -> n `T.isInfixOf` T.toCaseFold (summary e)) diff --git a/src/Arxiv/Query.hs b/src/Arxiv/Query.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Query.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Arxiv.Query +Description : A tiny, composable DSL for arXiv API search queries +Copyright : (c) Eiko 2025 +License : BSD3 +Maintainer : eikochanowo@outlook.com +Stability : experimental +Portability : portable + +This module provides a small, ergonomic DSL to compose arXiv queries that +render to the API's @search_query@ parameter. It also carries paging and +sorting settings, plus an optional @id_list@ (server-side filtering by IDs). + +### TL;DR + +Build queries fluently with /builders/ (functions of type 'QBuilder'): + +@ +import Data.Function ((&)) +import Arxiv.Query + +let q = + emptyQuery + & ( titleAll [\"Coleman\",\"Tropical\"] + .|| title \"Chabauty\" + .&& (title \"Differential\" .|| title \"Equation\") + ) + .&& inCategory \"math.NT\" + & setSort SubmittedDate Desc + & setPaging 0 25 + +renderSearchQuery q +-- (ti:Coleman+AND+ti:Tropical)+OR+(ti:Chabauty)+AND+((ti:Differential)+OR+(ti:Equation))+AND+cat:math.NT +@ + +- '(.&&)' and '(.||)' are boolean-style combinators with sensible precedence: + @(.&&)@ binds tighter than @(.||)@ (like '&&' vs '||' in Haskell). +- Builders keep parentheses correct using an internal AST. + +### Fields & Syntax + +arXiv supports fielded search terms such as: + +* @ti:@ (title), @abs:@ (abstract), @au:@ (author), @cat:@ (category) +* @co:@ (comment), @jr:@ (journal reference), @rn:@ (report number) +* @all:@ searches all fields (used by 'anyWords', 'allWords', 'exactPhrase') + +Values are automatically quoted when they contain spaces or special characters. +You can also inject raw snippets via 'rawTerm' / 'rawGroupAnd' / 'rawGroupOr' +when you want full control. + +### Paging, Sorting, and id_list + +- Use 'setPaging' to set @start@ and @max_results@ (arXiv typically allows up + to ~300). +- Use 'setSort' to choose 'SortBy' and 'SortOrder'. +- 'setIdList' / 'addId' / 'clearIdList' manipulate the optional @id_list@ + parameter (comma-separated), which the client layer will send alongside + @search_query@. + +@renderSearchQuery@ only renders the query expression; paging, sorting, and +@id_list@ are carried in 'ArxivQuery' and used by the client code. + +### Not / Negation + +- To negate words across all fields, use 'notWords'. +- To negate field-specific predicates, use 'notInTitle', 'notInAbstract', + 'notInCategories', or the general 'groupNot'. + +@since 0.1.0.0 +-} +module Arxiv.Query + ( -- * Sorting + SortBy(..) + , SortOrder(..) + + -- * QBuilder type + , QBuilder + + -- * Query record & basics + , ArxivQuery(..) + , emptyQuery + , setPaging + , setSort + + -- * Author predicates + , byAuthor + , authorAny + , authorAll + , authorExact + + -- * Title predicates + , titleHas + , titleAny + , titleAll + , titlePhrase + , notInTitle + + -- * Abstract predicates + , abstractHas + , abstractAny + , abstractAll + , abstractPhrase + , notInAbstract + + -- * Category predicates + , inCategory + , categoriesAny + , categoriesAll + , notInCategories + + -- * All-fields helpers + , anyWords + , allWords + , exactPhrase + , notWords + + -- * Raw injections + , rawTerm + , rawGroupAnd + , rawGroupOr + + -- * Boolean-style combinators and grouping + , (.&&) + , (.||) + , groupAnd + , groupOr + , groupNot + + -- * Other fields + , commentHas + , journalRefHas + , reportNumberIs + + -- * id_list helpers + , setIdList + , addId + , clearIdList + + -- * Rendering + , renderSearchQuery + + -- * Term type + , Term(..) + , addTerm + + -- * Helper Functions + , (&) + ) where + +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Text as T + +-- | Builder type for arXiv queries. +-- +-- A 'QBuilder' takes an 'ArxivQuery' and returns a modified one. Most +-- functions in this module are such builders and can be composed with +-- function application or with '(.&&)' / '(.||)'. +type QBuilder = ArxivQuery -> ArxivQuery + +-- Sorting --------------------------------------------------------------- + +-- | Sorting key for the arXiv API. +data SortBy + = Relevance -- ^ @sortBy=relevance@ + | LastUpdatedDate -- ^ @sortBy=lastUpdatedDate@ + | SubmittedDate -- ^ @sortBy=submittedDate@ + deriving (Eq, Show) + +-- | Sort direction. +data SortOrder = Asc | Desc + deriving (Eq, Show) + +-- Tiny internal AST ----------------------------------------------------- + +-- | Internal query AST (keeps parentheses and negations correct). +data Term + = TField Text Text -- ^ @f:v@ (auto-quoting values as needed) + | TAllWord Text -- ^ @all:v@ + | TAllPhrase Text -- ^ @all:\"...\"@ + | TRaw Text -- ^ Injected verbatim snippet + | TNot Term + | TAnd [Term] + | TOr [Term] + deriving (Eq, Show) + +-- Query record ---------------------------------------------------------- + +-- | The full query configuration that the client consumes. +data ArxivQuery = ArxivQuery + { qTerms :: [Term] -- ^ Query expression terms (top-level AND). + , qStart :: !Int -- ^ Paging start index (offset). + , qMax :: !Int -- ^ Paging size (max_results). + , qSortBy :: !(Maybe SortBy) -- ^ Optional sort key. + , qSortOrder :: !(Maybe SortOrder) -- ^ Optional sort direction. + , qIdList :: ![Text] -- ^ Optional @id_list@ (comma-separated). + } deriving (Eq, Show) + +-- | An empty query with no terms, start @0@, max @50@, and no sorting. +emptyQuery :: ArxivQuery +emptyQuery = ArxivQuery [] 0 50 Nothing Nothing [] + +-- | Set paging parameters. +-- +-- Values are clamped to @start >= 0@ and @max >= 1@. +setPaging :: Int -> Int -> QBuilder +setPaging s m q = q { qStart = max 0 s, qMax = max 1 m } + +-- | Set sorting: see 'SortBy' and 'SortOrder'. +setSort :: SortBy -> SortOrder -> QBuilder +setSort sb so q = q { qSortBy = Just sb, qSortOrder = Just so } + +-- Helpers --------------------------------------------------------------- + +quoteIfNeeded :: Text -> Text +quoteIfNeeded t + | T.any (\c -> c == ' ' || c == ':' || c == '(' || c == ')' || c == '"') t + = "\"" <> t <> "\"" + | otherwise = t + +paren :: Text -> Text +paren x = "(" <> x <> ")" + +renderTerm :: Term -> Text +renderTerm (TField f v) = f <> ":" <> quoteIfNeeded v +renderTerm (TAllWord w) = "all:" <> quoteIfNeeded w +renderTerm (TAllPhrase p) = "all:" <> "\"" <> p <> "\"" +renderTerm (TRaw t) = t +renderTerm (TNot t) = "-" <> renderTerm t +renderTerm (TAnd xs) = paren (T.intercalate " AND " (map renderTerm xs)) +renderTerm (TOr xs) = paren (T.intercalate " OR " (map renderTerm xs)) + +addTerm :: Term -> QBuilder +addTerm t q = q { qTerms = qTerms q <> [t] } + +-- Existing API (preserved) --------------------------------------------- + +-- | Search by author: @au:@. +-- +-- Examples: +-- +-- @ +-- emptyQuery & byAuthor "Minhyong Kim" +-- emptyQuery & authorExact "Minhyong Kim" -- quoted exact match +-- @ +byAuthor :: Text -> QBuilder +byAuthor a = addTerm (TField "au" a) + +-- | Title contains a token: @ti:@. +titleHas :: Text -> QBuilder +titleHas t = addTerm (TField "ti" t) + +-- | Abstract contains a token: @abs:<abstract>@. +abstractHas :: Text -> QBuilder +abstractHas t = addTerm (TField "abs" t) + +-- | In category: @cat:<category>@ (e.g. @\"math.NT\"@). +inCategory :: Text -> QBuilder +inCategory c = addTerm (TField "cat" c) + +-- | Match any of the given words across all fields (OR): @all:...@. +anyWords :: [Text] -> QBuilder +anyWords [] q = q +anyWords ws q = addTerm (TOr (map TAllWord ws)) q + +-- | Match all the given words across all fields (AND): @all:...@. +allWords :: [Text] -> QBuilder +allWords [] q = q +allWords ws q = addTerm (TAnd (map TAllWord ws)) q + +-- | Match an exact phrase across all fields: @all:\"...\"@. +exactPhrase :: Text -> QBuilder +exactPhrase p = addTerm (TAllPhrase p) + +-- | Negate words across all fields: @-all:...@. +notWords :: [Text] -> QBuilder +notWords [] q = q +notWords ws q = addTerm (TAnd (map (TNot . TAllWord) ws)) q + +-- | Inject a raw term snippet exactly as written. +-- +-- Use this when you need complete control over the fielding/quoting. +rawTerm :: Text -> QBuilder +rawTerm t = addTerm (TRaw t) + +-- New fielded combinators ---------------------------------------------- + +-- | Title contains /any/ of these tokens: @(ti:a OR ti:b ...)@. +titleAny :: [Text] -> QBuilder +titleAny ws = addTerm (TOr (map (TField "ti") ws)) + +-- | Title contains /all/ of these tokens: @(ti:a AND ti:b ...)@. +titleAll :: [Text] -> QBuilder +titleAll ws = addTerm (TAnd (map (TField "ti") ws)) + +-- | Title contains this exact phrase: @ti:\"...\"@. +titlePhrase :: Text -> QBuilder +titlePhrase p = addTerm (TRaw ("ti:" <> "\"" <> p <> "\"")) + +-- | Title does /not/ contain any of these tokens: @-ti:a AND -ti:b ...@. +notInTitle :: [Text] -> QBuilder +notInTitle ws = addTerm (TAnd (map (TNot . TField "ti") ws)) + +-- | Abstract contains /any/ of these tokens: @(abs:a OR abs:b ...)@. +abstractAny :: [Text] -> QBuilder +abstractAny ws = addTerm (TOr (map (TField "abs") ws)) + +-- | Abstract contains /all/ of these tokens: @(abs:a AND abs:b ...)@. +abstractAll :: [Text] -> QBuilder +abstractAll ws = addTerm (TAnd (map (TField "abs") ws)) + +-- | Abstract contains this exact phrase: @abs:\"...\"@. +abstractPhrase :: Text -> QBuilder +abstractPhrase p = addTerm (TRaw ("abs:" <> "\"" <> p <> "\"")) + +-- | Abstract does /not/ contain any of these tokens. +notInAbstract :: [Text] -> QBuilder +notInAbstract ws = addTerm (TAnd (map (TNot . TField "abs") ws)) + +-- | Author matches /any/ token: @(au:a OR au:b ...)@. +authorAny :: [Text] -> QBuilder +authorAny ws = addTerm (TOr (map (TField "au") ws)) + +-- | Author matches /all/ tokens: @(au:a AND au:b ...)@. +authorAll :: [Text] -> QBuilder +authorAll ws = addTerm (TAnd (map (TField "au") ws)) + +-- | Author exact (quoted): @au:\"...\"@. +authorExact :: Text -> QBuilder +authorExact a = addTerm (TRaw ("au:" <> "\"" <> a <> "\"")) + +-- | Category is /any/ of: @(cat:a OR cat:b ...)@. +categoriesAny :: [Text] -> QBuilder +categoriesAny cs = addTerm (TOr (map (TField "cat") cs)) + +-- | Category is /all/ of: @(cat:a AND cat:b ...)@. +categoriesAll :: [Text] -> QBuilder +categoriesAll cs = addTerm (TAnd (map (TField "cat") cs)) + +-- | Category is /not/ any of: @-cat:a AND -cat:b ...@. +notInCategories :: [Text] -> QBuilder +notInCategories cs = addTerm (TAnd (map (TNot . TField "cat") cs)) + +-- | Comment contains a token: @co:<text>@. +commentHas :: Text -> QBuilder +commentHas t = addTerm (TField "co" t) + +-- | Journal reference contains a token: @jr:<text>@. +journalRefHas :: Text -> QBuilder +journalRefHas t = addTerm (TField "jr" t) + +-- | Report number equals token (usually exact): @rn:<id>@. +reportNumberIs :: Text -> QBuilder +reportNumberIs rn = addTerm (TField "rn" rn) + +-- Boolean-style combinators & grouping --------------------------------- + +infixr 3 .&& -- | AND; binds tighter (like '&&'). +infixr 2 .|| -- | OR; binds looser (like '||'). + +-- | Combine two builders under an AND group (parenthesized). +-- +-- @ +-- title \"Chabauty\" .&& inCategory \"math.NT\" +-- -- renders as: (ti:Chabauty)+AND+cat:math.NT +-- @ +(.&&) :: QBuilder -> QBuilder -> QBuilder +(.&&) f g = groupAnd [f, g] + +-- | Combine two builders under an OR group (parenthesized). +(.||) :: QBuilder -> QBuilder -> QBuilder +(.||) f g = groupOr [f, g] + +-- | Group a list of builders using AND: @(A AND B AND ...)@. +groupAnd :: [QBuilder] -> QBuilder +groupAnd fs q0 = + let ts = qTerms (foldl (\q f -> f q) (q0 { qTerms = [] }) fs) + in addTerm (TAnd ts) q0 + +-- | Group a list of builders using OR: @(A OR B OR ...)@. +groupOr :: [QBuilder] -> QBuilder +groupOr fs q0 = + let ts = qTerms (foldl (\q f -> f q) (q0 { qTerms = [] }) fs) + in addTerm (TOr ts) q0 + +-- | Negate a grouped builder: @-(A AND B ...)@. +-- +-- If the builder expands to multiple terms, they are AND-ed before negation. +groupNot :: QBuilder -> QBuilder +groupNot f q0 = + let ts = qTerms (f (q0 { qTerms = [] })) + in case ts of + [] -> q0 + [one] -> addTerm (TNot one) q0 + many -> addTerm (TNot (TAnd many)) q0 + +-- Raw groups (inject ready-made snippets) ------------------------------- + +-- | Group raw snippets with AND, injected verbatim. +rawGroupAnd :: [Text] -> QBuilder +rawGroupAnd xs = addTerm (TAnd (map TRaw xs)) + +-- | Group raw snippets with OR, injected verbatim. +rawGroupOr :: [Text] -> QBuilder +rawGroupOr xs = addTerm (TOr (map TRaw xs)) + +-- id_list helpers ------------------------------------------------------- + +-- | Replace the entire @id_list@ (comma-separated on the wire). +-- +-- This is sent alongside @search_query@ by the client layer; arXiv will +-- restrict results to those IDs. +setIdList :: [Text] -> QBuilder +setIdList ids q = q { qIdList = ids } + +-- | Append a single ID to @id_list@. +addId :: Text -> QBuilder +addId i q = q { qIdList = qIdList q <> [i] } + +-- | Clear @id_list@. +clearIdList :: QBuilder +clearIdList q = q { qIdList = [] } + +-- Render --------------------------------------------------------------- + +-- | Render the query expression (for the API's @search_query@ parameter). +-- +-- Note that paging, sorting, and @id_list@ are not part of this string; they +-- are carried in 'ArxivQuery' and used by the HTTP client. +-- +-- If no terms are present, renders to @all:*@. +renderSearchQuery :: ArxivQuery -> Text +renderSearchQuery q = + if null (qTerms q) + then "all:*" + else T.intercalate " AND " (map renderTerm (qTerms q)) diff --git a/src/Arxiv/Query/Algebraic.hs b/src/Arxiv/Query/Algebraic.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Query/Algebraic.hs @@ -0,0 +1,59 @@ +-- | Module : Arxiv.Query.Algebraic +-- Description : Algebraic representation of arXiv queries, can be useful for reading and constructing queries. +{-# LANGUAGE OverloadedStrings #-} +module Arxiv.Query.Algebraic where + +import Data.Text (Text) +import Arxiv.Query + +data IsHasAnyAll a + = Is !a + | Has !a + | Any ![a] + | All ![a] + deriving (Show, Eq, Read) + +data QueryTerm + = Title !(IsHasAnyAll Text) + | Abstract !(IsHasAnyAll Text) + | Author !(IsHasAnyAll Text) + | Category !(IsHasAnyAll Text) + | AnyWhere !(IsHasAnyAll Text) + | Or !QueryTerm !QueryTerm + | And !QueryTerm !QueryTerm + | Ors ![QueryTerm] + | Ands ![QueryTerm] + | Not !QueryTerm + deriving (Show, Eq, Read) + +toTerms :: QueryTerm -> [Term] +toTerms (Title (Is t)) = [TField "ti" $ "\"" <> t <> "\""] +toTerms (Title (Has t)) = [TField "ti" t] +toTerms (Title (Any ts)) = [TOr $ TField "ti" <$> ts] +toTerms (Title (All ts)) = [TAnd $ TField "ti" <$> ts] +toTerms (Abstract (Is t)) = [TField "abs" t] +toTerms (Abstract (Has t)) = [TField "abs" t] +toTerms (Abstract (Any ts)) = [TOr $ TField "abs" <$> ts] +toTerms (Abstract (All ts)) = [TAnd $ TField "abs" <$> ts] +toTerms (Author (Is t)) = [TField "au" $ "\"" <> t <> "\""] +toTerms (Author (Has t)) = [TField "au" t] +toTerms (Author (Any ts)) = [TOr $ TField "au" <$> ts] +toTerms (Author (All ts)) = [TAnd $ TField "au" <$> ts] +toTerms (Category (Is t)) = [TField "cat" t] +toTerms (Category (Has t)) = [TField "cat" t] +toTerms (Category (Any ts)) = [TOr $ TField "cat" <$> ts] +toTerms (Category (All ts)) = [TAnd $ TField "cat" <$> ts] +toTerms (AnyWhere (Is t)) = [TField "all" t] +toTerms (AnyWhere (Has t)) = [TField "all" t] +toTerms (AnyWhere (Any ts)) = [TOr $ TField "all" <$> ts] +toTerms (AnyWhere (All ts)) = [TAnd $ TField "all" <$> ts] +toTerms (Or t1 t2) = [TOr (toTerms t1 ++ toTerms t2)] +toTerms (Ors ts) = [TOr (concatMap toTerms ts)] +toTerms (And t1 t2) = [TAnd (toTerms t1 ++ toTerms t2)] +toTerms (Ands ts) = [TAnd (concatMap toTerms ts)] +toTerms (Not t) = [TNot (TAnd $ toTerms t)] +{-# INLINE toTerms #-} + +applyQueryTerm :: QueryTerm -> ArxivQuery -> ArxivQuery +applyQueryTerm qt query = foldr addTerm query ( toTerms qt ) +{-# INLINE applyQueryTerm #-} diff --git a/src/Arxiv/Query/Parser.hs b/src/Arxiv/Query/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Arxiv/Query/Parser.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Parse algebraic query expressions +module Arxiv.Query.Parser + ( parseQueryTerm + , queryTermParser + , runQueryTermTests + ) where + +import Arxiv.Query.Algebraic +import Control.Applicative (asum) +import Control.Monad (forM_) +import Data.Text (Text, pack) +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Data.Text.IO as TIO + +data AndOrBracket a + = AndTerm !(AndOrBracket a) !(AndOrBracket a) + | OrTerm !(AndOrBracket a) !(AndOrBracket a) + | NotTerm !(AndOrBracket a) + | BracketTerm !(AndOrBracket a) + | SingleTerm !a + deriving (Show, Eq) + +queryTermReduction :: AndOrBracket QueryTerm -> QueryTerm +queryTermReduction (AndTerm t1 t2) = And (queryTermReduction t1) (queryTermReduction t2) +queryTermReduction (OrTerm t1 t2) = Or (queryTermReduction t1) (queryTermReduction t2) +queryTermReduction (NotTerm t) = Not (queryTermReduction t) +queryTermReduction (BracketTerm t) = queryTermReduction t +queryTermReduction (SingleTerm t) = t + +andOrBracketParser :: Int -> (Char, Char) -> Parsec Void Text a -> Parsec Void Text (AndOrBracket a) +andOrBracketParser !braLevel (bra, ket) termParser = asum + [ + try $ (AndTerm <$> bracketTermP) <* space <* string "&&" <* space + <*> andOrBracketParser braLevel (bra, ket) termParser + , try $ (OrTerm <$> bracketTermP) <* space <* string "||" <* space + <*> andOrBracketParser braLevel (bra, ket) termParser + , bracketTermP + , try $ (AndTerm . SingleTerm <$> termParser) <* space <* string "&&" <* space + <*> andOrBracketParser braLevel (bra, ket) termParser + , try $ (OrTerm . SingleTerm <$> termParser) <* space <* string "||" <* space + <*> andOrBracketParser braLevel (bra, ket) termParser + , NotTerm <$> (string "not" >> space1 >> andOrBracketParser braLevel (bra, ket) termParser) + , SingleTerm <$> termParser + ] where bracketTermP = do + _ <- char bra + term <- andOrBracketParser (braLevel + 1) (bra, ket) termParser + _ <- char ket + return (BracketTerm term) + +{- example: + +title is coleman ---> Title (Is "coleman") +title has "coleman integral" ---> Title (Has "coleman integral") +ands [<queryTerm>, ...] ---> Ands [<queryTerm>, ...] + +-} +queryTermParser :: Parsec Void Text QueryTerm +queryTermParser = asum + [ titleParser + , abstractParser + , authorParser + , categoryParser + , anywhereParser + , fmap Ands $ string "ands" >> space >> listOf queryTermParser + , fmap Ors $ string "ors" >> space >> listOf queryTermParser + , AnyWhere . Has <$> quotedTextParser -- without any prefix, "text" is treated as anywhere has "text" + ] + where + titleParser = string "title" >> space1 >> Title <$> isHasAnyAllParser + abstractParser = string "abstract" >> space1 >> Abstract <$> isHasAnyAllParser + authorParser = string "author" >> space1 >> Author <$> isHasAnyAllParser + categoryParser = string "category" >> space1 >> Category <$> isHasAnyAllParser + anywhereParser = string "anywhere" >> space1 >> AnyWhere <$> isHasAnyAllParser + isHasAnyAllParser = asum + [ Is <$> (string "is" >> space1 >> quotedTextParser) + , Has <$> (string "has" >> space1 >> quotedTextParser) + , Any <$> (string "any" >> space1 >> listOf quotedTextParser) + , All <$> (string "all" >> space1 >> listOf quotedTextParser) + ] + quotedTextParser = pack <$> (char '"' >> manyTill anySingle (char '"')) + listOf p = between (char '[') (char ']') (sepBy p (char ',' >> space)) + +fullQueryTermParser :: Parsec Void Text QueryTerm +fullQueryTermParser = queryTermReduction <$> andOrBracketParser 0 ('(', ')') queryTermParser + +parseQueryTerm :: Text -> Either (ParseErrorBundle Text Void) QueryTerm +parseQueryTerm = runParser (fullQueryTermParser <* eof) "" + +queryTermTestItem :: Text -> QueryTerm -> Maybe String +queryTermTestItem input expected = + case runParser (fullQueryTermParser <* eof) "" input of + Left err -> Just ("Parse error: " ++ errorBundlePretty err) + Right actual -> + if actual == expected + then Nothing + else Just ("Expected: " ++ show expected ++ ", but got: " ++ show actual) + +queryTermTests :: [(Text, QueryTerm)] +queryTermTests = + [ ("title is \"coleman\"", Title (Is "coleman")) + , ("abstract has \"p-adic integral\"", Abstract (Has "p-adic integral")) + , ("author any [\"john doe\", \"jane smith\"]", Author (Any ["john doe", "jane smith"])) + , ("category all [\"math.NT\", \"math.AG\"]", Category (All ["math.NT", "math.AG"])) + , ("anywhere is \"quantum mechanics\"", AnyWhere (Is "quantum mechanics")) + , ("ands [title is \"coleman\", author has \"doe\"]", Ands [Title (Is "coleman"), Author (Has "doe")]) + , ("ors [category is \"math.NT\", category is \"math.AG\"]", Ors [Category (Is "math.NT"), Category (Is "math.AG")]) + , ("(title has \"haskell\" && author has \"simon\")", + And + (Title (Has "haskell")) + (Author (Has "simon"))) + , ("(title has \"haskell\" && author has \"simon\") || abstract has \"functional programming\"", + Or + (And + (Title (Has "haskell")) + (Author (Has "simon"))) + (Abstract (Has "functional programming"))) + , ("\"haskell\" && \"simon\"", + And + (AnyWhere (Has "haskell")) + (AnyWhere (Has "simon"))) + , ("not (title is \"quantum\")", + Not + (Title (Is "quantum"))) + ] + +runQueryTermTests :: IO () +runQueryTermTests = do + let results = map (\(input, expected) -> (input, queryTermTestItem input expected)) queryTermTests + let failures = [(input, err) | (input, Just err) <- results] + if null failures + then putStrLn "All query term parser tests passed." + else do + putStrLn "Some query term parser tests failed:" + forM_ failures $ \(input, err) -> do + putStr "Input: " >> TIO.putStr input + putStrLn $ "\nError: " ++ err diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.Text as T +import Arxiv.Query +import Arxiv.Client + +failWith :: String -> IO a +failWith msg = ioError (userError msg) + +assert :: Bool -> String -> IO () +assert True _ = pure () +assert False m = failWith m + +main :: IO () +main = do + putStrLn "[test] renderSearchQuery builds fielded terms" + let q = emptyQuery & inCategory "math.NT" & anyWords ["Chabauty","Coleman"] + let rq = renderSearchQuery q + putStrLn (" search_query = " <> T.unpack rq) + assert ("cat:math.NT" `T.isInfixOf` rq) "missing cat:math.NT" + assert ("all:" `T.isInfixOf` rq) "missing 'all:' prefix" + + putStrLn "[test] simple network call returns some entries" + es <- queryArxivIO (emptyQuery & anyWords ["electron"] & setPaging 0 5) + assert (not (null es)) "expected non-empty result for 'electron'" + + putStrLn "[test] OK"