From 9484710e3e9ab73d180c07d25068b5bc02bbbc47 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Tue, 14 Nov 2023 14:38:12 -0500
Subject: [PATCH] Adapt the executables to work with ExceptT
---
app/Main.hs | 3 ++-
download-sdmf/Main.hs | 57 +++++++++++++++++++++++--------------------
gbs-downloader.cabal | 2 ++
list-dircap/Main.hs | 3 ++-
4 files changed, 36 insertions(+), 29 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index 157e018..95edf3f 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,6 @@
module Main where
+import Control.Monad.Except (runExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
@@ -22,7 +23,7 @@ main = do
let Right (CHKReader cap) = parse pCapability "<argv>" (T.pack readCap)
-- Download & decode the shares
- result <- download announcements cap announcementToImmutableStorageServer
+ result <- runExceptT $ download announcements cap announcementToImmutableStorageServer
-- Show the result
putStrLn "Your result:"
diff --git a/download-sdmf/Main.hs b/download-sdmf/Main.hs
index a42c2f1..b6e3f8b 100644
--- a/download-sdmf/Main.hs
+++ b/download-sdmf/Main.hs
@@ -2,38 +2,41 @@
module Main where
-import Control.Monad.Except (runExceptT)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as BL
+import Control.Monad.Except (ExceptT (ExceptT), MonadTrans (lift), runExceptT, withExceptT)
+import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text as T
-import Data.Yaml (decodeEither')
+import Data.Yaml (decodeFileEither)
import System.Environment (getArgs)
import Tahoe.Announcement (Announcements (..))
import Tahoe.Download (announcementToMutableStorageServer, download)
-import Tahoe.SDMF (SDMF (..), pCapability, writerReader)
+import Tahoe.SDMF (Reader, SDMF (..), pCapability, writerReader)
import Text.Megaparsec (parse)
+newtype Failed = Failed String
+
+instance Show Failed where
+ show (Failed s) = s
+
main :: IO ()
-main = do
- [announcementPath, readCap] <- getArgs
- -- Load server announcements
- announcementsBytes <- B.readFile announcementPath
- let Right (Announcements announcements) = decodeEither' announcementsBytes
-
- -- Accept & parse read capability
- case parse pCapability "<argv>" (T.pack readCap) of
- Left e -> print $ "Failed to parse cap: " <> show e
- Right (SDMFVerifier _) -> C8.putStrLn "Nothing currently implemented for verifier caps."
- Right (SDMFWriter rwcap) -> go announcements (writerReader rwcap)
- Right (SDMFReader rocap) -> go announcements rocap
+main =
+ either (putStrLn . ("Failed: " <>) . show) (BL.putStrLn . BL.append "Your result: ")
+ =<< ( runExceptT $
+ do
+ [announcementPath, readCap] <- lift getArgs
+ -- Parse read capability
+ cap <- mightFail "Failed to parse capability: " . pure . parse pCapability "<argv>" . T.pack $ readCap
+
+ -- Load server announcements
+ announcements <- mightFail "Failed to parse announcements: " $ decodeFileEither announcementPath
+
+ case cap of
+ (SDMFVerifier _) -> ExceptT . pure . Left . Failed $ "Nothing implemented for verifier capabilities."
+ (SDMFWriter rwcap) -> go announcements (writerReader rwcap)
+ (SDMFReader rocap) -> go announcements rocap
+ )
where
- go announcements cap = do
- -- Download & decode the shares
- result <- runExceptT $ download announcements cap announcementToMutableStorageServer
-
- -- Show the result
- liftIO $ do
- putStrLn "Your result:"
- either print (C8.putStrLn . BL.toStrict) result
+ go :: Announcements -> Reader -> ExceptT Failed IO BL.ByteString
+ go (Announcements announcements) cap = withExceptT (Failed . ("Failed download: " <>) . show) $ download announcements cap announcementToMutableStorageServer
+
+mightFail :: (Functor m, Show a1) => String -> m (Either a1 a2) -> ExceptT Failed m a2
+mightFail s = withExceptT (Failed . (s <>) . show) . ExceptT
diff --git a/gbs-downloader.cabal b/gbs-downloader.cabal
index edf629c..eebb17b 100644
--- a/gbs-downloader.cabal
+++ b/gbs-downloader.cabal
@@ -158,6 +158,7 @@ executable download-chk
, containers >=0.6.0.1 && <0.7
, gbs-downloader
, megaparsec >=8.0 && <9.3
+ , mtl >=2.2.2 && <2.4
, tahoe-chk >=0.2 && <0.3
, text >=1.2.3.1 && <1.3
, yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12
@@ -202,6 +203,7 @@ executable list-dircap
, containers >=0.6.0.1 && <0.7
, gbs-downloader
, megaparsec >=8.0 && <9.3
+ , mtl >=2.2.2 && <2.4
, tahoe-chk >=0.2 && <0.3
, tahoe-directory >=0.1 && <0.2
, tahoe-ssk >=0.3 && <0.4
diff --git a/list-dircap/Main.hs b/list-dircap/Main.hs
index c0adc74..a050462 100644
--- a/list-dircap/Main.hs
+++ b/list-dircap/Main.hs
@@ -10,6 +10,7 @@ import Tahoe.Announcement (Announcements (..))
import qualified Tahoe.Directory as TD
import Text.Megaparsec (parse)
+import Control.Monad.Except (runExceptT)
import Tahoe.Download (announcementToImmutableStorageServer, announcementToMutableStorageServer, downloadDirectory)
main :: IO ()
@@ -30,7 +31,7 @@ main = do
where
go announcements cap lookupServer = do
-- Download & decode the shares
- result <- downloadDirectory announcements cap lookupServer
+ result <- runExceptT $ downloadDirectory announcements cap lookupServer
-- Show the result
putStrLn "Your result:"
--
GitLab