{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -- | module Main where import Conduit ( sourceLazy, withSourceFile ) import qualified Data.ByteString.Char8 as C import qualified Data.CaseInsensitive as CI import Data.Foldable ( Foldable(toList), for_ ) import Data.Generics.Labels () import Data.Maybe ( isJust ) import qualified Data.Sequence as S import qualified Data.Text as T import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 ( iso8601ParseM ) import Lens.Micro import Network.DO.Spaces ( newSpaces ) import Network.DO.Spaces.Actions import Network.DO.Spaces.Request import Network.DO.Spaces.Types import Network.HTTP.Types ( mkStatus ) import Test.Hspec main :: IO () main = sequence_ [ requests , errorResponse , listAllBucketsResponse , listBucket , bucketLocationResponse , objectInfoResponse , copyObject , beginMultipartResponse , listPartsResponse , bucketName , bucketCORS , bucketACLs , bucketLifecycle ] requests :: IO () requests = do sp <- testSpaces spacesRequest <- newSpacesRequest (testBuilder sp) testTime hspec . describe "Network.DO.Spaces.Request" $ do it "generates the canonical request" $ (spacesRequest & canonicalRequest) `shouldBe` canonRequest it "generates the string to sign" $ mkStringToSign spacesRequest `shouldBe` strToSign it "generates the signature" $ mkSignature spacesRequest strToSign `shouldBe` sig it "generates the authorization" $ mkAuthorization spacesRequest strToSign `shouldBe` auth where bodyHash = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" canonRequest = Canonicalized $ C.intercalate "\n" [ "GET" , "/" , "" , "host:a-bucket.sgp1.digitaloceanspaces.com" , "x-amz-content-sha256:" <> bodyHash , "x-amz-date:20210404T214315Z" , "" , "host;x-amz-content-sha256;x-amz-date" , bodyHash ] strToSign = StringToSign $ C.intercalate "\n" [ "AWS4-HMAC-SHA256" , "20210404T214315Z" , "20210404/sgp1/s3/aws4_request" , "266d2fb56a251205c42c7e0deb7d2e370574cf190f366ecf53179c27697c8e38" ] sig = Signature "3d0da77e916e588d05f0190f8c350eddb47337953897b1e0cfdb44075fd6b2b9" auth = Authorization $ mconcat [ "AWS4-HMAC-SHA256 Credential=" , "II5JDQBAN3JYM4DNEB6C" , "/" , "20210404/sgp1/s3/aws4_request, " , "SignedHeaders=" , "host;x-amz-content-sha256;x-amz-date, " , "Signature=" , uncompute sig ] testTime = read @UTCTime "2021-04-04 21:43:15 +0000" testBuilder spaces = SpacesRequestBuilder { spaces , method = Nothing , body = Nothing , headers = mempty , bucket = Just testBucket , object = Nothing , subresources = Nothing , queryString = Nothing , overrideRegion = Nothing } testBucket = Bucket "a-bucket" testSpaces :: IO Spaces testSpaces = newSpaces Singapore (Explicit (AccessKey "II5JDQBAN3JYM4DNEB6C") (SecretKey "wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY")) errorResponse :: IO () errorResponse = do apiEx <- withSourceFile "./tests/data/error-response.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } parseErrorResponse status raw hspec . describe "Network.DO.Spaces.Actions.parseErrorResponse" . it "parses Spaces XML error responses correctly" $ apiEx `shouldBe` APIException { code = "SignatureDoesNotMatch" , requestID = "tx000012a832c-nyc3" , hostID = "71f0230-nyc3a-nyc" , status } where status = mkStatus 403 "" listAllBucketsResponse :: IO () listAllBucketsResponse = do sp <- testSpaces allBuckets <- withSourceFile "./tests/data/list-all-buckets.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @ListAllBuckets raw) sp d1 <- iso8601ParseM @_ @UTCTime "2017-06-23T18:37:48.157Z" d2 <- iso8601ParseM @_ @UTCTime "2017-06-23T18:37:48.157Z" hspec . describe "Network.DO.Spaces.Actions.ListAllBuckets" . it "parses the response correctly" $ allBuckets `shouldBe` ListAllBucketsResponse { owner = Owner (OwnerID 6174283) (OwnerID 6174283) , buckets = S.fromList [ BucketInfo (Bucket "static-images") d1 , BucketInfo (Bucket "log-files") d2 ] } listBucket :: IO () listBucket = do sp <- testSpaces bucketContents <- withSourceFile "./tests/data/list-bucket.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @ListBucket raw) sp d1 <- iso8601ParseM @_ @UTCTime "2017-07-13T18:40:46.777Z" d2 <- iso8601ParseM @_ @UTCTime "2017-07-14T17:44:03.597Z" hspec . describe "Network.DO.Spaces.Actions.ListBucket" $ do it "parses the response correctly" $ bucketContents `shouldBe` listBucketResp d1 d2 it "ensures maxKeys is within the correct range" $ do let badReq = listBucketReq $ Just (-1) badReq2 = listBucketReq $ Just 1001 runSpacesT (buildRequest badReq) sp `shouldThrow` (InvalidRequest msg ==) runSpacesT (buildRequest badReq2) sp `shouldThrow` (InvalidRequest msg ==) where listBucketReq maxKeys = ListBucket { bucket = Bucket "some-bucket" , delimiter = Nothing , marker = Nothing , prefix = Nothing , maxKeys } msg = "ListBucket: maxKeys must be >= 0 && <= 1000" listBucketResp d1 d2 = ListBucketResponse { bucket = Bucket "static-images" , prefix = Nothing , marker = Nothing , nextMarker = Nothing , maxKeys = 1000 , isTruncated = False , objects = S.fromList [ ObjectInfo { object = Object "example.txt" , lastModified = d1 , etag = "b3a92f49e7ae64acbf6b3e76f2040f5e" , size = 14 , owner = Owner (OwnerID 6174283) (OwnerID 6174283) } , ObjectInfo { object = Object "sammy.png" , lastModified = d2 , etag = "fb08934ef619f205f272b0adfd6c018c" , size = 35369 , owner = Owner (OwnerID 6174283) (OwnerID 6174283) } ] } bucketLocationResponse :: IO () bucketLocationResponse = do sp <- testSpaces bucketContents <- withSourceFile "./tests/data/bucket-location.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @GetBucketLocation raw) sp hspec . describe "Network.DO.Spaces.Actions.GetBucketLocation" . it "parses the response correctly" $ bucketContents `shouldBe` GetBucketLocationResponse { locationConstraint = NewYork } objectInfoResponse :: IO () objectInfoResponse = do sp <- testSpaces let body = sourceLazy mempty headers = [ (CI.mk "Content-Type", "text/plain") , (CI.mk "Content-Length", "14") , (CI.mk "Etag", "b3a92f49e7ae64acbf6b3e76f2040f5e") , (CI.mk "Last-Modified", "Thu, 13 Jul 2017 18:40:46 GMT") ] raw = RawResponse { .. } objectInfo <- runSpacesT (consumeResponse @_ @GetObjectInfo raw) sp hspec . describe "Network.DO.Spaces.Actions.GetObjectInfo" . it "parses response headers correctly" $ objectInfo `shouldBe` ObjectMetadata { contentLength = 14 , contentType = "text/plain" , etag = "b3a92f49e7ae64acbf6b3e76f2040f5e" , lastModified = testTime } where testTime = read @UTCTime "2017-07-13 18:40:46 +0000" copyObject :: IO () copyObject = do sp <- testSpaces copyObjectDate <- iso8601ParseM @_ @UTCTime "2017-07-10T20:22:54.167Z" copyObjectResp <- withSourceFile "./tests/data/copy-object.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @CopyObject raw) sp hspec . describe "Network.DO.Spaces.Actions.CopyObject" $ do it "parses the response correctly" $ copyObjectResp `shouldBe` CopyObjectResponse { lastModified = copyObjectDate , etag = "7967bfe102f83fb5fc7e5a02bf05e8fc" } it "ensures the correct metadataDirective is provided" $ runSpacesT (buildRequest badReq) sp `shouldThrow` (InvalidRequest msg ==) where badReq = CopyObject { srcBucket , srcObject , destBucket = srcBucket , destObject = srcObject , metadataDirective = Copy , acl = Nothing } srcObject = Object "some-object" srcBucket = Bucket "some-bucket" msg = mconcat [ "CopyObject: " , "Object cannot be copied to itself unless " , "REPLACE directive is specified" ] beginMultipartResponse :: IO () beginMultipartResponse = do sp <- testSpaces multipart <- withSourceFile "./tests/data/begin-multipart.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @BeginMultipart raw) sp hspec . describe "Network.DO.Spaces.Actions.BeginMultipart" . it "parses the response correctly" $ multipart `shouldBe` BeginMultipartResponse { session = MultipartSession { bucket = Bucket "static-images" , object = Object "multipart-file.tar.gz" , uploadID = "2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh" } } listPartsResponse :: IO () listPartsResponse = do sp <- testSpaces d <- iso8601ParseM @_ @UTCTime "2017-08-14T18:45:01.601Z" listParts <- withSourceFile "./tests/data/list-parts.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @ListParts raw) sp hspec . describe "Network.DO.Spaces.Actions.ListParts" . it "parses the response correctly" $ listParts `shouldBe` listPartsResp d where listPartsResp lastModified = ListPartsResponse { bucket = Bucket "my-new-bucket" , object = Object "multipart-file.tar.gz" , uploadID = "2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh" , partMarker = 0 , nextPartMarker = 1 , maxParts = 1000 , isTruncated = False , parts = S.fromList [ Part { partNumber = 1 , etag = "d8d3ed3a4de016917a814a2cf5acad3c" , size = 5242880 , lastModified } , Part { partNumber = 2 , etag = "adf5feafc0fe4632008d5cb30beb1c49" , size = 5242880 , lastModified } ] } bucketName :: IO () bucketName = hspec . describe "Network.DO.Spaces.Types.mkBucket" $ do it "rejects invalid Bucket names" . for_ [ "doc_example_bucket" , "doc-example-bucket-" , "do" , T.replicate 64 "d" ] $ \name -> mkBucket name `shouldThrow` matchErr it "accepts valid Bucket names" . for_ [ "docexamplebucket1" , "log-delivery-march-2020" , "my-hosted-content" ] $ \name -> mkBucket name `shouldSatisfy` isJust where matchErr (OtherError _) = True matchErr _ = False bucketCORS :: IO () bucketCORS = do sp <- testSpaces cors <- withSourceFile "./tests/data/get-bucket-cors.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @GetBucketCORS raw) sp hspec . describe "Network.DO.Spaces.Actions.GetBucketCORS" . it "parses the response correctly" $ (cors ^. #rules & toList) `shouldBe` [ CORSRule { allowedOrigin = "http://example.com" , allowedMethods = [ PUT, DELETE, POST ] , allowedHeaders = [ "*" ] } , CORSRule { allowedOrigin = "*" , allowedMethods = [ GET ] , allowedHeaders = mempty } ] bucketACLs :: IO () bucketACLs = do sp <- testSpaces acls <- withSourceFile "./tests/data/get-bucket-acls.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @GetBucketACLs raw) sp hspec . describe "Network.DO.Spaces.Actions.GetBucketACLs" . it "parses the response correctly" $ (acls ^. #accessControlList) `shouldBe` [ Grant { permission = ReadOnly, grantee = Group } , Grant { permission = FullControl , grantee = CanonicalUser (Owner (OwnerID 6174283) (OwnerID 6174283)) } ] bucketLifecycle :: IO () bucketLifecycle = do sp <- testSpaces rs <- withSourceFile "./tests/data/get-bucket-lifecycle.xml" $ \body -> do let headers = mempty raw = RawResponse { .. } runSpacesT (consumeResponse @_ @GetBucketLifecycle raw) sp hspec . describe "Network.DO.Spaces.Actions.GetBucketACLs" . it "parses the response correctly" $ (rs ^. #rules) `shouldBe` [ LifecycleRule { id' = LifecycleID "Expire old logs" , enabled = True , expiration = Just (AfterDays 90) , prefix = Just "logs/" , abortIncomplete = Nothing } , LifecycleRule { id' = LifecycleID "Remove uncompleted uploads" , enabled = True , abortIncomplete = Just 1 , expiration = Nothing , prefix = Nothing } ]