wip some steps towards StorageServer/StorageClient refactoring

gbs-downloader.cabal

@@ -80,6 +80,7 @@ library
   -- Modules exported by the library.
   exposed-modules:
     Tahoe.Announcement
+    Tahoe.Client
     Tahoe.Download
 
   -- Modules included in this library but not exported.

src/Tahoe/Client.hs

+module Tahoe.Client where
+
+import Control.Exception (SomeException (SomeException))
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Network.HTTP.Client (Manager, ManagerSettings (managerModifyRequest), Request (requestHeaders))
+import Network.URI (URI (URI, uriAuthority, uriFragment, uriPath, uriScheme), URIAuth (URIAuth, uriPort, uriRegName, uriUserInfo))
+import Servant.Client (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme))
+import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
+import TahoeLAFS.Storage.API (CBORSet (CBORSet), ShareNumber (ShareNumber))
+import Text.Read (readMaybe)
+
+-- | There was a problem while trying to look up a server from its announcement.
+data LookupError
+    = -- | The server's announced URI was unparseable.
+      URIParseError StorageServerAnnouncement
+    | -- | The port integer in the server's URI was unparseable.
+      PortParseError String
+    | -- | The structure of the server's URI was unparseable.
+      AnnouncementStructureUnmatched
+    deriving (Eq, Ord, Show)
+
+data StorageClient = StorageClient
+    { storageClientManager :: Manager
+    , storageClientBaseUrl :: BaseUrl
+    }
+
+makeGBSManager :: MonadIO m => URI -> m (Either LookupError Manager)
+makeGBSManager
+    URI
+        { uriScheme = "pb:"
+        , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)}
+        , uriPath = ('/' : swissnum)
+        , uriFragment = "" -- It's a fURL, not a NURL, so there's no fragment.
+        } =
+        case readMaybe port of
+            Nothing -> pure . Left . PortParseError $ port
+            Just realPort -> do
+                manager <- newGBSManager tubid swissnum
+                wrapGreatBlackSwamp
+
+-- | Make a manager suitable for use with a Great Black Swamp server.
+newGBSManager ::
+    MonadIO m =>
+    [Char] ->
+    String ->
+    m Manager
+newGBSManager tubid swissnum =
+    newTlsManagerWith $
+        managerSettingsForService
+            (T.pack . init $ tubid)
+            (T.pack swissnum)
+
+--                 pure . Right $ wrapGreatBlackSwamp manager host realPort
+-- makeServer _ = pure . Left $ AnnouncementStructureUnmatched
+
+-- Parameterize readImmutableShare and getImmutableShareNumbers to
+-- wrapGreatBlackSwamp, then use it for both mutables and immutables.  Then
+-- use the same download function for both!
+
+{- | Create a StorageClient that will speak Great Black Swamp using the given
+ manager to the server at the given host/port.
+-}
+wrapGreatBlackSwamp :: [Char] -> Int -> Manager -> StorageServer
+wrapGreatBlackSwamp host realPort manager =
+    StorageClient{..}
+  where
+    baseUrl = https host realPort
+    env = mkClientEnv manager baseUrl
+    toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
+
+    storageServerID = undefined
+
+    storageServerWrite = undefined
+
+    storageServerRead storageIndex shareNum = do
+        let clientm = readImmutableShare (toBase32 storageIndex) (ShareNumber $ fromIntegral shareNum) Nothing
+        res <- runClientM clientm env
+        case res of
+            Left err -> throwIO err
+            Right bs -> pure bs
+
+    storageServerGetBuckets storageIndex = do
+        let clientm = getImmutableShareNumbers (toBase32 storageIndex)
+        print' "Going to get share numbers"
+        r <- try $ runClientM clientm env
+        case r of
+            Left (err :: SomeException) -> do
+                pure mempty
+            Right res -> do
+                case res of
+                    Left err -> throwIO err
+                    Right (CBORSet s) -> pure $ Set.map (\(ShareNumber i) -> fromIntegral i) s -- XXX fromIntegral aaaaaaaa!!
+
+-- | Make an HTTPS URL.
+https :: String -> Int -> BaseUrl
+https host port =
+    BaseUrl
+        { baseUrlScheme = Https
+        , baseUrlHost = host
+        , baseUrlPort = port
+        , baseUrlPath = ""
+        }
+
+{- | Make an HTTPS manager for the given SPKI hash and swissnum.
+
+ The SPKI hash is _not_ used to authenticate the server!  See
+ https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
+-}
+managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
+managerSettingsForService _ swissnum =
+    (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}
+  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"
+                , headerCompleteBytes
+                ) :
+                requestHeaders req
+            }
+
+{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
+ a Great Black Swamp server.
+-}
+announcementToStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
+announcementToStorageServer ann =
+    case greatBlackSwampURIs ann of
+        Nothing -> pure . Left . URIParseError $ ann
+        Just uri -> makeServer uri

src/Tahoe/Download.hs

@@ -36,8 +36,8 @@ import Tahoe.Announcement (StorageServerAnnouncement, greatBlackSwampURIs)
 import qualified Tahoe.CHK
 import Tahoe.CHK.Capability (Reader (..), Verifier (..))
 import qualified Tahoe.CHK.Encrypt
-import Tahoe.CHK.Server (StorageServer (..), StorageServerID)
 import Tahoe.CHK.Types (ShareNum, StorageIndex)
+import Tahoe.Client (StorageClient (..), StorageServerID)
 import qualified Tahoe.SDMF as SDMF
 import TahoeLAFS.Storage.API (CBORSet (..), ShareNumber (ShareNumber))
 import TahoeLAFS.Storage.Client (getImmutableShareNumbers, readImmutableShare)
@@ -48,7 +48,7 @@ print' :: MonadIO m => String -> m ()
 print' = const $ pure ()
 
 -- | Partially describe one share download.
-type DownloadTask = (ShareNum, StorageServer)
+type DownloadTask = (ShareNum, StorageClient)
 
 -- | A downloaded share
 type Share = (ShareNum, LB.ByteString)
@@ -102,25 +102,22 @@ data DiscoverError
 -}
 type LookupServer m = StorageServerAnnouncement -> m (Either LookupError StorageServer)
 
-downloadMutable :: MonadIO m => Map.Map StorageServerID StorageServerAnnouncement -> SDMF.Reader -> LookupServer m -> m (Either DownloadError LB.ByteString)
-downloadMutable = undefined
-
 {- | Recover the application data associated with a given capability from the
  given servers, if possible.
 -}
 download ::
-    MonadIO m =>
+    (ReadCapability r, MonadIO m) =>
     -- | Information about the servers from which to consider downloading shares
     -- representing the application data.
     Map.Map StorageServerID StorageServerAnnouncement ->
     -- | The read capability for the application data.
-    Reader ->
+    r ->
     -- | Get functions for interacting with a server given its URL.
     LookupServer m ->
     -- | Either a description of how the recovery failed or the recovered
     -- application data.
     m (Either DownloadError LB.ByteString)
-download servers cap@Reader{verifier = Verifier{..}} lookupServer = do
+download servers cap lookupServer = do
     print' ("Going to download: " <> show storageIndex)
     locationE <- locateShares servers lookupServer storageIndex required
     print' "Finished locating shares"
@@ -263,130 +260,6 @@ downloadShare storageIndex (shareNum, s) = do
     print' "Downloaded it"
     pure (shareNum, LB.fromStrict <$> massaged)
 
--- | There was a problem while trying to look up a server from its announcement.
-data LookupError
-    = -- | The server's announced URI was unparseable.
-      URIParseError StorageServerAnnouncement
-    | -- | The port integer in the server's URI was unparseable.
-      PortParseError String
-    | -- | The structure of the server's URI was unparseable.
-      AnnouncementStructureUnmatched
-    deriving (Eq, Ord, Show)
-
-{- | Interpret the location in an announcement as a Tahoe-LAFS fURL pointed at
- a Great Black Swamp server.
--}
-announcementToStorageServer :: MonadIO m => StorageServerAnnouncement -> m (Either LookupError StorageServer)
-announcementToStorageServer ann =
-    case greatBlackSwampURIs ann of
-        Nothing -> pure . Left . URIParseError $ ann
-        Just uri -> makeServer uri
-
-makeServer :: MonadIO m => URI -> m (Either LookupError StorageServer)
-makeServer
-    URI
-        { uriScheme = "pb:"
-        , uriAuthority = Just URIAuth{uriUserInfo = tubid, uriRegName = host, uriPort = (':' : port)}
-        , uriPath = ('/' : swissnum)
-        , uriFragment = "" -- It's a fURL, not a NURL, so there's no fragment.
-        } =
-        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"
-
-                pure . Right $ wrapGreatBlackSwamp manager host realPort
-makeServer _ = pure . Left $ AnnouncementStructureUnmatched
-
--- Parameterize readImmutableShare and getImmutableShareNumbers to
--- wrapGreatBlackSwamp, then use it for both mutables and immutables.  Then
--- use the same download function for both!
-
-{- | Create a StorageServer that will speak Great Black Swamp using the given
- manager to the server at the given host/port.
--}
-wrapGreatBlackSwamp :: Manager -> [Char] -> Int -> StorageServer
-wrapGreatBlackSwamp manager host realPort =
-    StorageServer{..}
-  where
-    baseUrl = https host realPort
-    env = mkClientEnv manager baseUrl
-    toBase32 = T.unpack . T.toLower . encodeBase32Unpadded
-
-    storageServerID = undefined
-
-    storageServerWrite = undefined
-
-    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 -> do
-                print' "Going to throw a damn IO error"
-                throwIO err
-            Right bs -> pure bs
-
-    storageServerGetBuckets storageIndex = do
-        let clientm = getImmutableShareNumbers (toBase32 storageIndex)
-        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!!
-
--- | Make an HTTPS URL.
-https :: String -> Int -> BaseUrl
-https host port =
-    BaseUrl
-        { baseUrlScheme = Https
-        , baseUrlHost = host
-        , baseUrlPort = port
-        , baseUrlPath = ""
-        }
-
-{- | Make an HTTPS manager for the given SPKI hash and swissnum.
-
- The SPKI hash is _not_ used to authenticate the server!  See
- https://whetstone.private.storage/privatestorage/tahoe-great-black-swamp/-/issues/27
--}
-managerSettingsForService :: T.Text -> T.Text -> ManagerSettings
-managerSettingsForService _ swissnum =
-    (mkManagerSettings tlsSettings sockSettings){managerModifyRequest = pure . authorize}
-  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"
-                , headerCompleteBytes
-                ) :
-                requestHeaders req
-            }
-
--- | Make a manager suitable for use with a Great Black Swamp server.
-newGBSManager ::
-    MonadIO m =>
-    [Char] ->
-    String ->
-    m Manager
-newGBSManager tubid swissnum =
-    newTlsManagerWith $
-        managerSettingsForService
-            (T.pack . init $ tubid)
-            (T.pack swissnum)
+class ReadCapability r s | r -> s where
+    storageIndex :: r -> StorageIndex
+    decode :: LB.ByteString -> Maybe s