1 {-# LANGUAGE OverloadedStrings #-} 2 module Model.Citation.CrossRef 3 ( lookupCitation 4 -- for testing 5 , uriHDL 6 ) where 7 8 import Control.Applicative (optional) 9 import Control.Exception (handle) 10 import Control.Monad.Trans.Class (lift) 11 import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) 12 import qualified Data.Attoparsec.ByteString as P 13 import qualified Data.ByteString.Char8 as BSC 14 import Data.Maybe (fromJust) 15 import qualified Data.Text.Lazy as TL 16 import qualified Data.Text.Lazy.Encoding as TLE 17 import qualified Network.HTTP.Client as HC 18 import qualified Network.URI as URI 19 20 import Ops 21 import qualified JSON 22 import HTTP.Client 23 import Model.URL 24 import Model.Citation.Types 25 26 crossRefUrl :: HC.Request 27 crossRefUrl = (fromJust $ HC.parseRequest "http://data.crossref.org/") 28 { HC.cookieJar = Nothing 29 } 30 31 crossRefReq :: String -> HC.Request 32 crossRefReq h = crossRefUrl { HC.path = BSC.pack $ '/' : URI.escapeURIString URI.isUnescapedInURIComponent h } 33 34 uriHDL :: URI.URI -> Maybe String 35 uriHDL u 36 | URI.uriScheme u == "hdl:" = Just $ URI.uriPath u ++ URI.uriQuery u 37 | otherwise = Nothing 38 39 parseCitation :: JSON.Value -> JSON.Parser Citation 40 parseCitation = JSON.withObject "citation" $ \o -> 41 Citation 42 <$> o JSON..:? "head" JSON..!= "" 43 <*> (Just <$> (o JSON..: "DOI" >>= parseDOI)) 44 <*> optional (o JSON..: "issued" >>= (JSON..: "date-parts") >>= (`JSON.lookupAtParse` 0) >>= (`JSON.lookupAtParse` 0)) 45 <*> o JSON..:? "title" 46 where 47 parseDOI d = hdlURL d `useWhen` validHDL d 48 49 lookupCitation :: URI.URI -> HTTPClient -> IO (Maybe Citation) 50 lookupCitation uri hcm = runMaybeT $ do 51 req <- may $ crossRefReq <$> uriHDL uri 52 j <- MaybeT $ httpMaybe $ 53 HC.withResponse (requestAcceptContent "application/vnd.citationstyles.csl+json" req) hcm 54 (fmap P.maybeResult . httpParse JSON.json) 55 cite <- may $ JSON.parseMaybe parseCitation j 56 -- empirically this is UTF-8, but does not say so: 57 lift $ handle 58 (\(_ :: HC.HttpException) -> return cite) -- this actually happens fairly often 59 $ (\h -> cite{ citationHead = TL.toStrict $ TLE.decodeUtf8 $ HC.responseBody h }) <$> 60 HC.httpLbs (requestAcceptContent "text/x-bibliography;style=apa" req) hcm 61 where 62 may = MaybeT . return