diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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.
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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.
diff --git a/casa-client.cabal b/casa-client.cabal
--- a/casa-client.cabal
+++ b/casa-client.cabal
@@ -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
-version: 0.0.2
-copyright: 2018-2019 FP Complete
+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: chrisdone@fpcomplete.com
+maintainer: Chris Done ,
+ Mike Pilgrem
+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
diff --git a/src/Casa/Client.hs b/src/Casa/Client.hs
--- a/src/Casa/Client.hs
+++ b/src/Casa/Client.hs
@@ -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