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)