casa-client 0.0.2 → 0.0.3
raw patch · 4 files changed
+318/−266 lines, 4 filesdep ~aesondep ~attoparsecdep ~basenew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: aeson, attoparsec, base, base16-bytestring, bytestring, casa-types, conduit, conduit-extra, crypton, exceptions, http-conduit, http-types, memory, network-uri, resourcet, template-haskell, text, th-lift, unliftio-core, unordered-containers
API changes (from Hackage documentation)
- Casa.Client: data PushException
+ Casa.Client: newtype PushException
- Casa.Client: blobsSource :: (MonadThrow m, MonadResource m, MonadIO m) => SourceConfig -> ConduitT i (BlobKey, ByteString) m ()
+ Casa.Client: blobsSource :: forall (m :: Type -> Type) i. (MonadThrow m, MonadResource m, MonadIO m) => SourceConfig -> ConduitT i (BlobKey, ByteString) m ()
Files
- CHANGELOG.md +25/−0
- LICENSE +24/−24
- casa-client.cabal +47/−30
- src/Casa/Client.hs +222/−212
+ CHANGELOG.md view
@@ -0,0 +1,25 @@+# 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.
LICENSE view
@@ -1,24 +1,24 @@-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.+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.cabal view
@@ -1,41 +1,58 @@-cabal-version: 1.12+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 <https://casa.fpcomplete.com/>-version: 0.0.2-copyright: 2018-2019 FP Complete+description: Client for Casa (Content-Addressable Storage Archive). See+ <https://casa.stackage.org/>+category: Development+homepage: https://github.com/commercialhaskell/casa#readme+bug-reports: https://github.com/commercialhaskell/casa/issues author: Chris Done-maintainer: chrisdone@fpcomplete.com+maintainer: Chris Done <chrisdone@fpcomplete.com>,+ Mike Pilgrem <public@pilgrem.com>+copyright: 2018-2019 FP Complete,+ 2024-2025 Haskell Foundation license: BSD3 license-file: LICENSE-category: Development 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- other-modules: Paths_casa_client- hs-source-dirs: src- default-language: Haskell2010+ Casa.Client+ hs-source-dirs:+ src ghc-options: -Wall build-depends:- base >= 4.5 && < 5- , bytestring- , base16-bytestring- , conduit-extra- , conduit- , text- , http-conduit- , exceptions- , casa-types- , resourcet- , http-types- , unordered-containers- , attoparsec- , unliftio-core- , crypton- , memory- , network-uri- , aeson- , th-lift- , template-haskell+ 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
src/Casa/Client.hs view
@@ -1,212 +1,222 @@-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}---- |--module Casa.Client- ( blobsSource- , SourceConfig(..)- , blobsSink- , CasaRepoPrefix- , parseCasaRepoPrefix- , thParserCasaRepo- , PushException(..)- , PullException(..)- ) where--import Casa.Types-import Control.Monad-import Control.Monad.Catch-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Control.Monad.Trans.Resource-import qualified Crypto.Hash as Crypto-import Data.Aeson-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-import Data.Conduit.Attoparsec-import Data.Conduit.ByteString.Builder-import qualified Data.Conduit.List as CL-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import Data.List-import Data.Monoid ((<>))-import Data.Typeable-import Language.Haskell.TH-import Language.Haskell.TH.Lift-import Network.HTTP.Client.Conduit (requestBodySourceChunked)-import Network.HTTP.Simple-import Network.HTTP.Types-import Network.URI---- | An exception from blob consuming/sending.-data PullException- = AttoParseError ParseError- | BadHttpStatus Status- | TooManyReturnedKeys Int- deriving (Show, Typeable)-instance Exception PullException---- | An exception from blob consuming/sending.-data PushException- = PushBadHttpStatus Status- deriving (Show, Typeable)-instance Exception PushException---- | The URL prefix for a casa repo.--- Commonly: @https://casa.fpcomplete.com@--- Parsers will strip out a trailing slash.-newtype CasaRepoPrefix =- CasaRepoPrefix String- deriving (Show, Lift)-instance FromJSON CasaRepoPrefix where- parseJSON j = do- s <- parseJSON j- either fail pure (parseCasaRepoPrefix s)---- | 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 repo. Should be a valid URI e.g. https://casa.fpcomplete.com"- 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 (HM.toList (sourceConfigBlobs sourceConfig)) .| conduit .|- consumer (HM.size (sourceConfigBlobs sourceConfig))- where- makeSkeletonRequest =- fmap- (setRequestMethod "POST")- (parseRequest (casaRepoPullUrl (sourceConfigUrl sourceConfig)))- 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 (sourceConfigBlobs sourceConfig))- consumer remaining = do- mkeyValue <- await- case mkeyValue of- Nothing -> pure ()- Just (Left x) -> throwM (AttoParseError x)- Just (Right (_position, keyValue)) ->- if remaining == 0- then throwM- (TooManyReturnedKeys- (HM.size (sourceConfigBlobs sourceConfig)))- 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+{-# 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