Switch to base64-bytestring

base64 with ghc 8.6.5 on arm produces incorrect output

gbs-downloader.cabal

@@ -90,7 +90,7 @@ library
     , aeson
     , base
     , base32
-    , base64
+    , base64-bytestring
     , binary
     , bytestring
     , connection

src/Tahoe/Download.hs

@@ -14,12 +14,12 @@ module Tahoe.Download (
     announcementToStorageServer,
 ) where
 
-import Control.Exception (throwIO)
+import Control.Exception (SomeException, throwIO, try)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Data.Binary (Word16, decodeOrFail)
 import qualified Data.ByteString as B
 import Data.ByteString.Base32 (encodeBase32Unpadded)
-import Data.ByteString.Base64 (encodeBase64)
+import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Lazy as LB
 import Data.Either (isRight, partitionEithers)
 import Data.List (foldl')
@@ -43,6 +43,9 @@ import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
 import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
 import Text.Read (readMaybe)
 
+print' :: MonadIO m => String -> m ()
+print' = liftIO . print
+
 {- | An unrecoverable problem arose while attempting to download and/or read
  some application data.
 -}
@@ -105,13 +108,21 @@ download ::
     -- application data.
     m (Either DownloadError LB.ByteString)
 download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
+    print' ("Going to download: " <> show storageIndex)
     locationE <- locateShares servers lookupServer storageIndex required
+    print' "Finished locating shares"
     case locationE of
-        Left err -> pure $ Left err
+        Left err -> do
+          print' "Got an error locating shares"
+          pure $ Left err
         Right discovered -> do
+            print' "Found some shares, fetching them"
             -- XXX note shares can contain failures
             shares <- fetchShares storageIndex discovered
-            decodeShares cap shares
+            print' "Fetched the shares, decoding them"
+            s <- decodeShares cap shares
+            print' "Decoded them"
+            pure s
 
 -- | Find out which servers claim to have shares related to a given storage index.
 locateShares ::
@@ -132,6 +143,7 @@ locateShares servers lookupServer storageIndex required =
     case Map.toList servers of
         [] -> pure . Left $ NoConfiguredServers
         serverList -> do
+            print' "Discovering shares"
             -- Ask each server for all shares it has.
             ( problems :: [DiscoverError]
                 , discovered :: [(StorageServer, Set.Set ShareNum)]
@@ -154,8 +166,11 @@ fetchShares ::
     -- | The guide to where shares are placed.
     [(StorageServer, Set.Set ShareNum)] ->
     m [(ShareNum, Either DownloadError LB.ByteString)]
-fetchShares storageIndex discovered =
-    mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+fetchShares storageIndex discovered = do
+    print' "Fetching shares"
+    s <- mapM (uncurry $ downloadShare storageIndex) (Map.toList sharemap)
+    print' "Fetched shares"
+    pure s
   where
     sharemap = makeShareMap discovered
 
@@ -177,7 +192,9 @@ decodeShares cap@Reader{readKey, verifier = Verifier{..}} shares =
      in if length onlyDecoded < fromIntegral required
             then pure $ Left NotEnoughDecodedShares{notEnoughDecodedSharesNeeded = fromIntegral required, notEnoughDecodedSharesFound = length onlyDecoded}
             else do
+                print' "Interpreted shares, decoding them"
                 ciphertext <- liftIO $ Tahoe.CHK.decode cap onlyDecoded
+                print' "Decoded them, might decrypt them"
                 case ciphertext of
                     Nothing -> pure $ Left ShareDecodingFailed
                     Just ct ->
@@ -199,11 +216,16 @@ discoverShares ::
     (StorageServerID, StorageServerAnnouncement) ->
     m (Either DiscoverError (StorageServer, Set.Set ShareNum))
 discoverShares lookupServer storageIndex (_sid, sann) = do
+    print' "Looking up server from announcement"
     server <- lookupServer sann
+    print' "Looked it up"
     case server of
         Left e -> pure . Left . StorageServerUnreachable $ e
-        Right ss@StorageServer{storageServerGetBuckets} ->
-            liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
+        Right ss@StorageServer{storageServerGetBuckets} -> do
+            print' $ "Getting buckets for " <> show storageIndex
+            r <- liftIO $ Right . (ss,) <$> storageServerGetBuckets storageIndex
+            print' $ "Got them " <> (show . fmap snd) r
+            pure r
 
 {- | Invert the mapping implied by the list of two tuples so that the servers
  that claim to have a certain share can easily be retrieved.
@@ -232,7 +254,9 @@ downloadShare storageIndex shareNum (s : _) = do
     -- TODO: There might be more servers.  We could try them if this fails.
     -- On the other hand, we might get bytes but we don't verify them here so
     -- we might also need retry logic up a level or two from here.
+    print' $ "Going to download " <> show storageIndex <> " " <> show shareNum
     shareBytes <- liftIO $ storageServerRead s storageIndex shareNum
+    print' "Downloaded it"
     pure (shareNum, Right $ LB.fromStrict shareBytes)
 
 data LookupError
@@ -258,7 +282,9 @@ makeServer
         case readMaybe port of
             Nothing -> pure . Left . PortParseError $ port
             Just realPort -> do
+                print' "Going to make a GBS manager"
                 manager <- liftIO $ newGBSManager tubid swissnum
+                print' "Made it"
 
                 let baseUrl = https host realPort
                     env = mkClientEnv manager baseUrl
@@ -270,17 +296,30 @@ makeServer
 
                     storageServerRead storageIndex shareNum = do
                         let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+                        print' "Going to read from a server"
                         res <- runClientM clientm env
+                        print' "Did it"
                         case res of
-                            Left err -> throwIO err
+                            Left err -> do
+                              print' "Going to throw a damn IO error"
+                              throwIO err
                             Right bs -> pure bs
 
                     storageServerGetBuckets storageIndex = do
                         let clientm = getImmutableShareNumbers (toBase32 storageIndex)
-                        res <- runClientM clientm env
-                        case res of
-                            Left err -> throwIO err
-                            Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
+                        print' "Going to get share numbers"
+                        r <- try $ runClientM clientm env
+                        case r of
+                          Left (err :: SomeException) -> do
+                            print' $ "A PROBLEM ARISES " <> show err
+                            pure mempty
+                          Right res -> do
+                            print' "Got the share numbers"
+                            case res of
+                                Left err -> do
+                                  print' "Going to throw another IO error!!"
+                                  throwIO err
+                                Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
                 pure . Right $ StorageServer{..}
 makeServer _ = pure . Left $ AnnouncementStructureUnmatched
 
@@ -299,11 +338,14 @@ managerSettingsForService _ swissnum =
   where
     tlsSettings = TLSSettingsSimple True True True
     sockSettings = Nothing
+    swissnumBytes = encodeUtf8 swissnum
+    swissnumBase64 = Base64.encode swissnumBytes
+    headerCompleteBytes = B.concat ["Tahoe-LAFS ", swissnumBase64]
     authorize req =
         req
             { requestHeaders =
                 ( "Authorization"
-                , encodeUtf8 $ T.concat ["Tahoe-LAFS ", encodeBase64 . encodeUtf8 $ swissnum]
+                , headerCompleteBytes
                 ) :
                 requestHeaders req
             }