{-# LANGUAGE DeriveGeneric #-}
module Network.BackblazeB2.Data where
import qualified Conduit as C
import Control.Monad.Fail (fail)
import Data.Aeson ((.:), (.:?))
import qualified Data.Aeson as Json
import qualified Data.Aeson.Types as Json
import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import qualified Data.Ratio as R
import qualified Data.Scientific as Sc
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime,
utcTimeToPOSIXSeconds)
import Network.HTTP.Client (HttpException (HttpExceptionRequest),
HttpExceptionContent (StatusCodeException))
import Network.HTTP.Req (HttpException (VanillaHttpException),
MonadHttp (..))
import qualified Network.HTTP.Req.Conduit as RC
import qualified Network.HTTP.Types.Header as Hdr
import LocalPrelude
data Credentials =
Credentials
{ cAccountId :: Text
, cApplicationKey :: Text
} deriving (Eq, Show)
instance MonadHttp IO where
handleHttpException e =
case e of
stEx@(VanillaHttpException (HttpExceptionRequest _
(StatusCodeException _ bs)))
-> case Json.decodeStrict bs of
Nothing -> throwIO stEx
Just b2Err -> throwIO $ LEServer b2Err
v -> throwIO v
labelModifierFn :: Int -> Json.Options
labelModifierFn n = Json.defaultOptions {
Json.fieldLabelModifier = fixCase . drop n
}
where
fixCase "" = ""
fixCase (h:t) = Char.toLower h : t
data AuthInfo = AuthInfo
{ aiAccountId :: Text
, aiAuthorizationToken :: Text
, aiApiUrl :: Url 'Https
, aiDownloadUrl :: Url 'Https
, aiRecommendedPartSize :: Int64
} deriving (Eq, Show)
instance Json.FromJSON AuthInfo where
parseJSON (Json.Object v) = do
accId <- v .: "accountId"
authTok <- v .: "authorizationToken"
apiUrlStr <- v .: "apiUrl"
apiUrl <- case parseUrlHttps (encodeUtf8 apiUrlStr) of
Just (url, _) -> return url
_ -> fail "invalid url received."
dwnUrlStr <- v .: "downloadUrl"
dwnUrl <- case parseUrlHttps (encodeUtf8 dwnUrlStr) of
Just (url, _) -> return url
_ -> fail "invalid url received."
rPsz <- v .: "recommendedPartSize"
return $ AuthInfo accId authTok apiUrl dwnUrl rPsz
parseJSON o = Json.typeMismatch "object" o
getDownloadUrl :: AuthInfo -> Url 'Https
getDownloadUrl ai = aiDownloadUrl ai
data ConnectInfo = ConnectInfo
{ creds :: Credentials
, authInfo :: AuthInfo
} deriving (Show, Eq)
data LibErr = LEServer BB2Error
| JsonErr Text
| NoAuthFound
| HeaderMissing Hdr.HeaderName
| HeaderParseError Hdr.HeaderName ByteString [Char]
deriving (Eq, Show)
instance Exception LibErr
tryLibErr :: MonadUnliftIO m => m a -> m (Either LibErr a)
tryLibErr act = try act
data BB2Error = BB2Error { bb2eStatus :: Int
, bb2eCode :: Text
, bb2eMessage :: Text
} deriving (Show, Eq, Generic)
instance Json.FromJSON BB2Error where
parseJSON = Json.genericParseJSON $ labelModifierFn 4
type Bucket = Text
data BucketType = AllPublic | AllPrivate
deriving (Eq, Show)
instance Json.FromJSON BucketType where
parseJSON (Json.String "allPrivate") = return AllPrivate
parseJSON (Json.String "allPublic") = return AllPublic
parseJSON o = Json.typeMismatch "string" o
instance Json.ToJSON BucketType where
toJSON AllPrivate = Json.String "allPrivate"
toJSON AllPublic = Json.String "allPublic"
type BucketInfo = Map.Map Text Text
type BucketId = Text
type FileId = Text
data LifecycleRule = LifecycleRule {
lcrFileNamePrefix :: Text
, lcrDaysFromUploadingToHiding :: Maybe Int64
, lcrDaysFromHidingToDeleting :: Maybe Int64
} deriving (Show, Eq, Generic)
instance Json.ToJSON LifecycleRule where
toJSON = Json.genericToJSON $ labelModifierFn 3
toEncoding = Json.genericToEncoding $ labelModifierFn 3
instance Json.FromJSON LifecycleRule where
parseJSON = Json.genericParseJSON $ labelModifierFn 3
data BucketOpts = BucketOpts {
boBucketInfo :: Maybe BucketInfo
, boLCRs :: [LifecycleRule]
} deriving (Show, Eq)
emptyBucketOpts :: BucketOpts
emptyBucketOpts = BucketOpts Nothing []
data BucketData = BucketData {
brdAccountId :: Text
, brdBucketId :: BucketId
, brdBucketName :: Bucket
, brdBucketType :: BucketType
, brdBucketInfo :: BucketInfo
, brdLifecycleRules :: [LifecycleRule]
, brdRevision :: Int64
} deriving (Show, Eq, Generic)
instance Json.FromJSON BucketData where
parseJSON = Json.genericParseJSON $ labelModifierFn 3
data AllBuckets = AllBuckets {
abBuckets :: [BucketData]
} deriving (Show, Eq, Generic)
instance Json.FromJSON AllBuckets where
parseJSON = Json.genericParseJSON $ labelModifierFn 2
newtype UploadUrl = UploadUrl { unUploadUrl :: (Url 'Https, Option 'Https)}
instance Json.FromJSON UploadUrl where
parseJSON (Json.String s) =
case parseUrlHttps (encodeUtf8 s) of
Just (url, opts) -> return $ UploadUrl (url, opts)
_ -> fail "Invalid url received."
parseJSON o = Json.typeMismatch "string" o
data UploadUrlInfo = UploadUrlInfo
{ uuBucketId :: BucketId
, uuUploadUrl :: UploadUrl
, uuAuthorizationToken :: Text
} deriving (Generic)
instance Json.FromJSON UploadUrlInfo where
parseJSON = Json.genericParseJSON $ labelModifierFn 2
data PartUploadUrlInfo =
PartUploadUrlInfo
{ puuFileId :: FileId
, puuUploadUrl :: UploadUrl
, puuAuthorizationToken :: Text
} deriving (Generic)
instance Json.FromJSON PartUploadUrlInfo where
parseJSON = Json.genericParseJSON $ labelModifierFn 3
data PartUploadResp =
PartUploadResp { purFileId :: FileId
, purContentLength :: Int64
, purContentSha1 :: Text
, purUploadTimestamp :: BBTimestamp
}
deriving (Show, Generic)
instance Json.FromJSON PartUploadResp where
parseJSON = Json.genericParseJSON $ labelModifierFn 3
newtype BBTimestamp = BBTimestamp { getBBTimestamp :: UTCTime }
deriving (Eq, Show)
getMilliEpoch :: BBTimestamp -> Int64
getMilliEpoch (BBTimestamp t) =
1000 * round (utcTimeToPOSIXSeconds t)
instance Json.FromJSON BBTimestamp where
parseJSON = Json.withScientific "UnixMilliEpoch" $ \n ->
let millis = fromIntegral <$> (Sc.toBoundedInteger n :: Maybe Int64)
in case millis of
Just m -> pure . BBTimestamp . posixSecondsToUTCTime .
fromRational $ m R.% 1000
_ -> fail "could not parse milli-epoch time"
instance Json.ToJSON BBTimestamp where
toJSON = Json.toJSON . getMilliEpoch
toEncoding = Json.toEncoding . getMilliEpoch
data FileProps =
FileProps
{ fpContentType :: Text
, fpLastModified :: Maybe UTCTime
, fpMetaInfo :: Map.Map Text Text
} deriving (Show, Eq)
defaultFileProps :: FileProps
defaultFileProps = FileProps "b2/x-auto" Nothing Map.empty
data FileInfo =
FileInfo
{ fiFileId :: Text
, fiFileName :: Text
, fiAccountId :: Text
, fiBucketId :: BucketId
, fiContentLength :: Int64
, fiContentSha1 :: Text
, fiContentType :: Text
, fiFileInfo :: Map.Map Text Text
, fiAction :: Text
, fiUploadTimestamp :: BBTimestamp
} deriving (Show, Eq, Generic)
instance Json.FromJSON FileInfo where
parseJSON = Json.genericParseJSON $ labelModifierFn 2
data DownloadAuth = DownloadAuth {
daBucketId :: BucketId
, daFileNamePrefix :: Text
, daAuthorizationToken :: Text
} deriving (Show, Eq, Generic)
instance Json.FromJSON DownloadAuth where
parseJSON = Json.genericParseJSON $ labelModifierFn 2
type Object = Text
type ObjectId = Text
data ObjectMetadata = ObjectMetadata {
omContentLength :: Int64
, omContentType :: Text
, omObjectId :: ObjectId
, omObjectName :: Object
, omContentSha1 :: Text
, omXBzInfo :: Map Text Text
, omUploadTimestamp :: BBTimestamp
, omCacheControl :: Text
} deriving (Eq, Show)
data FileVersion = FileVersion {
fvFileName :: Object
, fvFileId :: ObjectId
} deriving (Show, Eq, Generic)
instance Json.FromJSON FileVersion where
parseJSON = Json.genericParseJSON $ labelModifierFn 2
instance Json.ToJSON FileVersion where
toJSON = Json.genericToJSON $ labelModifierFn 2
toEncoding = Json.genericToEncoding $ labelModifierFn 2
data ObjectListArgs = ObjectListArgs {
olaBucketId :: BucketId
, olaStartFileName :: Maybe Object
, olaMaxFileCount :: Maybe Int
, olaPrefix :: Maybe Object
, olaDelimiter :: Maybe Text
} deriving (Show, Eq, Generic)
instance Json.ToJSON ObjectListArgs where
toJSON = Json.genericToJSON $ labelModifierFn 3
toEncoding = Json.genericToEncoding $ labelModifierFn 3
data ListResultObjectItem = ListResultObjectItem {
lroiFileId :: Text
, lroiFileName :: Object
, lroiContentLength :: Int64
, lroiContentType :: Maybe Text
, lroiContentSha1 :: Maybe Text
, lroiFileInfo :: Maybe (Map.Map Text Text)
, lroiAction :: Text
, lroiUploadTimestamp :: BBTimestamp
} deriving (Show, Eq, Generic)
instance Json.FromJSON ListResultObjectItem where
parseJSON = Json.genericParseJSON $ labelModifierFn 4
data ListResultFolderItem = ListResultFolderItem {
lrfiFileName :: Object
, lrfiAction :: Text
} deriving (Show, Eq, Generic)
instance Json.FromJSON ListResultFolderItem where
parseJSON = Json.genericParseJSON $ labelModifierFn 4
data ListResultItem = LRIObject ListResultObjectItem
| LRIFolder ListResultFolderItem
deriving (Show, Eq)
instance Json.FromJSON ListResultItem where
parseJSON v = (LRIObject <$> Json.parseJSON v)
<|> (LRIFolder <$> Json.parseJSON v)
data ObjectListResult = ObjectListResult {
olrFiles :: [ListResultObjectItem]
, olrFolders :: [ListResultFolderItem]
, olrNextFileName :: Maybe Object
} deriving (Show, Eq, Generic)
instance Json.FromJSON ObjectListResult where
parseJSON = Json.withObject "ObjectListResult" $ \o -> do
nxt <- o .:? "nextFileName"
listResultItems <- o .: "files"
let (files, folders) = partitionIt listResultItems
return $ ObjectListResult (reverse files) (reverse folders) nxt
where
partitionIt :: [ListResultItem] -> ([ListResultObjectItem],
[ListResultFolderItem])
partitionIt = flip foldl ([], []) $
\(files, folders) item -> case item of
LRIObject x -> (x:files, folders)
LRIFolder x -> (files, x:folders)
data Stream = Stream
{ streamLength :: Int64
, streamSource :: C.ConduitT () ByteString IO ()
}
streamToReqBody :: Stream -> RC.ReqBodySource
streamToReqBody s =
RC.ReqBodySource (streamLength s) (streamSource s)
newtype ObjectConsumer a =
ObjectConsumer
{ unObjectConsumer :: (ObjectMetadata, IO ByteString) -> IO a
}