module EZID.API
( EZIDM
, runEZIDM
, ezidStatus
, EZIDMeta(..)
, ezidCreate
, ezidModify
) where
import Control.Arrow (left)
import Control.Exception.Lifted (try)
import Control.Monad ((<=<), join)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT(..))
import qualified Data.Attoparsec.ByteString as P
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import Data.Char (isSpace)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (getCurrentTime)
import qualified Network.HTTP.Client as HC
import Network.HTTP.Types (methodGet, methodPut, methodPost)
import Network.URI (URI)
import qualified Text.XML.Light as XML
import Ops
import Has
import Model.Id.Types
import Model.Identity.Types
import Model.Party.Types
import Model.Permission.Types
import Service.DB
import Service.Types
import Service.Log
import Context
import HTTP.Client
import EZID.Service
import qualified EZID.ANVL as ANVL
import EZID.DataCite
data EZIDContext = EZIDContext
{ ezidContext :: !BackgroundContext
, contextEZID :: !EZID
}
instance Has Model.Permission.Types.Access EZIDContext where
view = view . ezidContext
instance Has (Model.Id.Types.Id Model.Party.Types.Party) EZIDContext where
view = view . ezidContext
instance Has Model.Party.Types.Party EZIDContext where
view = view . ezidContext
instance Has Model.Party.Types.SiteAuth EZIDContext where
view = view . ezidContext
instance Has Model.Identity.Types.Identity EZIDContext where
view = view . ezidContext
instance Has Service.DB.DBConn EZIDContext where
view = view . ezidContext
instance Has Logs EZIDContext where
view = view . ezidContext
instance Has HTTPClient EZIDContext where
view = view . ezidContext
instance Has EZID EZIDContext where
view = contextEZID
type EZIDM a = CookiesT (ReaderT EZIDContext IO) a
runEZIDM :: EZIDM a -> BackgroundContextM (Maybe a)
runEZIDM f = ReaderT $ \ctx ->
mapM (runReaderT (runCookiesT f) . EZIDContext ctx)
(serviceEZID $ contextService $ backgroundContext ctx)
ezidCall :: BS.ByteString -> BS.ByteString -> ANVL.ANVL -> EZIDM (Maybe ANVL.ANVL)
ezidCall path method body = do
req <- peeks ezidRequest
t <- liftIO getCurrentTime
r <- try $ withResponseCookies (requestAcceptContent "text/plain" req)
{ HC.path = path
, HC.method = method
, HC.requestBody = HC.RequestBodyLBS $ B.toLazyByteString $ ANVL.encode body
} (fmap P.eitherResult . httpParse ANVL.parse)
let r' = join $ left (show :: HC.HttpException -> String) r
focusIO $ logMsg t $ toLogStr ("ezid: " <> method <> " " <> path <> ": ") <> toLogStr (either id show r')
return $ rightJust r'
ezidCheck :: ANVL.ANVL -> Maybe T.Text
ezidCheck = lookup "success"
ezidStatus :: EZIDM Bool
ezidStatus =
isJust . (ezidCheck =<<) <$> ezidCall "/status" methodGet []
data EZIDMeta
= EZIDPublic
{ ezidTarget :: !URI
, ezidDataCite :: !DataCite
}
| EZIDUnavailable
ezidMeta :: EZIDMeta -> ANVL.ANVL
ezidMeta EZIDPublic{..} =
[ ("_target", T.pack $ show ezidTarget)
, ("_status", "public")
, ("_profile", "datacite")
, ("datacite", T.pack $ XML.showTopElement $ dataCiteXML ezidDataCite)
]
ezidMeta EZIDUnavailable = [ ("_status", "unavailable") ]
ezidCreate :: BS.ByteString -> EZIDMeta -> EZIDM (Maybe BS.ByteString)
ezidCreate hdl meta = do
ns <- peeks ezidNS
fmap (TE.encodeUtf8 . T.takeWhile (\c -> c /= '|' && not (isSpace c))) . (=<<) (T.stripPrefix "doi:" <=< ezidCheck) <$>
ezidCall ("/id/" <> ns <> hdl) methodPut (ezidMeta meta)
ezidModify :: BS.ByteString -> EZIDMeta -> EZIDM Bool
ezidModify hdl meta =
isJust . (ezidCheck =<<) <$>
ezidCall ("/id/doi:" <> hdl) methodPost (ezidMeta meta)