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)