diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,53 @@ -import Distribution.Simple -main = defaultMain +#!/usr/bin/runhaskell +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + , postHaddock = \args flags pkg lbi -> do + postHaddock simpleUserHooks args flags pkg lbi + } + +haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath +haddockOutputDir flags pkg = destDir where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + + diff --git a/Text/CSL/Input/Identifier.hs b/Text/CSL/Input/Identifier.hs deleted file mode 100644 --- a/Text/CSL/Input/Identifier.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | This modules provides a way to convert document identifiers, such --- as DOIs, ISBNs, arXiv IDs to bibliographic references. --- --- Each type of identifiers will be converted via internet services --- to a bibliographic record of type 'Text.CSL.Reference' , which in --- turn can be rendered in various format using @citeproc-hs@ package --- . --- --- Moreover, the server responses are cached in a local database, --- making the server load as little as possible. - - -module Text.CSL.Input.Identifier - (EReference, readID, readDOI, readArXiv, readBibcode, readISBN ) - where - - -import qualified Text.CSL -import Text.CSL.Input.Identifier.Internal - - --- | EReference is the type returned by the 'Reference' resolver, --- accompanied with possible error message. - -type EReference = Either String Text.CSL.Reference diff --git a/Text/CSL/Input/Identifier/Internal.hs b/Text/CSL/Input/Identifier/Internal.hs deleted file mode 100644 --- a/Text/CSL/Input/Identifier/Internal.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Text.CSL.Input.Identifier.Internal where - -import Control.Applicative ((<$>)) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (runNoLoggingT) -import Control.Monad.Trans.Resource (runResourceT) -import qualified Data.ByteString.Char8 as BS -import Data.Char (toLower) -import Data.List (span) -import qualified Data.Text as Text -import qualified Data.String.Utils as String (replace) -import Database.Persist -import Database.Persist.TH -import Database.Persist.Sqlite -import Network.Curl.Download (openURIWithOpts) -import Network.Curl.Opts (CurlOption(CurlFollowLocation, CurlHttpHeaders)) -import System.Directory (createDirectoryIfMissing) -import System.Process (runInteractiveCommand, system) -import System.IO (hGetContents, hClose) -import Text.CSL (Reference, readBiblioString, BibFormat(Bibtex, Json)) -import Text.Printf - -import qualified Paths_citation_resolve as Paths - - - --- $setup --- >>> import Control.Applicative((<$>), (<*>)) --- >>> import Data.Either.Utils(forceEither) --- >>> import Text.CSL - - - - --- | data structure for accessing the reference cache database. -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| -WebCache - url String - content BS.ByteString - deriving Show -|] - --- | 'Resolver' is a function that converts a 'String' key to some --- value @a@, which may fail with an error message. -type Resolver a = String -> IO (Either String a) - --- | Take a resolver, and make it cached. -cached :: Resolver BS.ByteString -> Resolver BS.ByteString -cached resolver0 url = do - dbfn <- getDataFileName "reference.db3" - - runNoLoggingT $ runResourceT $ withSqlitePool (Text.pack dbfn) 1 $ \pool -> do - flip runSqlPool pool $ runMigration migrateAll - mx <- flip runSqlPool pool $ do - selectFirst [WebCacheUrl ==. url] [] - case mx of - Just x -> do - return $ Right $ webCacheContent $ entityVal x - - Nothing -> do - ret <- liftIO $ resolver0 url - case ret of - Right content0 -> do - flip runSqlPool pool $ do - insert $ WebCache - url content0 - return () - Left _ -> return () - return ret - - - - --- | parse a Bibtex entry obtained in various ways. -resolveBibtex :: String -> Resolver Reference -resolveBibtex src str = do - rs <- readBiblioString Bibtex str - case rs of - [r] -> return $ Right r - [] -> return $ Left $ src ++ " returned no reference." - _ -> return $ Left $ src ++ " returned multiple references." - - --- | Multi-purpose reference ID resolver. Resolve 'String' starting --- with "arXiv:", "isbn:", "doi:" to 'Reference' . --- --- >>> (==) <$> readArXiv "1204.4779" <*> readID "arXiv:1204.4779" --- True --- >>> (==) <$> readDOI "10.1088/1749-4699/5/1/015003" <*> readID "doi:10.1088/1749-4699/5/1/015003" --- True --- >>> (==) <$> readISBN "9780199233212" <*> readID "isbn:9780199233212" --- True - - - -readID :: Resolver Reference -readID str - | idId == "arxiv" = readArXiv addr - | idId == "bibcode" = readBibcode addr - | idId == "doi" = readDOI addr - | idId == "isbn" = readISBN addr - | otherwise = return $ Left $ "Unknown identifier type: " ++ str - where - (h,t) = span (/=':') str - idId = map toLower h - addr = drop 1 t - - - - --- | resolve a DOI to a 'Reference'. --- --- >>> ref <- forceEither <$> readDOI "10.1088/1749-4699/5/1/015003" --- >>> title ref --- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations" --- >>> putStrLn $ url ref --- http://dx.doi.org/10.1088/1749-4699/5/1/015003 - - - -readDOI :: Resolver Reference -readDOI doi = do - let - opts = [ CurlFollowLocation True - , CurlHttpHeaders ["Accept: text/bibliography; style=bibtex"] - ] - url = "http://dx.doi.org/" ++ doi - res <- cached (openURIWithOpts opts) url - case res of - Left msg -> return $ Left msg - Right bs -> resolveBibtex url $ BS.unpack bs - --- | resolve an arXiv ID to a 'Reference'. If it's a referred journal paper, it can also resolve --- the refereed version of the paper. --- --- >>> ref <- forceEither <$> readArXiv "1204.4779" --- >>> title ref --- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations" --- >>> containerTitle ref --- "Computational Science and Discovery" - -readArXiv :: Resolver Reference -readArXiv arXiv = do - let - opts = [ CurlFollowLocation True] - url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&arXiv:" ++ arXiv - res <- cached (openURIWithOpts opts) url - case res of - Left msg -> return $ Left msg - Right bs -> resolveBibtex url $ - String.replace "adsurl" "url" $ - BS.unpack bs - - - --- | resolve an Bibcode ID to a 'Reference'. --- --- >>> ref <- forceEither <$> readBibcode " 2012CS&D....5a5003M" --- >>> title ref --- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations" --- >>> containerTitle ref --- "Computational Science and Discovery" - -readBibcode :: Resolver Reference -readBibcode idstr = do - let - opts = [ CurlFollowLocation True] - url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&bibcode=" ++ idstr - res <- cached (openURIWithOpts opts) url - case res of - Left msg -> return $ Left msg - Right bs -> resolveBibtex url $ - String.replace "adsurl" "url" $ - BS.unpack bs - - - - - - - --- | resolve an ISBN to a 'Reference'. --- --- >>> ref <- forceEither <$> readISBN "9780199233212" --- >>> title ref --- "The nature of computation" - -readISBN :: Resolver Reference -readISBN isbn = do - let - opts = [ CurlFollowLocation True ] - url = printf "http://xisbn.worldcat.org/webservices/xid/isbn/%s?method=getMetadata&format=xml&fl=*" - isbn - res <- cached (openURIWithOpts opts) url - case res of - Left msg -> return $ Left msg - Right bs -> do - xsltfn <- getDataFileName "isbn2bibtex.xsl" - writeFile xsltfn xsl - (hIn,hOut,_,_) <- runInteractiveCommand $ printf "xsltproc %s -" xsltfn - BS.hPutStr hIn bs - hClose hIn - str <- hGetContents hOut - resolveBibtex url str - - where - xsl = "\n\n \n \n \n @BOOK{CiteKeyGoesHere,\n AUTHOR = \"\",\n TITLE = \"\",\n PUBLISHER = \"\",\n ADDRESS = \"\",\n YEAR =\"\"}\n\n \n\n" - - --- | a safer way to get data file name. -getDataFileName :: String -> IO String -getDataFileName fn = do - dd <- Paths.getDataDir - createDirectoryIfMissing True dd - Paths.getDataFileName fn --- >>> take 7 $ title ref --- "Paraiso" diff --git a/citation-resolve.cabal b/citation-resolve.cabal --- a/citation-resolve.cabal +++ b/citation-resolve.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: citation-resolve -version: 0.2.4 +version: 0.3 synopsis: convert document IDs such as DOI, ISBN, arXiv ID to bibliographic reference. description: This modules provides a way to convert document identifiers, such @@ -29,45 +29,55 @@ maintainer: muranushi@gmail.com -- copyright: category: Text -build-type: Simple +build-type: Custom cabal-version: >=1.8 -Data-Files: bibtex.csl +Data-Files: bibtex.csl, isbn2bibtex.xsl, default.db library - exposed-modules: Text.CSL.Input.Identifier - Text.CSL.Input.Identifier.Internal + exposed-modules: + Text.CSL.Input.Identifier + Text.CSL.Input.Identifier.Internal - other-modules: Paths_citation_resolve + other-modules: + Paths_citation_resolve - build-depends: base >=4.5 && <5 - , bytestring >= 0.9.2.1 - , citeproc-hs >= 0.3.7 - , curl >= 1.3.8 - , directory >= 1.2 - , download-curl >= 0.1.4 - , MissingH >= 1.1 - , monad-logger >= 0.3.1.1 --- , hxt >= 9.3.1 -- TODO: treat xsl more properly --- , hxt-xslt >= 9.1.1 -- using these libraries. - , persistent >= 1.2.0.2 - , persistent-template >= 1.1.2 - , persistent-sqlite >= 1.1.2 - , process >= 1.1 - , resourcet >= 0.4.4 - , text >= 0.11 - , transformers >= 0.3 + Hs-Source-Dirs: src -Test-Suite doctest + build-depends: + base >=4.5 && <5 + , aeson >= 0.6.1 + , bytestring >= 0.9.2.1 + , citeproc-hs >= 0.3.7 + , containers >= 0.5 + , curl >= 1.3.8 + , data-default + , directory >= 1.2 + , download-curl >= 0.1.4 + , either >= 3.4.1 + , lens >= 3.9.0.2 + , MissingH >= 1.1 + , mtl >= 2.1.2 +-- , hxt >= 9.3.1 -- TODO: treat xsl more properly +-- , hxt-xslt >= 9.1.1 -- using these libraries. + , process >= 1.1 + , safe + , text >= 0.11 + , transformers >= 0.3 + , yaml >= 0.8.4 + +Test-Suite doctests Type: exitcode-stdio-1.0 HS-Source-Dirs: test - Ghc-Options: -threaded -Wall + Ghc-Options: -Wall -threaded Main-Is: doctests.hs - Build-Depends: base - , directory >= 1.1 - , filepath >= 1.2 - , MissingH >= 1.1 - , doctest >= 0.9.3 + + Build-Depends: + base + , directory >= 1.1 + , filepath >= 1.2 + , MissingH >= 1.1 + , doctest >= 0.9.3 Test-Suite spec Type: exitcode-stdio-1.0 @@ -76,11 +86,11 @@ Main-Is: Spec.hs Other-Modules: - Build-Depends: base >=4.5 && < 5 - , binary-search - - , hspec >= 1.3 - , QuickCheck >= 2.5 + Build-Depends: + base >=4.5 && < 5 + , binary-search + , hspec >= 1.3 + , QuickCheck >= 2.5 Source-Repository head Type: git diff --git a/default.db b/default.db new file mode 100644 --- /dev/null +++ b/default.db @@ -0,0 +1,51 @@ +- - arXiv:1204.4779 + - - ! '@ARTICLE{2012CS&D....5a5003M,' + - ! ' author = {{Muranushi}, T.},' + - ! ' title = "{Paraiso: an automated tuning framework for explicit solvers + of partial differential equations}",' + - ! ' journal = {Computational Science and Discovery},' + - archivePrefix = "arXiv", + - ! ' eprint = {1204.4779},' + - ! ' primaryClass = "astro-ph.IM",' + - ! ' year = 2012,' + - ! ' month = jan,' + - ! ' volume = 5,' + - ! ' number = 1,' + - ! ' eid = {015003},' + - ! ' pages = {015003},' + - ! ' doi = {10.1088/1749-4699/5/1/015003},' + - ! ' url = {http://adsabs.harvard.edu/abs/2012CS%26D....5a5003M},' + - ! ' adsnote = {Provided by the SAO/NASA Astrophysics Data System}' + - ! '}' +- - bibcode:2012CS&D....5a5003M + - - ! '@ARTICLE{2012CS&D....5a5003M,' + - ! ' author = {{Muranushi}, T.},' + - ! ' title = "{Paraiso: an automated tuning framework for explicit solvers + of partial differential equations}",' + - ! ' journal = {Computational Science and Discovery},' + - archivePrefix = "arXiv", + - ! ' eprint = {1204.4779},' + - ! ' primaryClass = "astro-ph.IM",' + - ! ' year = 2012,' + - ! ' month = jan,' + - ! ' volume = 5,' + - ! ' number = 1,' + - ! ' eid = {015003},' + - ! ' pages = {015003},' + - ! ' doi = {10.1088/1749-4699/5/1/015003},' + - ! ' url = {http://adsabs.harvard.edu/abs/2012CS%26D....5a5003M},' + - ! ' adsnote = {Provided by the SAO/NASA Astrophysics Data System}' + - ! '}' +- - doi:10.1088/1749-4699/5/1/015003 + - - ! '@article{Muranushi_2012, title={Paraiso: an automated tuning framework for + explicit solvers of partial differential equations}, volume={5}, url={http://dx.doi.org/10.1088/1749-4699/5/1/015003}, + DOI={10.1088/1749-4699/5/1/015003}, number={1}, journal={Computational Science + & Discovery}, publisher={IOP Publishing}, author={Muranushi, Takayuki}, year={2012}, + month={Jan}, pages={015003}}' +- - isbn:9784274068850 + - - ! ' @BOOK{CiteKeyGoesHere,' + - ! ' AUTHOR = "Lipovaca Miran;Tanaka Hideyuki;Muranushi Takayuki.",' + - ! " TITLE = \"Sugoi hasukeru tanoshiku manab\u014D\"," + - ! " PUBLISHER = \"\u014Cmusha\"," + - ! " ADDRESS = \"T\u014Dky\u014D\"," + - ! ' YEAR =""}' diff --git a/isbn2bibtex.xsl b/isbn2bibtex.xsl new file mode 100644 --- /dev/null +++ b/isbn2bibtex.xsl @@ -0,0 +1,14 @@ + + + + + + @BOOK{CiteKeyGoesHere, + AUTHOR = "", + TITLE = "", + PUBLISHER = "", + ADDRESS = "", + YEAR =""} + + + diff --git a/src/Text/CSL/Input/Identifier.hs b/src/Text/CSL/Input/Identifier.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSL/Input/Identifier.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | This modules provides a way to convert document identifiers, such +-- as DOIs, ISBNs, arXiv IDs to bibliographic references. +-- +-- Each type of identifiers will be converted via internet services +-- to a bibliographic record of type 'Text.CSL.Reference' , which in +-- turn can be rendered in various format using @citeproc-hs@ package +-- . +-- +-- Moreover, the server responses are cached in a local database, +-- making the server load as little as possible. + +module Text.CSL.Input.Identifier + (resolveEither, resolve) + where + +import Control.Monad.IO.Class +import Control.Monad.State as State +import Control.Monad.Trans.Either +import Data.Default +import Text.CSL.Reference (emptyReference, Reference) +import Text.CSL.Input.Identifier.Internal + +-- $setup +-- >>> import Control.Applicative((<$>), (<*>)) +-- >>> import Data.Either.Utils(forceEither) +-- >>> import Text.CSL + + + +-- | Resolve a document url to a 'Reference'. returns an empty reference when someting fails. +-- prefix the document ID with one of "arXiv:", "doi:", "bibcode:" or "isbn:" . +-- +-- +-- >>> do { ref <- resolveDef "arXiv:1204.4779" ; putStrLn $ title ref } +-- Paraiso: an automated tuning framework for explicit solvers of partial differential equations +-- >>> do { ref <- resolveDef "doi:10.1088/1749-4699/5/1/015003" ; print $ author ref } +-- [Takayuki Muranushi] +-- >>> do { ref <- resolveDef "bibcode:2012CS&D....5a5003M" ; putStrLn $ containerTitle ref } +-- Computational Science and Discovery +-- >>> do { ref <- resolveDef "isbn:9784274068850" ; putStrLn $ title ref } +-- Sugoi hasukeru tanoshiku manabō + + +resolve :: (MonadIO m, MonadState DB m) => String -> m Reference +resolve = liftM (either (const emptyReference) id) . runEitherT . resolveEither + +-- | Resolve the document id using the default database. + +resolveDef :: String -> IO Reference +resolveDef url = do + fn <- getDataFileName "default.db" + let go = withDBFile fn $ resolve url + State.evalStateT go def diff --git a/src/Text/CSL/Input/Identifier/Internal.hs b/src/Text/CSL/Input/Identifier/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSL/Input/Identifier/Internal.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Text.CSL.Input.Identifier.Internal where + +import Control.Applicative ((<$>)) +import Control.Lens (_2, Iso, iso, over, Simple, to, use, (%=)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State as State +import Control.Monad.Trans.Either +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Generic as AG +import qualified Data.ByteString.Char8 as BS +import Data.Char (toLower, isSpace) +import Data.Default(Default(..)) +import Data.List (span) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.String.Utils as String (replace) +import qualified Data.Yaml as Yaml +import Network.Curl.Download (openURIWithOpts) +import Network.Curl.Opts (CurlOption(CurlFollowLocation, CurlHttpHeaders)) +import Safe (headMay) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Process (runInteractiveCommand, system) +import System.IO (hGetContents, hClose, hPutStrLn, stderr) +import Text.CSL (Reference, readBiblioString, BibFormat(Bibtex, Json)) +import Text.Printf + +import qualified Paths_citation_resolve as Paths + + + +-- | The data structure that carries the resolved references. +newtype DB = DB { unDB :: Map.Map String String} + +-- | The lens for accessing the map within the DB. +db :: Simple Iso DB (Map.Map String String) +db = iso unDB DB + +instance Default DB where def = DB Map.empty + +instance Yaml.FromJSON DB where + parseJSON x0 = do + x1 <- Yaml.parseJSON x0 + let x1' :: [(String, [String])] + x1' = x1 + return $ DB $ Map.fromList $ map (over _2 unlines) x1' + +instance Yaml.ToJSON DB where + toJSON = Yaml.toJSON . map (over _2 lines) . Map.toList . unDB + + + + +withDBFile :: (MonadIO m, MonadState DB m) => FilePath -> m a -> m a +withDBFile fn prog = do + x <- liftIO $ doesFileExist fn + initState <- case x of + False -> return def + True -> do + con <- liftIO $ BS.readFile fn + case Yaml.decode con of + Just st -> return st + Nothing -> do + liftIO $ hPutStrLn stderr $ "cannot read/parse DB file: " ++ fn + return def + State.put initState + ret <- prog + finalState <- State.get + liftIO $ BS.writeFile fn $ Yaml.encode (finalState :: DB) + return ret + + +-- | Resolver Monad is a function that converts a key of type @a@ to some +-- other type @b@, which may fail with an error message. +type RM m a b = a -> EitherT String m b + +-- | Perform possibly failing IO within a monad + +liftIOE :: MonadIO m => IO (Either a b) -> EitherT a m b +liftIOE = (>>= hoistEither) . liftIO + +-- | parse a Bibtex entry that contains single reference. +resolveBibtex :: MonadIO m => String -> RM m String Reference +resolveBibtex url str = do + rs <- liftIO $ readBiblioString Bibtex str + case rs of + [r] -> right r + [] -> left $ url ++ " returned no parsable reference." + _ -> left $ url ++ " returned multiple references." + + + +-- | resolve a document url to a 'Reference', or emits a error +-- message with reason why it fails. +resolveEither :: forall m. (MonadIO m, MonadState DB m) => String -> EitherT String m Reference +resolveEither url = do + val <- use $ db . to (Map.lookup url) + case val of + Just bibtexStr -> resolveBibtex url bibtexStr + Nothing -> do + reader <- hoistEither selectResolver + bibtexStr <- reader addr + ret <- resolveBibtex url bibtexStr + db %= Map.insert url bibtexStr + return ret + + + where + (h,t) = span (/=':') url + idId = map toLower h + addr = drop 1 t + + selectResolver :: Either String (RM m String String) + selectResolver = + maybe (Left $ "Unknown identifier type: " ++ idId) (Right . snd) $ + headMay $ + filter ((==idId) . fst) specialResolverTbl + + specialResolverTbl = + [ ("arxiv" , resolveArXiv ) + , ("bibcode" , resolveBibcode ) + , ("doi" , resolveDOI ) + , ("isbn" , resolveISBN ) ] + + +-- resolvers for specific document IDs. + +resolveDOI :: MonadIO m => RM m String String +resolveDOI docIDStr = do + let + opts = [ CurlFollowLocation True + , CurlHttpHeaders ["Accept: text/bibliography; style=bibtex"] + ] + url = "http://dx.doi.org/" ++ docIDStr + bs <- liftIOE $ openURIWithOpts opts url + return $ BS.unpack bs + +resolveArXiv :: MonadIO m => RM m String String +resolveArXiv docIDStr = do + let + opts = [ CurlFollowLocation True] + url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&arXiv:" ++ docIDStr + bs <- liftIOE $ openURIWithOpts opts url + return $ + unlines . drop 2 . filter (any (not . isSpace)) . lines $ + String.replace "adsurl" "url" $ + BS.unpack bs + +resolveBibcode :: MonadIO m => RM m String String +resolveBibcode docIDStr = do + let + opts = [ CurlFollowLocation True] + url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&bibcode=" ++ docIDStr + bs <- liftIOE $ openURIWithOpts opts url + return $ + unlines . drop 2 . filter (any (not . isSpace)) . lines $ + String.replace "adsurl" "url" $ BS.unpack bs + +resolveISBN :: MonadIO m => RM m String String +resolveISBN docIDStr = do + let + opts = [ CurlFollowLocation True ] + url = printf "http://xisbn.worldcat.org/webservices/xid/isbn/%s?method=getMetadata&format=xml&fl=*" + docIDStr + bs <- liftIOE $ openURIWithOpts opts url + str <- liftIO $ do + xsltfn <- getDataFileName "isbn2bibtex.xsl" + writeFile xsltfn xsl + (hIn,hOut,_,_) <- runInteractiveCommand $ printf "xsltproc %s -" xsltfn + BS.hPutStr hIn bs + hClose hIn + hGetContents hOut + return $ unlines . filter (any (not . isSpace)) . lines $ str + + where + -- we must dynamically generate this file because it does not + -- exist at the test timing. + + xsl = "\n\n \n \n \n @BOOK{CiteKeyGoesHere,\n AUTHOR = \"\",\n TITLE = \"\",\n PUBLISHER = \"\",\n ADDRESS = \"\",\n YEAR =\"\"}\n\n \n\n" + + +-- | a safer way to get data file name. +getDataFileName :: String -> IO String +getDataFileName fn = do + dd <- Paths.getDataDir + createDirectoryIfMissing True dd + Paths.getDataFileName fn diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,24 +1,51 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-13 Edward Kmett +-- License : BSD-style (see the file LICENSE.doctests) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module provides doctests for a project based on the actual versions +-- of the packages it was built with. It requires a corresponding Setup.lhs +-- to be added to the project +----------------------------------------------------------------------------- module Main where +import Build_doctests (deps) import Control.Applicative import Control.Monad -import Test.DocTest +import Data.List import System.Directory import System.FilePath +import Test.DocTest -findHs :: FilePath -> IO [FilePath] -findHs dir = do - fs <- map (dir ) <$> - filter (`notElem` ["..","."]) <$> - getDirectoryContents dir - subDirs <- filterM doesDirectoryExist fs - files1 <- filter ((`elem` [".hs", ".lhs"]) . takeExtension) <$> - filterM doesFileExist fs - files2 <- concat <$> mapM findHs subDirs - return $ files1 ++ files2 +-- | Run in a modified codepage where we can print UTF-8 values on Windows. +withUnicode :: IO a -> IO a +withUnicode m = m + + main :: IO () -main = do - files <- findHs "Text" - putStrLn $ "testing: " ++ unwords files - doctest $ ["-idist/build/autogen"] ++ files +main = withUnicode $ getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c