diff --git a/BibTeX.hs b/BibTeX.hs new file mode 100644 --- /dev/null +++ b/BibTeX.hs @@ -0,0 +1,209 @@ +{- | +The parsers in this module also skip trailing spaces. +-} +module BibTeX ( + file, + comment, + entry, + assignment, + value, + texSequence, + texBlock, + identifier, + bibIdentifier, + + -- utility functions + skippingSpace, + skippingLeadingSpace, + + splitCommaSepList, + splitAuthorList, + splitSepList, + ) where + +import qualified Text.BibTeX.Entry as Entry + +import qualified Text.ParserCombinators.Parsec.Token as T +import qualified Text.ParserCombinators.Parsec.Language as L +import qualified Text.ParserCombinators.Parsec as Parsec +import Text.ParserCombinators.Parsec + (CharParser, Parser, + (<|>), alphaNum, digit, letter, char, noneOf, oneOf, + between, many, many1, sepEndBy, ) + +import Control.Monad (liftM, liftM2, liftM3, ) + +import Data.List.HT (chop, ) +import Data.Maybe + + +lexer :: T.TokenParser st +lexer = + T.makeTokenParser $ L.emptyDef { + L.commentLine = "%", + L.identStart = alphaNum, + L.identLetter = alphaNum + } + + +identifier, comma, equals :: CharParser st String +identifier = T.identifier lexer +comma = T.comma lexer +equals = T.symbol lexer "=" + +braces, lexeme :: CharParser st a -> CharParser st a +braces = T.braces lexer +lexeme = T.lexeme lexer + +{- | +Beware that this and all other parsers do not accept leading spaces, +cf. 'skippingSpace'. +That is when encountering leading white spaces +the parser will just return an empty list. +If you want to parse a file that contains entirely of BibTeX data +you better call @skippingLeadingSpace file@ instead. +However, the @file@ parser is more combinable +and can be used for files that contain both BibTeX and other data +or it can be used for automated filetype checking. +-} +file :: Parser [Entry.T] +file = comment >> catMaybes <$> sepEndBy entry comment + + +comment :: Parser String +comment = many $ noneOf "@" + + +{- | +Parse a BibTeX entry like + +> @article{author2010title, +> author = {Firstname Surname}, +> title = {Title}, +> year = 2010, +> month = jul, +> } + +. +-} +entry :: Parser (Maybe Entry.T) -- could be onyl a comment +entry = + do entryType <- char '@' >> identifier + if entryType == "comment" then return Nothing + else fmap Just $ braces $ + liftM2 (Entry.Cons entryType) + (Parsec.try bibIdentifier) + (comma >> sepEndBy assignment comma) + +{- | +Parse an assignment like + +> author = {Firstname Surname} + +. +-} +assignment :: Parser (String, String) +assignment = + liftM2 (,) + bibIdentifier + (equals >> value) + +{- | +Parse a value like + +> jul + +or + +> 2010 + +or + +> {Firstname Surname} + +or + +> "Firstname Surname" + +. +-} +value :: Parser String +value = + lexeme (many1 letter) <|> -- for fields like: month = jul + lexeme (many1 digit) <|> -- for fields like: year = 2010 + braces (texSequence '}') <|> + lexeme (between (char '"') (char '"') (texSequence '"')) + +{- | +Parse a sequence of 'texBlock's until the occurrence of a closing character. +The closing character is not part of the result. +-} +texSequence :: Char -> Parser String +texSequence closeChar = + liftM concat (many (texBlock closeChar)) + +{- | +Parse a single character like @a@, +a LaTeX macro call like @\\alpha@ +or a block enclosed in curly braces like @{\\\"{a}bc}@. +-} +texBlock :: Char -> Parser String +texBlock closeChar = + liftM3 (\open body close -> open : body ++ close : []) + (char '{') (texSequence '}') (char '}') <|> + sequence + [char '\\', + oneOf "_{}$|'`^&%\".,~# " <|> letter] <|> + fmap (:[]) (noneOf [closeChar]) + + +{- | +Parse a name of a BibTeX entry like @author2010title@. +-} +bibIdentifier :: Parser String +bibIdentifier = + lexeme $ + liftM2 (:) (alphaNum <|> char '_') -- less restrictive to handle all the internet shit! + (many (alphaNum <|> oneOf "&;:-_.?+/")) + + +{- | +Extends a parser, such that all trailing spaces are skipped. +It might be more comfortable to skip all leading spaces, +but parser written that way are hard to combine. +This is so, since if you run two parsers in parallel +and both of them expect leading spaces, +then the parser combinator does not know +which one of the parallel parsers to choose. + +See also: 'lexeme'. +-} +skippingSpace :: Parser a -> Parser a +skippingSpace p = + do x <- p + Parsec.skipMany Parsec.space + return x + +skippingLeadingSpace :: Parser a -> Parser a +skippingLeadingSpace p = + Parsec.skipMany Parsec.space >> p + + +-- * Convert contents of BibTeX fields into lists + +{- | +Split a string at the commas and remove leading spaces. +-} +splitCommaSepList :: String -> [String] +splitCommaSepList = splitSepList ',' + +{- | +Split a string containing a list of authors in BibTeX notation. +-} +splitAuthorList :: String -> [String] +splitAuthorList = + map unwords . chop ("and" ==) . words + +splitSepList :: Char -> String -> [String] +splitSepList sep = + map (dropWhile (' '==)) . chop (sep==) diff --git a/DOI.hs b/DOI.hs new file mode 100644 --- /dev/null +++ b/DOI.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} + +module DOI + where + +import qualified BibTeX as B1 +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.IO.Class +import Data.Bool +import Data.Char +import Data.Function +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.String.Utils hiding (join) +import Data.Time.Format +import Data.Time.LocalTime +import Data.URLEncoded +import Options.Applicative hiding (action) +import Safe +import System.Console.Haskeline +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO +import qualified System.IO.Strict as S +import System.IO.Temp +import System.Process +import Text.BibTeX.Entry +import Text.BibTeX.Format +import Text.HTML.TagSoup +import Text.Parsec.Prim hiding ((<|>)) +import Text.Printf +import Text.Read +import Text.Regex +import Text.Regex.Base.RegexLike +import Text.Regex.TDFA + +-- * hard coded global config (bad) +dst = "/home/data/promotion/Literatur" +-- ^ destination folder + +pdfSubDir = "doi" +-- ^ subdirectory for PDFs + +bibFile = dst "literatur.bib" +-- ^ BibTeX entries are appended to this file + +-- | Url of the bibsonomy scraper (e.g. their public version of self hosted) +-- needs to be install in ROOT app (tested on tomcat8) +-- > cd /tmp && wget http://dev.bibsonomy.org/maven2/org/bibsonomy/bibsonomy-scrapingservice/3.3.0/bibsonomy-scrapingservice-3.3.0.war && sudo mv bibsonomy-scrapingservice-3.3.0.war /var/lib/tomcat8/webapps/ROOT.war +bibsonomyUrl = if True then + "http://scraper.bibsonomy.org/service?format=bibtex&selection=&url=" + else + "http://localhost:8080/service?format=bibtex&selection=&" + -- needs to be install in ROOT app (tested on tomcat8) + -- cd /tmp && wget http://dev.bibsonomy.org/maven2/org/bibsonomy/bibsonomy-scrapingservice/3.3.0/bibsonomy-scrapingservice-3.3.0.war && sudo mv bibsonomy-scrapingservice-3.3.0.war /var/lib/tomcat8/webapps/ROOT.war + +-- * The types and the program + +data Options = Options + { oTarget :: String + , oFile :: Maybe String + , oKey :: Maybe String } + deriving Show + +optP :: Parser Options +optP = Options + <$> (on (<|>) (strArgument . metavar) "URL" "DOI") + <*> optional (strOption + ( short 'f' + <> metavar "PATH" + <> help "Path to possibly pre-existing pdf" )) + <*> optional (strOption + ( short 'k' + <> help "Provide a BibTeX Key" )) + +main :: IO () +main = customExecParser (prefs showHelpOnError) (info (helper <*> optP) i) >>= action + where i = fullDesc + <> header "retrieve BibTeX information and PDFs from a DOI or URL" + + +test4 = " @article{Armada_2007, title={A modified finite-lived American exchange option methodology applied to real options valuation}, volume={17}, ISSN={1044-0283}, url={http://dx.doi.org/10.1016/j.gfj.2006.05.006}, DOI={10.1016/j.gfj.2006.05.006}, number={3}, journal={Global Finance Journal}, publisher={Elsevier BV}, author={Armada, Manuel Rocha and Kryzanowski, Lawrence and Pereira, Paulo Jorge}, year={2007}, month={Mar}, pages={419\8211\&438}}\n" + + +test = "http://www.sciencedirect.com/science/article/pii/S1044028306000603" +test2 ="http://dx.doi.org/10.1016/j.gfj.2006.05.006" +test3 = "http://dx.doi.org/10.2139/ssrn.1709599" + +parseOrError name x y = either (error . unlines . (:[y]) . show) id $ parse x name y +parseBib name bib = f . parseOrError name (B1.skippingLeadingSpace $ B1.skippingSpace B1.file) + . sr "^@comment" "comment" $ bib + where f [x] = Just x + f [] = Nothing -- todo: propagate error, but fail only + -- if there are no bibtex entries at all (also from other + -- sources) + f x = error $ printf "BibTeX %s parser returns wrong number of entries:\n%s\n%sEOF\n" name (show x) bib + +doiFromBibsonomy :: Maybe T -> String +doiFromBibsonomy b = f $ find ((=="doi") . fmap toLower . fst) =<< fmap fields b + where f = fromMaybe (error $ printf "Bibsonomy returned no DOI:\n%s\n" $ maybe "" entry b) + . (extractDoi . snd =<<) + +existingKey Nothing = return () +existingKey (Just key) = (isInfixOf key <$> readFile bibFile) >>= flip when + (printf "Key '%s' already present in '%s'\n" key bibFile >> exitFailure) + +-- | first arg: doi or url +-- second arg: filename for preexisting file (which will be moved to doi location) +-- or value for the 'file' field +action (Options raw path key) = do + existingKey key + let edoi = extractDoi raw + url = maybe raw doiUrl edoi + bibson <- async $ downloadBibTeX url bibsonomy + doi <- fromMaybe (doiFromBibsonomy <$> wait bibson) $ return <$> edoi + -- print bibson + -- print doi + bibs <- (fmap catMaybes . mapM wait . (bibson:)) =<< + mapM (async . downloadBibTeX (doiUrl doi)) [crossref2] + -- crossref not as up-to-date e.g. for SSRN + file <- maybeToList . fmap ((,) "file") <$> getFile doi path + timestamp <- formatTime defaultTimeLocale "%FT%T" <$> getZonedTime + let mod bib = bib { fields = + fields bib ++ file ++ [("timestamp",timestamp)] + , identifier = fromMaybe (identifier bib) key} + str = entry $ mod $ merge bibs + putStrLn str + appendFile bibFile $ "\n" ++ str + + +-- combine several bibtex entries into one. the result with contain +-- the fields of both entries and thus contain duplicates. +merge :: [T] -> T +merge xs = (headNote "empty list in 'merge'" xs) { + fields = sortBy (comparing fst) $ nub $ + fmap (normalizeDoi . first (fmap toLower) . second strip) $ concatMap fields xs } + +normalizeDoi (f,v) = (,) f $ + if f=="doi" then fromMaybe v $ extractDoi v + else v + +getFile :: String -- ^ DOI + -> Maybe String -- ^ Existing File if available + -> IO (Maybe FilePath) +getFile doi f = do e <- doesFileExist target + if e then do pErr "File already exists: %s" target + return $ Just filename + else g f + where g (Just f) = do + e <- doesFileExist f + if e then withTarget (fmap Just . copyFile f) + else do pErr "File %s does not exist. Using it literally." f + return $ Just f + g Nothing = do r <- selectLink . extractLinks =<< doi2html doi + withTarget $ fmap join . forM r . downloadPdf + filename = pdfSubDir sr "/" "SLASH" doi <.> "pdf" + target = dst filename + withTarget :: (String -> IO (Maybe ())) -> IO (Maybe FilePath) + withTarget ac = do + createDirectoryIfMissing True $ fst $ splitFileName target + (fmap $ const filename) <$> ac target + +extractDoi :: String -> Maybe String +extractDoi input = -- maybe (error $ printf "Could not extract DOI from '%s'" input) + ((!!3).getAllTextSubmatches) <$> + input =~~ "^(http://(dx\\.)?doi\\.org/|doi:)?([^./]+\\.[^/]+/.*)" + +doiUrl doi = "http://dx.doi.org/" ++ doi + +selectLink :: [String] -> IO (Maybe String) +selectLink = runInputT defaultSettings . f . fmap transformUrl + where f [] = do + r <- fromJust <$> getInputChar "No Pdf Link Found, leave empty? [y/N] " + if r == 'y' then return Nothing + else error "not implemented, use -f argument instead" + f [x] = return $ Just x + f xs = do liftIO $ sequence $ reverse $ zipWith (printf "%2d: %s\n\n") + [(0::Int)..] ("(skip PDF download)":xs) + either ((>> f xs) . liftIO . putStrLn) + (return . selected) + . readEither . fromJust =<< getInputLine "Select PDF: " + where selected 0 = Nothing + selected x = Just $ xs !! (pred x) + transformUrl = sr "(.*jstor.*)" "\\1?acceptTC=true" + + +pErr :: HPrintfType r => [Char] -> r +pErr x = hPrintf stderr $ "\n" ++ x ++ "\n\n" + +extractLinks = mapMaybe mPdf . fmap (fromAttrib "href" . head) + . sections (~== "") . parseTags + +mPdf x = x =~~ "[^#].*pdf.*" :: Maybe String +mPdf2 x = (headNote "empty list in 'mPdf2'") + <$> matchRegex (mkRegexWithOpts "^[^#].*pdf.*" False False) x + +-- | get Location header +-- doi2url url = either (error.show) f <$> simpleHTTP (getRequest url) +-- where f = fromMaybe (error $ "No Location Header in "++ url ) . findHeader HdrLocation + +downloadBibTeX url (name,io) = do + pErr "Downloading %s BibTeX for %s" name url + a <- io url + print a + return $ parseBib name a :: IO (Maybe T) + +bibsonomy = (,) "Bibsonomy" $ \url -> do + readProcess2 "curl" + ["-L" + , bibsonomyUrl + ++ export (importList [("url", url)]) + ] + "" + +readProcess2 a b c = do pErr $ sr "%" "%%" $ showCommandForUser a b + readProcess a b c + +crossref = (,) "CrossRef" $ \url -> do + readProcess2 "curl" + (["-LH", "Accept: text/bibliography; style=bibtex", url]) + "" + +crossref2 = (,) "CrossRef" $ \url -> do + readProcess2 "curl" + (["-LH", "Accept: application/x-bibtex", url]) + "" + +uA = "Mozilla/5.0 (Windows NT 6.3; rv:36.0) Gecko/20100101 Firefox/36.0" + +doi2html :: String -> IO String +doi2html url = do + pErr "Downloading Website for %s" url + withSystemTempFile "wget_doi" $ \file h -> do + putStrLn file + hClose h + readProcess "wget" + (["-U",uA,"-O",file,"-k" + ] ++ [doiUrl url]) + "" + S.readFile file + -- readProcess "curl" + -- ["-LH",uA + -- ,doiUrl url] + -- "" + + +downloadPdf :: String -> String -> IO (Maybe ()) +downloadPdf target url = do + pErr "Downloading PDF from for %s" url + callProcess "wget" + ["-U",uA + ,"-O",target + ,url] + ft <- readProcess "xdg-mime" + ["query","filetype",target] + "" + if isInfixOf "pdf" $ fmap toLower ft + then return $ Just () + else do pErr "Filetype not PDF: %s" ft + return Nothing + +-- | substitute regex +sr :: String -- ^ regex + -> String -- ^ replacement + -> String -- ^ input + -> String +sr regex replacement input = subRegex (mkRegex regex) input replacement diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Johannes Gerer + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/doi.cabal b/doi.cabal new file mode 100644 --- /dev/null +++ b/doi.cabal @@ -0,0 +1,74 @@ +name: doi +version: 0.0.1 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +maintainer: Johannes Gerer +stability: Experimental +homepage: http://johannesgerer.com/doi +synopsis: Automatic Bibtex and fulltext of scientific articles +description: + Extract Bibtex entries and download fulltext of scientific articles automatically for a given DOI or URL + . + See on Github. +category: Database +author: Johannes Gerer + +library + exposed-modules: + DOI + BibTeX + build-depends: + MissingH >=1.4.0.1 && <1.5, + async >=2.1.1 && <2.2, + base >=4.9.0.0 && <4.10, + bibtex >=0.1.0.6 && <0.2, + directory >=1.2.6.2 && <1.3, + filepath >=1.4.1.0 && <1.5, + haskeline >=0.7.3.0 && <0.8, + optparse-applicative >=0.12.1.0 && <0.13, + parsec >=3.1.11 && <3.2, + process >=1.4.2.0 && <1.5, + regex-base >=0.93.2 && <0.94, + regex-compat >=0.95.1 && <0.96, + regex-tdfa >=1.2.2 && <1.3, + safe >=0.3.10 && <0.4, + strict >=0.3.2 && <0.4, + tagsoup ==0.14.*, + temporary >=1.2.0.4 && <1.3, + time >=1.6.0.1 && <1.7, + transformers >=0.5.2.0 && <0.6, + utility-ht >=0.0.12 && <0.1, + urlencoded >=0.4.1 && <0.5 + default-language: Haskell2010 + +executable doi + main-is: main.hs + build-depends: + MissingH >=1.4.0.1 && <1.5, + async >=2.1.1 && <2.2, + base >=4.9.0.0 && <4.10, + bibtex >=0.1.0.6 && <0.2, + directory >=1.2.6.2 && <1.3, + filepath >=1.4.1.0 && <1.5, + haskeline >=0.7.3.0 && <0.8, + optparse-applicative >=0.12.1.0 && <0.13, + parsec >=3.1.11 && <3.2, + process >=1.4.2.0 && <1.5, + regex-base >=0.93.2 && <0.94, + regex-compat >=0.95.1 && <0.96, + regex-tdfa >=1.2.2 && <1.3, + safe >=0.3.10 && <0.4, + strict >=0.3.2 && <0.4, + tagsoup ==0.14.*, + temporary >=1.2.0.4 && <1.3, + time >=1.6.0.1 && <1.7, + transformers >=0.5.2.0 && <0.6, + utility-ht >=0.0.12 && <0.1, + urlencoded >=0.4.1 && <0.5 + default-language: Haskell2010 + other-modules: + BibTeX + DOI + diff --git a/main.hs b/main.hs new file mode 100644 --- /dev/null +++ b/main.hs @@ -0,0 +1,3 @@ +module Main (DOI.main) + where +import DOI