1 {-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-} 2 module Databrary.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 Databrary.Ops 31 import Databrary.Has 32 import Databrary.Model.Id.Types 33 import Databrary.Model.Identity.Types 34 import Databrary.Model.Party.Types 35 import Databrary.Model.Permission.Types 36 import Databrary.Service.DB 37 import Databrary.Service.Types 38 import Databrary.Service.Log 39 import Databrary.Context 40 import Databrary.HTTP.Client 41 import Databrary.EZID.Service 42 import qualified Databrary.EZID.ANVL as ANVL 43 import Databrary.EZID.DataCite 44 45 data EZIDContext = EZIDContext 46 { ezidContext :: !BackgroundContext 47 , contextEZID :: !EZID 48 } 49 50 -- makeHasRec ''EZIDContext ['ezidContext, 'contextEZID] 51 -- instance Has BackgroundContext EZIDContext where 52 -- view = ezidContext 53 instance Has Databrary.Model.Permission.Types.Access EZIDContext where 54 view = (view . ezidContext) 55 instance Has (Databrary.Model.Id.Types.Id Databrary.Model.Party.Types.Party) EZIDContext where 56 view = (view . ezidContext) 57 instance Has Databrary.Model.Party.Types.Party EZIDContext where 58 view = (view . ezidContext) 59 instance Has Databrary.Model.Party.Types.SiteAuth EZIDContext where 60 view = (view . ezidContext) 61 instance Has Databrary.Model.Identity.Types.Identity EZIDContext where 62 view = (view . ezidContext) 63 instance Has Databrary.Service.DB.DBConn EZIDContext where 64 view = (view . ezidContext) 65 -- instance Has Control.Monad.Trans.Resource.InternalState EZIDContext where 66 -- view = (view . ezidContext) 67 -- instance Has time-1.6.0.1:Data.Time.Calendar.Days.Day EZIDContext where 68 -- view = (view . ezidContext) 69 -- instance Has Databrary.Model.Time.Timestamp EZIDContext where 70 -- view = (view . ezidContext) 71 -- instance Has Secret EZIDContext where 72 -- view = (view . ezidContext) 73 -- instance Has Databrary.Service.Entropy.Entropy EZIDContext where 74 -- view = (view . ezidContext) 75 -- instance Has Databrary.Service.Passwd.Passwd EZIDContext where 76 -- view = (view . ezidContext) 77 instance Has Logs EZIDContext where 78 view = (view . ezidContext) 79 -- instance Has Databrary.Service.Messages.Messages EZIDContext where 80 -- view = (view . ezidContext) 81 -- instance Has Databrary.Service.DB.DBPool EZIDContext where 82 -- view = (view . ezidContext) 83 -- instance Has Databrary.Store.Types.Storage EZIDContext where 84 -- view = (view . ezidContext) 85 -- instance Has Databrary.Store.AV.AV EZIDContext where 86 -- view = (view . ezidContext) 87 -- instance Has Databrary.Web.Types.Web EZIDContext where 88 -- view = (view . ezidContext) 89 instance Has HTTPClient EZIDContext where 90 view = (view . ezidContext) 91 -- instance Has Databrary.Static.Service.Static EZIDContext where 92 -- view = (view . ezidContext) 93 -- instance Has Databrary.Ingest.Service.Ingest EZIDContext where 94 -- view = (view . ezidContext) 95 -- instance Has Databrary.Solr.Service.Solr EZIDContext where 96 -- view = (view . ezidContext) 97 -- instance Has Databrary.Service.Notification.Notifications EZIDContext where 98 -- view = (view . ezidContext) 99 -- instance Has Service EZIDContext where 100 -- view = (view . ezidContext) 101 -- instance Has Context EZIDContext where 102 -- view = (view . ezidContext) 103 instance Has EZID EZIDContext where 104 view = contextEZID 105 106 type EZIDM a = CookiesT (ReaderT EZIDContext IO) a 107 108 runEZIDM :: EZIDM a -> BackgroundContextM (Maybe a) 109 runEZIDM f = ReaderT $ \ctx -> 110 mapM (runReaderT (runCookiesT f) . EZIDContext ctx) 111 (serviceEZID $ contextService $ backgroundContext ctx) 112 113 ezidCall :: BS.ByteString -> BS.ByteString -> ANVL.ANVL -> EZIDM (Maybe ANVL.ANVL) 114 ezidCall path method body = do 115 req <- peeks ezidRequest 116 t <- liftIO getCurrentTime 117 r <- try $ withResponseCookies (requestAcceptContent "text/plain" req) 118 { HC.path = path 119 , HC.method = method 120 , HC.requestBody = HC.RequestBodyLBS $ B.toLazyByteString $ ANVL.encode body 121 } (fmap P.eitherResult . httpParse ANVL.parse) 122 let r' = join $ left (show :: HC.HttpException -> String) r 123 focusIO $ logMsg t $ toLogStr ("ezid: " <> method <> " " <> path <> ": ") <> toLogStr (either id show r') 124 return $ rightJust r' 125 126 ezidCheck :: ANVL.ANVL -> Maybe T.Text 127 ezidCheck = lookup "success" 128 129 ezidStatus :: EZIDM Bool 130 ezidStatus = 131 isJust . (ezidCheck =<<) <$> ezidCall "/status" methodGet [] 132 133 data EZIDMeta 134 = EZIDPublic 135 { ezidTarget :: !URI 136 , ezidDataCite :: !DataCite 137 } 138 | EZIDUnavailable 139 140 ezidMeta :: EZIDMeta -> ANVL.ANVL 141 ezidMeta EZIDPublic{..} = 142 [ ("_target", T.pack $ show ezidTarget) 143 , ("_status", "public") 144 , ("_profile", "datacite") 145 , ("datacite", T.pack $ XML.showTopElement $ dataCiteXML ezidDataCite) 146 ] 147 ezidMeta EZIDUnavailable = [ ("_status", "unavailable") ] 148 149 ezidCreate :: BS.ByteString -> EZIDMeta -> EZIDM (Maybe BS.ByteString) 150 ezidCreate hdl meta = do 151 ns <- peeks ezidNS 152 fmap (TE.encodeUtf8 . T.takeWhile (\c -> c /= '|' && not (isSpace c))) . (=<<) (T.stripPrefix "doi:" <=< ezidCheck) <$> 153 ezidCall ("/id/" <> ns <> hdl) methodPut (ezidMeta meta) 154 155 ezidModify :: BS.ByteString -> EZIDMeta -> EZIDM Bool 156 ezidModify hdl meta = 157 isJust . (ezidCheck =<<) <$> 158 ezidCall ("/id/doi:" <> hdl) methodPost (ezidMeta meta)