Utils.hs

module Network.BackblazeB2.Utils where

import qualified Data.Aeson                as Json
import qualified Data.ByteString           as B
import           Data.CaseInsensitive      (mk)
import qualified Data.CaseInsensitive      as CI
import qualified Data.Map.Strict           as Map
import           Data.Text.Read            (decimal)
import           Data.Time                 (UTCTime)
import qualified Network.HTTP.Client       as HClient
import qualified Network.HTTP.Types.Header as Hdr
import qualified Network.HTTP.Types.URI    as Uri


import           LocalPrelude

import           Network.BackblazeB2.Data

urlEncode :: Text -> ByteString
urlEncode = Uri.urlEncode False . encodeUtf8

urlDecode :: ByteString -> Text
urlDecode = decodeUtf8LE . Uri.urlDecode True

execRequest :: ( Json.FromJSON a, Json.ToJSON b, MonadIO m
               , MonadReader ConnectInfo m
               )
            => Text
            -> b
            -> m a
execRequest apiName body = do
    ci <- ask
    let ai = authInfo ci
        url = mkUrl apiName ai
        atok = encodeUtf8 $ aiAuthorizationToken ai
        auth = header "Authorization" atok

    fmap responseBody $ liftIO $ req POST url (ReqBodyJson body) jsonResponse auth

  where

    mkUrl :: Text -> AuthInfo -> Url 'Https
    mkUrl name ai = (aiApiUrl ai) /: "b2api" /: "v2" /: name

mkLastModifiedKV
    :: UTCTime
    -> (Text, Text)
mkLastModifiedKV t =
    ("src_last_modified_millis",
     show $ getMilliEpoch $ BBTimestamp t)

parseObjectMetadataHeaders :: Hdr.ResponseHeaders
                           -> Either LibErr ObjectMetadata
parseObjectMetadataHeaders r =
    ObjectMetadata
    <$> parseCL
    <*> (toS <$> lookup Hdr.hContentType)
    <*> (toS <$> lookup (mk "X-Bz-File-Id"))
    <*> (urlDecode <$> lookup (mk "X-Bz-File-Name"))
    <*> (toS <$> lookup (mk "X-Bz-Content-Sha1"))
    <*> pure parseMeta
    <*> (lookup (mk "X-Bz-Upload-Timestamp") >>= parseTimestamp)
    <*> (toS <$> lookup Hdr.hCacheControl)
  where
    h = Map.fromList r

    lookup :: CI.CI ByteString -> Either LibErr ByteString
    lookup k = maybe (Left $ HeaderMissing k) Right $
               Map.lookup k h

    parseCL :: Either LibErr Int64
    parseCL = do
      val <- lookup Hdr.hContentLength
      either (Left . HeaderParseError Hdr.hContentLength val)
        (Right . fst) $ decimal $ decodeUtf8LE val

    isMetaHdr (k, _) = "x-bz-info-" `B.isPrefixOf` (CI.foldedCase k)
    dropLen = B.length "x-bz-info-"
    extractMeta (k, v) = (decodeUtf8LE $ B.drop dropLen $ CI.original k,
                          urlDecode v)
    parseMeta = Map.fromList $ map extractMeta $ filter isMetaHdr r

    parseTimestamp :: ByteString -> Either LibErr BBTimestamp
    parseTimestamp = either (Left . JsonErr . toS) Right
                   . Json.eitherDecodeStrict

doRequest :: MonadIO m
          => ObjectConsumer b
          -> (Url scheme, Option scheme) -> m b
doRequest consumer (url, opts) =
    liftIO $ reqBr GET url NoReqBody opts $ \r -> do
        let hdrs = HClient.responseHeaders r
            metaE = parseObjectMetadataHeaders hdrs
        case metaE of
          Left e -> throwIO e
          Right meta -> do
              let bodyReader = HClient.responseBody r
              (unObjectConsumer consumer) (meta, bodyReader)