casa-client-0.0.3/src/ 0000755 0000000 0000000 00000000000 15063336353 012661 5 ustar 00 0000000 0000000 casa-client-0.0.3/src/Casa/ 0000755 0000000 0000000 00000000000 15065567032 013532 5 ustar 00 0000000 0000000 casa-client-0.0.3/src/Casa/Client.hs 0000644 0000000 0000000 00000017273 15065574513 015320 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Types and functions for a client for Casa (Content-addressable Storage
-- Archive).
module Casa.Client
( blobsSource
, SourceConfig (..)
, blobsSink
, CasaRepoPrefix
, parseCasaRepoPrefix
, thParserCasaRepo
, PushException (..)
, PullException (..)
) where
import Casa.Types
( BlobKey (..), blobKeyBinaryParser, blobKeyToBuilder )
import Control.Monad ( (>=>), unless )
import Control.Monad.Catch ( Exception, MonadThrow (..) )
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.IO.Unlift
( MonadUnliftIO, UnliftIO (..), askUnliftIO )
import Control.Monad.Trans.Resource ( MonadResource )
import qualified Crypto.Hash as Crypto
import Data.Aeson ( FromJSON (..) )
import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.ByteArray as Mem
import Data.ByteString ( ByteString )
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder as SB
import Data.Conduit ( ConduitT, (.|), await, transPipe, yield )
import Data.Conduit.Attoparsec ( ParseError, conduitParserEither )
import Data.Conduit.ByteString.Builder ( builderToByteString )
import qualified Data.Conduit.List as CL
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as HM
#if !MIN_VERSION_base(4,20,0)
import Data.Foldable ( foldl' )
#endif
import Language.Haskell.TH ( Exp, Q )
import Language.Haskell.TH.Lift ( Lift (..) )
import Network.HTTP.Client.Conduit ( requestBodySourceChunked )
import Network.HTTP.Simple
( Request, getResponseBody, getResponseStatus
, httpNoBody, httpSource, parseRequest, setRequestBody
, setRequestBodyLBS, setRequestMethod
)
import Network.HTTP.Types ( Status (..) )
import Network.URI ( parseURI )
-- | An exception from blob consuming/sending.
data PullException
= AttoParseError ParseError
| BadHttpStatus Status
| TooManyReturnedKeys Int
deriving Show
instance Exception PullException
-- | An exception from blob consuming/sending.
newtype PushException
= PushBadHttpStatus Status
deriving Show
instance Exception PushException
-- | The URL prefix for a Casa repository, commonly @https://casa.stackage.org@.
-- Parsers will strip out a trailing slash.
newtype CasaRepoPrefix =
CasaRepoPrefix String
deriving (Show, Lift)
instance FromJSON CasaRepoPrefix where
parseJSON = parseJSON >=> (either fail pure . parseCasaRepoPrefix)
-- | TH compile-time parser.
thParserCasaRepo :: String -> Q Exp
thParserCasaRepo = either error lift . parseCasaRepoPrefix
-- | Parse and normalize a Casa repo prefix.
parseCasaRepoPrefix :: String -> Either String CasaRepoPrefix
parseCasaRepoPrefix s =
case parseURI s of
Nothing ->
Left
"Invalid URI for repository. Should be a valid URI e.g. https://casa.stackage.org"
Just {} -> pure (CasaRepoPrefix (stripTrailing s))
where
stripTrailing = reverse . dropWhile (== '/') . reverse
-- | Used to build request paths.
casaServerVersion :: String
casaServerVersion = "v1"
-- | Build the URL from a repo prefix.
casaRepoPushUrl :: CasaRepoPrefix -> String
casaRepoPushUrl (CasaRepoPrefix uri) =
uri <> "/" <> casaServerVersion <> "/push"
-- | Build the URL from a repo prefix.
casaRepoPullUrl :: CasaRepoPrefix -> String
casaRepoPullUrl (CasaRepoPrefix uri) =
uri <> "/" <> casaServerVersion <> "/pull"
-- | A sink to push blobs to the server. Throws 'PushException'.
blobsSink ::
(MonadIO m, MonadThrow m, MonadUnliftIO m)
=> CasaRepoPrefix
-> ConduitT () ByteString m ()
-> m ()
blobsSink casaRepoUrl blobs = do
runInIO <- askUnliftIO
request <- makeRequest runInIO
response <- httpNoBody request
case getResponseStatus response of
Status 200 _ -> pure ()
status -> throwM (PushBadHttpStatus status)
where
makeRequest (UnliftIO runInIO) =
fmap
( setRequestBody
( requestBodySourceChunked
( transPipe runInIO blobs
.| CL.map
( \v ->
SB.word64BE (fromIntegral (S.length v))
<> SB.byteString v
)
.| builderToByteString
)
)
. setRequestMethod "POST"
)
(parseRequest (casaRepoPushUrl casaRepoUrl))
-- | Configuration for sourcing blobs from the server.
data SourceConfig =
SourceConfig
{ sourceConfigUrl :: !CasaRepoPrefix
-- ^ URL to pull from.
, sourceConfigBlobs :: !(HashMap BlobKey Int)
-- ^ The blobs to pull.
, sourceConfigMaxBlobsPerRequest :: !Int
-- ^ Maximum number of blobs per request; we split requests into chunks of
-- this number.
}
-- | Make a source of blobs from a URL. Throws 'PullException'.
blobsSource ::
(MonadThrow m, MonadResource m, MonadIO m)
=> SourceConfig
-> ConduitT i (BlobKey, ByteString) m ()
blobsSource sourceConfig = do
skeletonRequest <- makeSkeletonRequest
source skeletonRequest scBlobsList .| conduit .| consumer scBlobsSize
where
makeSkeletonRequest =
fmap
(setRequestMethod "POST")
(parseRequest (casaRepoPullUrl (sourceConfigUrl sourceConfig)))
scBlobs = sourceConfigBlobs sourceConfig
scBlobsList = HM.toList scBlobs
scBlobsSize = HM.size scBlobs
source skeletonRequest blobs =
unless (null blobs) $ do
httpSource filledRequest $ \response ->
case getResponseStatus response of
Status 200 _ -> getResponseBody response
status -> throwM (BadHttpStatus status)
source skeletonRequest remainingBlobs
where
(filledRequest, remainingBlobs) =
setRequestBlobs sourceConfig blobs skeletonRequest
conduit = conduitParserEither (blobKeyValueParser scBlobs)
consumer remaining = await >>= \case
Nothing -> pure ()
Just (Left x) -> throwM (AttoParseError x)
Just (Right (_position, keyValue)) ->
if remaining == 0
then throwM (TooManyReturnedKeys scBlobsSize)
else do
yield keyValue
consumer (remaining - 1)
-- | Fill the body of the request with max blobs per request.
setRequestBlobs ::
SourceConfig -> [(BlobKey, Int)] -> Request -> (Request, [(BlobKey, Int)])
setRequestBlobs sourceConfig blobs skeletonRequest = (request, remaining)
where
request =
setRequestBodyLBS
( SB.toLazyByteString
( foldl'
(\a (k, v) ->
a <> (blobKeyToBuilder k <> SB.word64BE (fromIntegral v)))
mempty
thisBatch
)
)
skeletonRequest
(thisBatch, remaining) =
splitAt (sourceConfigMaxBlobsPerRequest sourceConfig) blobs
-- | Parser for a key/value.
blobKeyValueParser :: HashMap BlobKey Int -> Atto.Parser (BlobKey, ByteString)
blobKeyValueParser lengths = do
blobKey <- blobKeyBinaryParser
case HM.lookup blobKey lengths of
Nothing -> fail $ "Invalid key: " <> show blobKey
Just len -> do
blob <- Atto.take len
if BlobKey (sha256Hash blob) == blobKey
then pure (blobKey, blob)
else fail $ "Content does not match SHA256 hash: " <> show blobKey
-- | Hash some raw bytes.
sha256Hash :: ByteString -> ByteString
sha256Hash = Mem.convert . Crypto.hashWith Crypto.SHA256
casa-client-0.0.3/CHANGELOG.md 0000644 0000000 0000000 00000001133 15065612117 013676 0 ustar 00 0000000 0000000 # Change log for `casa-client`
All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to the
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
## 0.0.3 - 2023-09-27
* Drop support for GHC versions before GHC 8.4.
* Add `CHANGELOG.md`.
* Add URLs to Cabal file.
## 0.0.2 - 2023-08-15
* Depend on `crypton` rather than `cryptonite`.
## 0.0.1 - 2020-03-05
* Relax upper bound to allow `base < 5`.
## 0.0.0 - 2020-03-05
* Initial version.
casa-client-0.0.3/LICENSE 0000644 0000000 0000000 00000002754 15063336353 013107 0 ustar 00 0000000 0000000 Copyright (c) 2019, Stack contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of Stack nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
casa-client-0.0.3/casa-client.cabal 0000644 0000000 0000000 00000003111 15065603357 015240 0 ustar 00 0000000 0000000 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.38.2.
--
-- see: https://github.com/sol/hpack
name: casa-client
version: 0.0.3
synopsis: Client for Casa
description: Client for Casa (Content-Addressable Storage Archive). See
category: Development
homepage: https://github.com/commercialhaskell/casa#readme
bug-reports: https://github.com/commercialhaskell/casa/issues
author: Chris Done
maintainer: Chris Done ,
Mike Pilgrem
copyright: 2018-2019 FP Complete,
2024-2025 Haskell Foundation
license: BSD3
license-file: LICENSE
build-type: Simple
extra-source-files:
CHANGELOG.md
source-repository head
type: git
location: https://github.com/commercialhaskell/casa
subdir: casa-client
library
exposed-modules:
Casa.Client
hs-source-dirs:
src
ghc-options: -Wall
build-depends:
aeson >=1.5.6.0
, attoparsec >=0.13.2.5
, base >=4.8 && <5
, base16-bytestring >=1.0.2.0
, bytestring >=0.10.12.0
, casa-types >=0.0.2
, conduit >=1.3.4.2
, conduit-extra >=1.3.5
, crypton >=0.34
, exceptions >=0.10.4
, http-conduit >=2.3.8
, http-types >=0.12.3
, memory >=0.15.0
, network-uri >=2.6.4.1
, resourcet >=1.2.4.3
, template-haskell >=2.16.0.0
, text >=1.2.4.1
, th-lift >=0.8.2
, unliftio-core >=0.2.0.1
, unordered-containers >=0.2.16.0
default-language: Haskell2010