1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 module EZID.API 3 ( EZIDM 4 , runEZIDM 5 , ezidStatus 6 , EZIDMeta(..) 7 , ezidCreate 8 , ezidModify 9 ) where 10 11 import Control.Arrow (left) 12 import Control.Exception.Lifted (try) 13 import Control.Monad ((<=<), join) 14 import Control.Monad.IO.Class (liftIO) 15 import Control.Monad.Trans.Reader (ReaderT(..)) 16 import qualified Data.Attoparsec.ByteString as P 17 import qualified Data.ByteString as BS 18 import qualified Data.ByteString.Builder as B 19 import Data.Char (isSpace) 20 import Data.Maybe (isJust) 21 import Data.Monoid ((<>)) 22 import qualified Data.Text as T 23 import qualified Data.Text.Encoding as TE 24 import Data.Time.Clock (getCurrentTime) 25 import qualified Network.HTTP.Client as HC 26 import Network.HTTP.Types (methodGet, methodPut, methodPost) 27 import Network.URI (URI) 28 import qualified Text.XML.Light as XML 29 30 import Ops 31 import Has 32 import Model.Id.Types 33 import Model.Identity.Types 34 import Model.Party.Types 35 import Model.Permission.Types 36 import Service.DB 37 import Service.Types 38 import Service.Log 39 import Context 40 import HTTP.Client 41 import EZID.Service 42 import qualified EZID.ANVL as ANVL 43 import EZID.DataCite 44 45 data EZIDContext = EZIDContext 46 { ezidContext :: !BackgroundContext 47 , contextEZID :: !EZID 48 } 49 50 instance Has Model.Permission.Types.Access EZIDContext where 51 view = view . ezidContext 52 instance Has (Model.Id.Types.Id Model.Party.Types.Party) EZIDContext where 53 view = view . ezidContext 54 instance Has Model.Party.Types.Party EZIDContext where 55 view = view . ezidContext 56 instance Has Model.Party.Types.SiteAuth EZIDContext where 57 view = view . ezidContext 58 instance Has Model.Identity.Types.Identity EZIDContext where 59 view = view . ezidContext 60 instance Has Service.DB.DBConn EZIDContext where 61 view = view . ezidContext 62 instance Has Logs EZIDContext where 63 view = view . ezidContext 64 instance Has HTTPClient EZIDContext where 65 view = view . ezidContext 66 instance Has EZID EZIDContext where 67 view = contextEZID 68 69 type EZIDM a = CookiesT (ReaderT EZIDContext IO) a 70 71 runEZIDM :: EZIDM a -> BackgroundContextM (Maybe a) 72 runEZIDM f = ReaderT $ \ctx -> 73 mapM (runReaderT (runCookiesT f) . EZIDContext ctx) 74 (serviceEZID $ contextService $ backgroundContext ctx) 75 76 ezidCall :: BS.ByteString -> BS.ByteString -> ANVL.ANVL -> EZIDM (Maybe ANVL.ANVL) 77 ezidCall path method body = do 78 req <- peeks ezidRequest 79 t <- liftIO getCurrentTime 80 r <- try $ withResponseCookies (requestAcceptContent "text/plain" req) 81 { HC.path = path 82 , HC.method = method 83 , HC.requestBody = HC.RequestBodyLBS $ B.toLazyByteString $ ANVL.encode body 84 } (fmap P.eitherResult . httpParse ANVL.parse) 85 let r' = join $ left (show :: HC.HttpException -> String) r 86 focusIO $ logMsg t $ toLogStr ("ezid: " <> method <> " " <> path <> ": ") <> toLogStr (either id show r') 87 return $ rightJust r' 88 89 ezidCheck :: ANVL.ANVL -> Maybe T.Text 90 ezidCheck = lookup "success" 91 92 ezidStatus :: EZIDM Bool 93 ezidStatus = 94 isJust . (ezidCheck =<<) <$> ezidCall "/status" methodGet [] 95 96 data EZIDMeta 97 = EZIDPublic 98 { ezidTarget :: !URI 99 , ezidDataCite :: !DataCite 100 } 101 | EZIDUnavailable 102 103 ezidMeta :: EZIDMeta -> ANVL.ANVL 104 ezidMeta EZIDPublic{..} = 105 [ ("_target", T.pack $ show ezidTarget) 106 , ("_status", "public") 107 , ("_profile", "datacite") 108 , ("datacite", T.pack $ XML.showTopElement $ dataCiteXML ezidDataCite) 109 ] 110 ezidMeta EZIDUnavailable = [ ("_status", "unavailable") ] 111 112 ezidCreate :: BS.ByteString -> EZIDMeta -> EZIDM (Maybe BS.ByteString) 113 ezidCreate hdl meta = do 114 ns <- peeks ezidNS 115 fmap (TE.encodeUtf8 . T.takeWhile (\c -> c /= '|' && not (isSpace c))) . (=<<) (T.stripPrefix "doi:" <=< ezidCheck) <$> 116 ezidCall ("/id/" <> ns <> hdl) methodPut (ezidMeta meta) 117 118 ezidModify :: BS.ByteString -> EZIDMeta -> EZIDM Bool 119 ezidModify hdl meta = 120 isJust . (ezidCheck =<<) <$> 121 ezidCall ("/id/doi:" <> hdl) methodPost (ezidMeta meta)