From 013529513af62e14c2bfc0eb4f699281cdd94f84 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 22 Aug 2016 13:47:23 -0400
Subject: wire up client to Storage.Network

---
 Storage/Network.hs | 43 ++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 38 insertions(+), 5 deletions(-)

(limited to 'Storage')

diff --git a/Storage/Network.hs b/Storage/Network.hs
index 0b6ff49..ec00cf8 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -9,9 +9,20 @@ module Storage.Network (Server(..), networkServers, networkStorage) where
 
 import Types
 import Types.Storage
+import HTTP
 import HTTP.Client
+import Servant.Client
+import Network.Wai.Handler.Warp (Port)
+import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
 
-newtype Server = Server { serverName :: String }
+data Server = Server
+	{ serverName :: String
+	, serverPort :: Port
+	}
+
+serverUrl :: Server -> BaseUrl
+serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) ""
 
 networkServers :: IO [Server]
 networkServers = return [] -- none yet
@@ -26,10 +37,14 @@ networkStorage server = Storage
 	}
 
 store :: Server -> StorableObjectIdent -> Share -> IO StoreResult
-store _server _i _s = return $ StoreFailure "network storage not implemented yet"
+store srv i (Share _n o) = 
+	serverRequest srv StoreFailure id $ \pow ->
+		putObject i pow o
 
 retrieve :: Server -> ShareNum -> StorableObjectIdent -> IO RetrieveResult
-retrieve _server _n _i = return $ RetrieveFailure "network storage not implemented yet"
+retrieve srv n i = 
+	serverRequest srv RetrieveFailure (RetrieveSuccess . Share n) $
+		getObject i
 
 -- | Servers should automatically obscure, so do nothing.
 -- (Could upload chaff.)
@@ -37,8 +52,26 @@ obscure :: Server -> IO ObscureResult
 obscure _ = return ObscureSuccess
 
 count :: Server -> IO CountResult
-count _server = return $ CountFailure "network storage not implemented yet"
+count srv = serverRequest srv CountFailure id countObjects
 
 -- | Not needed for servers.
 move :: Server -> Storage -> IO ()
-move _ _ = return ()
+move _ _ = error "move is not implemented for servers"
+
+serverRequest
+	:: Server
+	-> (String -> a)
+	-> (r -> a)
+	-> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (ProofOfWorkRequirement r))
+	-> IO a
+serverRequest srv onerr onsuccess a =
+	go Nothing =<< newManager defaultManagerSettings
+  where
+	url = serverUrl srv
+	go pow manager = do
+		res <- runExceptT $ a pow manager url
+		case res of
+			Left err -> return $ onerr $ 
+				"server failure: " ++ show err
+			Right (Result r) -> return $ onsuccess r
+			Right needpow -> error "NEEDPOW" -- loop with pow
-- 
cgit v1.2.3