From e5a5d6f30fb4451918efba5b72787cbc7632aecf Mon Sep 17 00:00:00 2001 From: Brian Ginsburg <7957636+bgins@users.noreply.github.com> Date: Fri, 15 Jul 2022 10:10:19 -0700 Subject: [PATCH] Add Append Endpoint (#595) * Bump server version to 2.20.0.0 * Add append endpoint to Web API * Add DirectoryName and FileName modules * Append endpoint DAG surgery (#608) * Implement add file to app endpoint * Add some notes to the readme * Rewrite IPFS files stats to handle more than CIDs * Use multipart upload instead of octetstream * Retrieve domain and update DNSLink * Use domain name from ENV * Append to uploads directory * Return CID of appended file * Validate UCAN resource (#621) Co-authored-by: Steven Vandevelde --- .../Fission/CLI/Handler/App/Delegate.hs | 35 ++-- .../Fission/CLI/Handler/Error/Types.hs | 2 + fission-cli/library/Fission/CLI/Remote.hs | 6 +- .../Fission/FileSystem/DirectoryName.hs | 3 + .../Fission/FileSystem/DirectoryName/Error.hs | 13 ++ .../Fission/FileSystem/DirectoryName/Types.hs | 44 +++++ .../library/Fission/FileSystem/FileName.hs | 3 + .../Fission/FileSystem/FileName/Error.hs | 13 ++ .../Fission/FileSystem/FileName/Types.hs | 45 ++++++ .../Web/Auth/Token/UCAN/Resource/Types.hs | 3 +- .../library/Fission/Web/API/Append/Types.hs | 27 ++++ .../library/Fission/Web/API/Remote.hs | 12 ++ .../library/Fission/Web/API/Types.hs | 10 +- fission-web-server/README.md | 10 +- .../library/Fission/Web/Server.hs | 14 +- .../Fission/Web/Server/App/Modifier.hs | 144 ++++++++++++++++- .../Fission/Web/Server/App/Modifier/Class.hs | 36 ++++- .../library/Fission/Web/Server/Error/Class.hs | 7 + .../Fission/Web/Server/Handler/Append.hs | 40 +++++ .../library/Fission/Web/Server/Types.hs | 8 +- fission-web-server/package.yaml | 2 +- ipfs/library/Network/IPFS/Client.hs | 48 ++++-- ipfs/library/Network/IPFS/Client/Files.hs | 13 ++ .../Network/IPFS/Client/Files/Copy/Types.hs | 12 ++ .../Network/IPFS/Client/Files/Remove/Types.hs | 12 ++ .../IPFS/Client/Files/Statistics/Types.hs | 23 +++ .../IPFS/Client/Files/Write/Form/Types.hs | 25 +++ .../Network/IPFS/Client/Files/Write/Types.hs | 20 +++ ipfs/library/Network/IPFS/Error.hs | 6 +- ipfs/library/Network/IPFS/Files.hs | 153 ++++++++++++++++++ ipfs/library/Network/IPFS/Files/Error.hs | 57 +++++++ ipfs/library/Network/IPFS/Remote/Class.hs | 47 +++++- ipfs/package.yaml | 1 + 33 files changed, 842 insertions(+), 52 deletions(-) create mode 100644 fission-core/library/Fission/FileSystem/DirectoryName.hs create mode 100644 fission-core/library/Fission/FileSystem/DirectoryName/Error.hs create mode 100644 fission-core/library/Fission/FileSystem/DirectoryName/Types.hs create mode 100644 fission-core/library/Fission/FileSystem/FileName.hs create mode 100644 fission-core/library/Fission/FileSystem/FileName/Error.hs create mode 100644 fission-core/library/Fission/FileSystem/FileName/Types.hs create mode 100644 fission-web-api/library/Fission/Web/API/Append/Types.hs create mode 100644 fission-web-server/library/Fission/Web/Server/Handler/Append.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files/Copy/Types.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files/Remove/Types.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files/Statistics/Types.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files/Write/Form/Types.hs create mode 100644 ipfs/library/Network/IPFS/Client/Files/Write/Types.hs create mode 100644 ipfs/library/Network/IPFS/Files.hs create mode 100644 ipfs/library/Network/IPFS/Files/Error.hs diff --git a/fission-cli/library/Fission/CLI/Handler/App/Delegate.hs b/fission-cli/library/Fission/CLI/Handler/App/Delegate.hs index 0ff8b61a9..5cfac511b 100644 --- a/fission-cli/library/Fission/CLI/Handler/App/Delegate.hs +++ b/fission-cli/library/Fission/CLI/Handler/App/Delegate.hs @@ -62,7 +62,7 @@ import Web.UCAN.Validation (check) -- | Delegate capabilities to a DID delegate :: ( MonadIO m - , MonadLogger m + , MonadLogger m , MonadRandom m , MonadTime m @@ -109,12 +109,13 @@ delegate appName potency audienceDid lifetimeInSeconds (QuietFlag quiet) = do raise $ ParseError @DID Right did -> do - remoteUrl <- getRemoteURL - logDebug $ "Remote URL: " <> show remoteUrl + appUrl <- getAppDomain + + logDebug $ "Application domain: " <> show appUrl let - URL { domainName } = remoteUrl - url = URL { domainName, subdomain = Just $ Subdomain appName} + URL { domainName } = appUrl + url = URL { domainName, subdomain = Just $ Subdomain appName } appResource = Subset $ FissionApp (Subset url) ptc <- case potency of @@ -132,7 +133,7 @@ delegate appName potency audienceDid lifetimeInSeconds (QuietFlag quiet) = do Right (signingKey, proof) -> do now <- getCurrentTime - let + let ucan = UCAN.delegateWithLifetime did signingKey appResource ptc proof lifetimeInSeconds now encodedUcan = encodeUcan ucan @@ -147,7 +148,7 @@ delegate appName potency audienceDid lifetimeInSeconds (QuietFlag quiet) = do getCredentialsFor :: ( MonadIO m - , MonadLogger m + , MonadLogger m , MonadRandom m , MonadTime m @@ -175,8 +176,8 @@ getCredentialsFor :: , Contains (Errors m) (Errors m) , Show (OpenUnion (Errors m)) - ) - => Text + ) + => Text -> Scope Resource -> Potency -> m (SecretKey SigningKey, Proof) @@ -253,7 +254,7 @@ checkProofEnvVar :: -> DID -> Scope Resource -> Potency - -> m UCAN + -> m UCAN checkProofEnvVar token did resource potency = do let tokenBS = Char8.pack $ wrapIn "\"" token @@ -261,7 +262,7 @@ checkProofEnvVar token did resource potency = do Left err -> do CLI.Error.put err "Unable to parse UCAN set in FISSION_APP_UCAN environment variable" raise $ ParseError @UCAN - + Right ucan -> do let rawContent = UCAN.RawContent.contentOf (decodeUtf8Lenient tokenBS) capableUcan <- ensureM $ checkCapability resource potency ucan @@ -293,7 +294,7 @@ checkProofConfig :: -> Text -> Scope Resource -> Potency - -> m Proof + -> m Proof checkProofConfig proof did appName appResource potency = do case proof of UCAN.Types.RootCredential -> do @@ -315,7 +316,7 @@ checkProofConfig proof did appName appResource potency = do ucan <- ensure $ parseToken proofTokenBS capableUcan <- ensureM $ checkCapability appResource potency ucan - ensureM $ check did rawContent capableUcan + ensureM $ check did rawContent capableUcan return proof checkCapability :: @@ -356,9 +357,9 @@ checkCapability requestedResource requestedPotency ucan = do putScopeError return $ Left ScopeOutOfBounds -checkAppRegistration :: +checkAppRegistration :: ( MonadIO m - , MonadLogger m + , MonadLogger m , MonadTime m , MonadWebClient m , ServerDID m @@ -373,8 +374,8 @@ checkAppRegistration :: , Contains (Errors m) (Errors m) , Show (OpenUnion (Errors m)) ) - => Text - -> Proof + => Text + -> Proof -> m (Either (ErrorCase m) Bool) checkAppRegistration appName proof = do attempt (sendAuthedRequest proof appIndex) >>= \case diff --git a/fission-cli/library/Fission/CLI/Handler/Error/Types.hs b/fission-cli/library/Fission/CLI/Handler/Error/Types.hs index 71ee9cc82..3a20a7422 100644 --- a/fission-cli/library/Fission/CLI/Handler/Error/Types.hs +++ b/fission-cli/library/Fission/CLI/Handler/Error/Types.hs @@ -10,6 +10,7 @@ import qualified Crypto.PubKey.RSA.Types as RSA import Network.DNS as DNS import qualified Network.IPFS.Add.Error as IPFS.Add +import qualified Network.IPFS.Files.Error as IPFS.Files import Network.IPFS.CID.Types import qualified Network.IPFS.Process.Error as IPFS.Process import qualified Network.IPFS.Types as IPFS @@ -62,6 +63,7 @@ type Errs , Status Denied -- , IPFS.Add.Error + , IPFS.Files.Error , IPFS.Process.Error , IPFS.UnableToConnect -- diff --git a/fission-cli/library/Fission/CLI/Remote.hs b/fission-cli/library/Fission/CLI/Remote.hs index 255422905..2abcb6301 100644 --- a/fission-cli/library/Fission/CLI/Remote.hs +++ b/fission-cli/library/Fission/CLI/Remote.hs @@ -1,5 +1,6 @@ module Fission.CLI.Remote - ( getRemoteURL + ( getAppDomain + , getRemoteURL , getRemoteBaseUrl , getNameService , getIpfsGateway @@ -17,6 +18,9 @@ import Fission.Web.API.Remote import Fission.CLI.Remote.Class +getAppDomain :: MonadRemote m => m URL +getAppDomain = toAppDomain <$> getRemote + getRemoteBaseUrl :: MonadRemote m => m BaseUrl getRemoteBaseUrl = toBaseUrl <$> getRemote diff --git a/fission-core/library/Fission/FileSystem/DirectoryName.hs b/fission-core/library/Fission/FileSystem/DirectoryName.hs new file mode 100644 index 000000000..21b82e3da --- /dev/null +++ b/fission-core/library/Fission/FileSystem/DirectoryName.hs @@ -0,0 +1,3 @@ +module Fission.FileSystem.DirectoryName (module Fission.FileSystem.DirectoryName.Types) where + +import Fission.FileSystem.DirectoryName.Types diff --git a/fission-core/library/Fission/FileSystem/DirectoryName/Error.hs b/fission-core/library/Fission/FileSystem/DirectoryName/Error.hs new file mode 100644 index 000000000..917622b5a --- /dev/null +++ b/fission-core/library/Fission/FileSystem/DirectoryName/Error.hs @@ -0,0 +1,13 @@ +-- | Directory name errors +module Fission.FileSystem.DirectoryName.Error (Invalid (..)) where + +import Fission.Prelude + +data Invalid = Invalid + deriving ( Show + , Eq + , Exception + ) + +instance Display Invalid where + display Invalid = "Invalid directory name -- must be alphanumeric separated with hyphens and not blocklisted" diff --git a/fission-core/library/Fission/FileSystem/DirectoryName/Types.hs b/fission-core/library/Fission/FileSystem/DirectoryName/Types.hs new file mode 100644 index 000000000..f06c57315 --- /dev/null +++ b/fission-core/library/Fission/FileSystem/DirectoryName/Types.hs @@ -0,0 +1,44 @@ +module Fission.FileSystem.DirectoryName.Types (DirectoryName (..)) where + +import RIO.Text as Text + +import Data.Swagger +import Servant.API + +import Fission.Prelude + +import Fission.URL.Validation + +import Fission.FileSystem.DirectoryName.Error + +newtype DirectoryName = DirectoryName { directoryName :: Text } + deriving ( Generic ) + deriving anyclass ( ToSchema + , ToParamSchema + ) + deriving newtype ( Eq + , Show + , IsString + ) + +mkDirectoryName :: Text -> Either Invalid DirectoryName +mkDirectoryName txt = + if isValid normalized + then Right $ DirectoryName normalized + else Left Invalid + + where + normalized = Text.toLower txt + +instance Arbitrary DirectoryName where + arbitrary = do + txt <- arbitrary + case mkDirectoryName $ Text.filter isURLChar txt of + Left _ -> arbitrary + Right dName -> return dName + +instance FromHttpApiData DirectoryName where + parseUrlPiece = Right . DirectoryName + +instance ToHttpApiData DirectoryName where + toUrlPiece (DirectoryName directoryName) = directoryName diff --git a/fission-core/library/Fission/FileSystem/FileName.hs b/fission-core/library/Fission/FileSystem/FileName.hs new file mode 100644 index 000000000..6421209a8 --- /dev/null +++ b/fission-core/library/Fission/FileSystem/FileName.hs @@ -0,0 +1,3 @@ +module Fission.FileSystem.FileName (module Fission.FileSystem.FileName.Types) where + +import Fission.FileSystem.FileName.Types diff --git a/fission-core/library/Fission/FileSystem/FileName/Error.hs b/fission-core/library/Fission/FileSystem/FileName/Error.hs new file mode 100644 index 000000000..8b2f2072b --- /dev/null +++ b/fission-core/library/Fission/FileSystem/FileName/Error.hs @@ -0,0 +1,13 @@ +-- | File name errors +module Fission.FileSystem.FileName.Error (Invalid (..)) where + +import Fission.Prelude + +data Invalid = Invalid + deriving ( Show + , Eq + , Exception + ) + +instance Display Invalid where + display Invalid = "Invalid file name -- must be alphanumeric separated with hyphens and not blocklisted" diff --git a/fission-core/library/Fission/FileSystem/FileName/Types.hs b/fission-core/library/Fission/FileSystem/FileName/Types.hs new file mode 100644 index 000000000..9b80d7536 --- /dev/null +++ b/fission-core/library/Fission/FileSystem/FileName/Types.hs @@ -0,0 +1,45 @@ +module Fission.FileSystem.FileName.Types (FileName (..)) where + +import RIO.Text as Text + +import Data.Swagger +import Servant.API + +import Fission.Prelude + +import Fission.URL.Validation + +import Fission.FileSystem.FileName.Error + + +newtype FileName = FileName { fileName :: Text } + deriving ( Generic ) + deriving anyclass ( ToSchema + , ToParamSchema + ) + deriving newtype ( Eq + , Show + , IsString + ) + +mkDirectoryName :: Text -> Either Invalid FileName +mkDirectoryName txt = + if isValid normalized + then Right $ FileName normalized + else Left Invalid + + where + normalized = Text.toLower txt + +instance Arbitrary FileName where + arbitrary = do + txt <- arbitrary + case mkDirectoryName $ Text.filter isURLChar txt of + Left _ -> arbitrary + Right dName -> return dName + +instance FromHttpApiData FileName where + parseUrlPiece = Right . FileName + +instance ToHttpApiData FileName where + toUrlPiece (FileName fileName) = fileName \ No newline at end of file diff --git a/fission-core/library/Fission/Web/Auth/Token/UCAN/Resource/Types.hs b/fission-core/library/Fission/Web/Auth/Token/UCAN/Resource/Types.hs index 875eb2653..42622e8b3 100644 --- a/fission-core/library/Fission/Web/Auth/Token/UCAN/Resource/Types.hs +++ b/fission-core/library/Fission/Web/Auth/Token/UCAN/Resource/Types.hs @@ -2,7 +2,8 @@ module Fission.Web.Auth.Token.UCAN.Resource.Types (Resource (..)) where import Fission.Prelude -import Fission.URL +import Fission.URL.DomainName.Types ( DomainName ) +import Fission.URL.Types ( URL ) import Fission.Web.Auth.Token.UCAN.Resource.Scope.Types import qualified Data.Bits as Bits diff --git a/fission-web-api/library/Fission/Web/API/Append/Types.hs b/fission-web-api/library/Fission/Web/API/Append/Types.hs new file mode 100644 index 000000000..a81f3c87d --- /dev/null +++ b/fission-web-api/library/Fission/Web/API/Append/Types.hs @@ -0,0 +1,27 @@ +module Fission.Web.API.Append.Types (RoutesV2 (..)) where + +import Network.IPFS.File.Types as File +import Network.IPFS.CID.Types + +import Fission.Web.API.Prelude + +import qualified Fission.Web.API.Auth.Types as Auth + +import Fission.FileSystem.DirectoryName.Types as DirectoryName +import Fission.FileSystem.FileName.Types as FileName + +newtype RoutesV2 mode = RoutesV2 + { append :: + mode + :- Summary "Append a file" + :> Description "Append a file to an app's public upload directory" + -- + :> Capture "App Name" DirectoryName + :> Capture "File Name" FileName + -- + :> ReqBody '[OctetStream] Serialized + -- + :> Auth.HigherOrder + :> PutAccepted '[JSON] CID + } + deriving Generic \ No newline at end of file diff --git a/fission-web-api/library/Fission/Web/API/Remote.hs b/fission-web-api/library/Fission/Web/API/Remote.hs index a7e248eba..9d03857fe 100644 --- a/fission-web-api/library/Fission/Web/API/Remote.hs +++ b/fission-web-api/library/Fission/Web/API/Remote.hs @@ -1,6 +1,7 @@ module Fission.Web.API.Remote ( Remote (..) , fromText + , toAppDomain , toBaseUrl , toURL , toNameService @@ -51,6 +52,17 @@ fromText txt = custom -> Custom <$> parseBaseUrl (Text.unpack custom) +toAppDomain :: Remote -> URL +toAppDomain = \case + Production -> URL "fission.app" Nothing + Staging -> URL "fissionapp.net" Nothing + LocalDev -> URL "localhost" Nothing + Custom url -> + if Text.isSuffixOf ".test" (textDisplay $ baseUrlHost url) then + URL "fissionapp.test" Nothing + else + URL.fromBaseUrl url + toBaseUrl :: Remote -> BaseUrl toBaseUrl = \case Production -> production diff --git a/fission-web-api/library/Fission/Web/API/Types.hs b/fission-web-api/library/Fission/Web/API/Types.hs index 0bff3da06..4606df9fa 100644 --- a/fission-web-api/library/Fission/Web/API/Types.hs +++ b/fission-web-api/library/Fission/Web/API/Types.hs @@ -14,6 +14,7 @@ import qualified Fission.Pong.Types as Ping import Fission.Web.API.Prelude import qualified Fission.Web.API.App.Types as App +import qualified Fission.Web.API.Append.Types as Append import qualified Fission.Web.API.Auth.UCAN.Types as UCAN import qualified Fission.Web.API.DNS.Types as DNS import Fission.Web.API.Docs @@ -39,10 +40,11 @@ data RoutesV2 mode = RoutesV2 deriving Generic data V2 mode = V2 - { ipfs :: mode :- "ipfs" :> ToServantApi IPFS.RoutesV2 - , app :: mode :- "app" :> ToServantApi App.RoutesV2 - , user :: mode :- "user" :> ToServantApi User.RoutesV2 - , auth :: mode :- "auth" :> "ucan" :> ToServantApi UCAN.Routes + { ipfs :: mode :- "ipfs" :> ToServantApi IPFS.RoutesV2 + , app :: mode :- "app" :> ToServantApi App.RoutesV2 + , user :: mode :- "user" :> ToServantApi User.RoutesV2 + , auth :: mode :- "auth" :> "ucan" :> ToServantApi UCAN.Routes + , append :: mode :- "append" :> ToServantApi Append.RoutesV2 } deriving Generic diff --git a/fission-web-server/README.md b/fission-web-server/README.md index 5e7f1c55d..25dfa95af 100644 --- a/fission-web-server/README.md +++ b/fission-web-server/README.md @@ -57,7 +57,7 @@ To mimic the full "fission stack" for local development, you can use the include - `docker compose exec dns-auth pdnsutil add-record fissionuser.test. gateway A "127.0.0.1"` - `docker compose exec dns-auth pdnsutil add-record fissionapp.test. gateway A "127.0.0.1"` 5. Point your local DNS resolver to localhost. - - on macOS: this is under System Preferences > Network > Advanced. + - on macOS: this is under System Preferences > Network > Advanced (make sure your local IP is at the top of the list) - on Linux: Add `nameserver 127.0.0.1` to `/etc/resolv.conf` 6. Pin the CID for the new app placeholder: `docker compose exec ipfs ipfs pin add -r QmRVvvMeMEPi1zerpXYH9df3ATdzuB63R1wf3Mz5NS5HQN` @@ -84,4 +84,10 @@ runfission.test. 3600 IN SOA a.misconfigured.dns.server.inval If you don't see that, you can try the following steps: 1. Ensure the local DNS server is set up for the zone, e.g. `dig runfission.test -p 5300 @127.0.0.1`. If that fails, make sure the zone is created (see above). 2. Ensure the local resolver is working, e.g. `dig runfission.test @127.0.0.1`. If that fails, make sure the zone exists in `.env`. -3. If `dig runfission.test` still fails, ensure your system is set to use the local resolver. Also, try disabling any VPN software (Tailscale, etc) as they may conflict with DNS resolution. \ No newline at end of file +3. If `dig runfission.test` still fails, ensure your system is set to use the local resolver. Also, try disabling any VPN software (Tailscale, etc) as they may conflict with DNS resolution. + +#### Practical + +- Connecting to the database: `docker compose exec postgres psql` +- You can lookup DNSLinks using `dig -t TXT _dnslink.HOST` (eg. `dig -t TXT _dnslink.icidasset.files.fissionuser.test`) +- Interacting with the IPFS CLI connected to the IPFS daemon: `docker compose exec ipfs ipfs ...` \ No newline at end of file diff --git a/fission-web-server/library/Fission/Web/Server.hs b/fission-web-server/library/Fission/Web/Server.hs index fdc075602..e39d5f83c 100644 --- a/fission-web-server/library/Fission/Web/Server.hs +++ b/fission-web-server/library/Fission/Web/Server.hs @@ -24,6 +24,7 @@ import qualified Fission.Web.Server.User as User import Fission.Web.Server.WNFS import qualified Fission.Web.Server.Handler.App as App +import qualified Fission.Web.Server.Handler.Append as Append import qualified Fission.Web.Server.Handler.DNS as DNS import qualified Fission.Web.Server.Handler.Heroku as Heroku import qualified Fission.Web.Server.Handler.IPFS as IPFS @@ -37,10 +38,12 @@ import qualified Fission.Web.Server.LoosePin as LoosePin import qualified Fission.Web.Server.App as App import qualified Fission.Web.Server.App.Content as App.Content import qualified Fission.Web.Server.App.Domain as App.Domain +import qualified Fission.Web.Server.Domain.Retriever.Class as Domain import Fission.Web.Server.Handler import qualified Fission.Web.Server.Handler.Auth.UCAN as Auth.UCAN +import Fission.Web.Server.Config.Types import Fission.Web.Server.IPFS.Cluster as Cluster import Fission.Web.Server.IPFS.Linked import Fission.Web.Server.MonadDB @@ -58,8 +61,10 @@ import qualified Paths_fission_web_server as Fission -- | Top level web API type. Handled by 'server'. app :: forall m t . ( App.Domain.Initializer m + , App.Domain.Retriever m , App.Content.Initializer m , App.CRUD m + , Domain.Retriever m , Proof.Resolver m , MonadReflectiveServer m , MonadRelayStore m @@ -69,6 +74,7 @@ app :: forall m t . , MonadDNSLink m , MonadWNFS m , MonadLogger m + , MonadReader Config m , MonadTime m , MonadEmail m , User.CRUD m @@ -85,6 +91,7 @@ app :: forall m t . , LoosePin.CRUD t , User.Retriever t , User.Destroyer t + , App.Modifier t , App.Retriever t , App.Domain.Retriever t ) @@ -104,8 +111,10 @@ app handlerNT authChecks appHost = -- | Web handlers for the 'API' server :: ( App.Domain.Initializer m + , App.Domain.Retriever m , App.Content.Initializer m , App.CRUD m + , Domain.Retriever m , Proof.Resolver m , MonadReflectiveServer m , MonadRelayStore m @@ -115,6 +124,7 @@ server :: , MonadDNSLink m , MonadWNFS m , MonadLogger m + , MonadReader Config m , MonadTime m , MonadEmail m , User.CRUD m @@ -131,6 +141,7 @@ server :: , LoosePin.CRUD t , User.Retriever t , User.Destroyer t + , App.Modifier t , App.Retriever t , App.Domain.Retriever t ) @@ -158,6 +169,7 @@ server appHost = , app = genericServerT App.handlerV2 , user = genericServerT User.handlerV2 , auth = genericServerT Auth.UCAN.handler + , append = genericServerT Append.handlerV2 } serverV_ = @@ -171,4 +183,4 @@ server appHost = } v2Docs = - Web.Swagger.handler fromHandler appHost Fission.version (Proxy @("v2" :> (ToServantApi Fission.RoutesV2))) + Web.Swagger.handler fromHandler appHost Fission.version (Proxy @("v2" :> ToServantApi Fission.RoutesV2)) diff --git a/fission-web-server/library/Fission/Web/Server/App/Modifier.hs b/fission-web-server/library/Fission/Web/Server/App/Modifier.hs index 5beb0c72c..138059101 100644 --- a/fission-web-server/library/Fission/Web/Server/App/Modifier.hs +++ b/fission-web-server/library/Fission/Web/Server/App/Modifier.hs @@ -1,5 +1,6 @@ module Fission.Web.Server.App.Modifier ( module Fission.Web.Server.App.Modifier.Class + , addFile , setCidDB ) where @@ -8,18 +9,159 @@ import Database.Persist as Persist import Network.IPFS.Bytes.Types import Network.IPFS.CID.Types +import qualified Network.IPFS.Files as IPFS.Files +import qualified Network.IPFS.Pin as IPFS.Pin +import qualified Network.IPFS.Stat as IPFS.Stat + +import Network.IPFS.Remote.Class (MonadRemoteIPFS) + +import qualified RIO.ByteString.Lazy as Lazy +import RIO.Text as Text import Fission.Prelude hiding (on) import Fission.Error as Error +import Fission.FileSystem.DirectoryName +import Fission.FileSystem.FileName import Fission.URL +import qualified Fission.Web.Server.App.Domain.Retriever as App.Domain import Fission.Web.Server.App.Modifier.Class +import Fission.Web.Server.App.Retriever.Class (Retriever) +import qualified Fission.Web.Server.App.Retriever.Class as App.Retriever +import Fission.Web.Server.Config.Types +import qualified Fission.Web.Server.Domain as Domain +import qualified Fission.Web.Server.Domain.Retriever.Class as Domain.Retriever import Fission.Web.Server.Error.ActionNotAuthorized.Types +import qualified Fission.Web.Server.IPFS.DNSLink as DNSLink import Fission.Web.Server.Models -import Fission.Web.Server.MonadDB +import Fission.Web.Server.MonadDB.Class (MonadDB(..)) +import Fission.Web.Server.MonadDB.Types (Transaction) import Fission.Web.Server.Ownership +import Fission.Web.Auth.Token.UCAN.Resource.Types +import Fission.Web.Auth.Token.UCAN.Resource.Scope.Types +import Fission.Web.Auth.Token.UCAN.Potency.Types + +import Web.UCAN.Proof as UCAN.Proof + + +{-| Adds a file to an app. + +Notes: +* Overwrites existing file data +* Uses IPFS MFS as a temporary storage to manipulate the DAG structure + +-} +addFile :: + ( App.Domain.Retriever m + , Domain.Retriever.Retriever m + , DNSLink.MonadDNSLink m + , MonadDB t m + , MonadLogger m + , MonadReader Config m + , MonadRemoteIPFS m + , MonadTime m + , Modifier t + , Retriever m + ) + => UserId + -> DirectoryName + -> FileName + -> Lazy.ByteString + -> Maybe Potency + -> Scope Resource + -> m (Either Errors' CID) +addFile userId appName@(DirectoryName appNameText) fileName rawData maybePtc rsc = do + now <- currentTime + domainName <- asks baseAppDomain + + let subdomain = Subdomain appNameText + let url = URL domainName (Just subdomain) + + let resourceNeeded = Subset $ FissionApp (Subset url) + logDebug $ show rsc + logDebug $ show resourceNeeded + let hasResource = rsc `canDelegate` resourceNeeded + + mayApp <- App.Retriever.byURL userId url + + case (hasResource, mayApp) of + (False, _) -> + return . Error.openLeft $ ActionNotAuthorized @Resource userId + + (True, Left _) -> do + return . Error.openLeft $ NotFound @App + + (True, Right (Entity appId app@App {appCid})) -> + if isOwnedBy userId app then do + -- Update DAG, DNSLink & DB + let (DomainName domainNameTxt) = domainName + + -- TODO: Pass potency `maybePtc` to the following function, based on this + -- it should, or should not, be able to overwrite a file. + appendToDag domainNameTxt appName fileName rawData appCid >>= \case + Left err -> + return $ Left err + + Right (fileCid, newCid) -> + IPFS.Stat.getSizeRemote newCid >>= \case + Left err -> + return . Error.openLeft $ err + + Right size -> do + Domain.getByDomainName domainName >>= \case + Left err -> + return . Error.openLeft $ err + + Right Domain {domainZoneId} -> do + DNSLink.set userId url domainZoneId newCid >>= \case + Left err -> return . Error.openLeft $ err + Right _ -> do + runDB (setCIDDirectly now appId size newCid) + return $ Right fileCid + + else + return . Error.openLeft $ ActionNotAuthorized @App userId + + +appendToDag :: + ( MonadRemoteIPFS m + , MonadLogger m + ) + => Text + -> DirectoryName + -> FileName + -> Lazy.ByteString + -> CID + -> m (Either Errors' (CID, CID)) +appendToDag domainName (DirectoryName appName) (FileName fileName) rawData appCid = do + let appCidText = unaddress appCid + + let tmpDirPath = "/" <> domainName <> "/" <> appName <> "/" + let distDirPath = tmpDirPath <> appCidText <> "/" + let filePath = distDirPath <> "uploads/" <> fileName + + IPFS.Files.cp (Left appCid) (Text.unpack tmpDirPath) + IPFS.Files.write (Text.unpack filePath) rawData + + maybefileCid <- IPFS.Files.statCID (Text.unpack filePath) + maybedirCid <- IPFS.Files.statCID (Text.unpack distDirPath) + + case (maybefileCid, maybedirCid) of + (Left err, _) -> + return . Error.openLeft $ err + + (_, Left err) -> + return . Error.openLeft $ err + + (Right fileCid, Right newAppCid) -> do + _ <- IPFS.Pin.add newAppCid + IPFS.Files.rm (Text.unpack distDirPath) + + return $ Right (fileCid, newAppCid) + + setCidDB :: MonadIO m => UserId diff --git a/fission-web-server/library/Fission/Web/Server/App/Modifier/Class.hs b/fission-web-server/library/Fission/Web/Server/App/Modifier/Class.hs index c9dd672d7..7038936e7 100644 --- a/fission-web-server/library/Fission/Web/Server/App/Modifier/Class.hs +++ b/fission-web-server/library/Fission/Web/Server/App/Modifier/Class.hs @@ -3,19 +3,28 @@ module Fission.Web.Server.App.Modifier.Class , Errors' ) where -import qualified Network.IPFS.Add.Error as IPFS.Pin +import Database.Persist as Persist +import Servant.Server + +import Network.IPFS.Bytes.Types import Network.IPFS.CID.Types -import qualified Network.IPFS.Get.Error as IPFS.Stat -import Servant.Server +import qualified Network.IPFS.Add.Error as IPFS.Pin +import qualified Network.IPFS.Files.Error as IPFS.Files +import qualified Network.IPFS.Get.Error as IPFS.Stat import Fission.Prelude hiding (on) import Fission.Error as Error import Fission.URL +import qualified Fission.Web.Server.IPFS.DNSLink.Class as DNSLink import Fission.Web.Server.Error.ActionNotAuthorized.Types import Fission.Web.Server.Models +import Fission.Web.Server.MonadDB.Types (Transaction) + +import qualified Fission.Web.Auth.Token.UCAN.Resource.Types as Ucan + type Errors' = OpenUnion '[ NotFound App @@ -26,15 +35,25 @@ type Errors' = OpenUnion , ActionNotAuthorized App , ActionNotAuthorized AppDomain , ActionNotAuthorized URL + , ActionNotAuthorized Ucan.Resource + , IPFS.Files.Error , IPFS.Pin.Error , IPFS.Stat.Error + , DNSLink.Errors' , ServerError , InvalidURL ] class Monad m => Modifier m where + setCIDDirectly :: + UTCTime + -> AppId + -> Bytes + -> CID + -> m (Either Errors' AppId) + setCID :: UserId -- ^ User for auth -> URL -- ^ URL associated with target app @@ -42,3 +61,14 @@ class Monad m => Modifier m where -> Bool -- ^ Flag: copy data (default yes) -> UTCTime -- ^ Now -> m (Either Errors' AppId) + + +instance MonadIO m => Modifier (Transaction m) where + setCIDDirectly now appId size newCID = do + update appId + [ AppCid =. newCID + , AppSize =. size + ] + + insert (SetAppCIDEvent appId newCID size now) + return (Right appId) diff --git a/fission-web-server/library/Fission/Web/Server/Error/Class.hs b/fission-web-server/library/Fission/Web/Server/Error/Class.hs index 29123a6cf..4a1f4ed36 100644 --- a/fission-web-server/library/Fission/Web/Server/Error/Class.hs +++ b/fission-web-server/library/Fission/Web/Server/Error/Class.hs @@ -11,6 +11,7 @@ import qualified Network.IPFS.Error as IPFS import Network.IPFS.Types import qualified Network.IPFS.Add.Error as Add +import qualified Network.IPFS.Files.Error as Files import qualified Network.IPFS.Get.Error as Get import qualified Network.IPFS.Peer.Error as Peer @@ -84,6 +85,7 @@ instance ToServerError Int where instance ToServerError IPFS.Error where toServerError = \case IPFS.AddErr addErr -> toServerError addErr + IPFS.FilesErr filErr -> toServerError filErr IPFS.GetErr getErr -> toServerError getErr IPFS.LinearizationErr linErr -> toServerError linErr @@ -115,6 +117,11 @@ instance ToServerError Add.Error where Add.UnexpectedOutput _ -> err502 { errBody = "Unexpected IPFS result" } Add.IPFSDaemonErr msg -> err502 { errBody = "IPFS Daemon Error: " <> displayLazyBS msg} +instance ToServerError Files.Error where + toServerError = \err -> case err of + Files.DestinationAlreadyExists -> err422 { errBody = displayLazyBS err } + _ -> err502 { errBody = displayLazyBS err } + instance ToServerError Peer.Error where toServerError = \case Peer.DecodeFailure _ -> err500 { errBody = "Peer list decode error" } diff --git a/fission-web-server/library/Fission/Web/Server/Handler/Append.hs b/fission-web-server/library/Fission/Web/Server/Handler/Append.hs new file mode 100644 index 000000000..6b623063c --- /dev/null +++ b/fission-web-server/library/Fission/Web/Server/Handler/Append.hs @@ -0,0 +1,40 @@ +module Fission.Web.Server.Handler.Append (handlerV2) where + +import Fission.Web.Server.IPFS.DNSLink.Class +import Network.IPFS.File.Types as File +import Network.IPFS.Remote.Class (MonadRemoteIPFS) + +import Servant.Server.Generic + +import Fission.Prelude + +import qualified Fission.Web.API.Append.Types as Append + +import Fission.Web.Server.App.Domain.Retriever as App.Domain +import Fission.Web.Server.App.Modifier as App +import Fission.Web.Server.App.Retriever.Class as App +import Fission.Web.Server.Authorization.Types +import qualified Fission.Web.Server.Domain.Retriever.Class as Domain +import Fission.Web.Server.Config.Types +import Fission.Web.Server.Error as Web.Err +import Fission.Web.Server.MonadDB.Class (MonadDB(..)) + + +handlerV2 :: + ( App.Domain.Retriever m + , App.Modifier t + , App.Retriever m + , Domain.Retriever m + , MonadRemoteIPFS m + , MonadDB t m + , MonadDNSLink m + , MonadLogger m + , MonadReader Config m + , MonadTime m + ) + => Append.RoutesV2 (AsServerT m) +handlerV2 = Append.RoutesV2 {append} + where + append appName fileName (Serialized rawData) Authorization {about = Entity userId _, potency, resource} = do + cid <- Web.Err.ensureM $ App.addFile userId appName fileName rawData potency resource + return cid diff --git a/fission-web-server/library/Fission/Web/Server/Types.hs b/fission-web-server/library/Fission/Web/Server/Types.hs index 946174429..075ceb145 100644 --- a/fission-web-server/library/Fission/Web/Server/Types.hs +++ b/fission-web-server/library/Fission/Web/Server/Types.hs @@ -109,6 +109,7 @@ import Fission.Web.Server.Auth.Token.Basic.Class import Fission.Web.Server.Relay.Store.Class import Fission.Web.Server.Config.Types +import Fission.Web.Server.App.Domain (AlreadyAssociated(maybeSubdomain)) -- | The top-level app type newtype Server a = Server { unServer :: RIO Config a } @@ -546,6 +547,12 @@ instance MonadAuth Authorization Server where instance App.Domain.Initializer Server where initial = asks baseAppDomain +instance App.Domain.Retriever Server where + allForOwner userId = runDB $ App.Domain.allForOwner userId + allForApp appId = runDB $ App.Domain.allForApp appId + allSiblingsByDomain domainName maybeSubdomain = runDB $ App.Domain.allSiblingsByDomain domainName maybeSubdomain + primarySibling userId url = runDB $ App.Domain.primarySibling userId url + instance App.Content.Initializer Server where placeholder = asks appPlaceholder @@ -906,4 +913,3 @@ runUserUpdate updateDB dbValToTxt uID subdomain = PowerDNS.set TXT url (textDisplay zoneID) segments 10 >>= \case Left serverErr -> return $ Error.openLeft serverErr Right _ -> return $ Right dbVal - diff --git a/fission-web-server/package.yaml b/fission-web-server/package.yaml index e96c2f60c..1e426db59 100644 --- a/fission-web-server/package.yaml +++ b/fission-web-server/package.yaml @@ -1,5 +1,5 @@ name: fission-web-server -version: "2.19.1.0" +version: "2.20.0.0" category: API author: - Brooklyn Zelenka diff --git a/ipfs/library/Network/IPFS/Client.hs b/ipfs/library/Network/IPFS/Client.hs index 7e1e50412..076b06021 100644 --- a/ipfs/library/Network/IPFS/Client.hs +++ b/ipfs/library/Network/IPFS/Client.hs @@ -2,10 +2,14 @@ module Network.IPFS.Client ( API , add , cat - , stat + , dagPut + , filesCopy + , filesRemove + , filesStat + , filesWrite , pin + , stat , unpin - , dagPut ) where import qualified RIO.ByteString.Lazy as Lazy @@ -26,6 +30,9 @@ import qualified Network.IPFS.Client.Add as Add import qualified Network.IPFS.Client.Cat as Cat import qualified Network.IPFS.Client.DAG.Put.Types as DAG.Put import qualified Network.IPFS.Client.DAG.Types as DAG +import qualified Network.IPFS.Client.Files as Files +import qualified Network.IPFS.Client.Files.Statistics.Types as Files.Statistics +import qualified Network.IPFS.Client.Files.Write.Form.Types as Files.Write import qualified Network.IPFS.Client.Pin as Pin import qualified Network.IPFS.Client.Stat as Stat @@ -36,19 +43,36 @@ type API type V0API = "add" :> Add.API :<|> "cat" :> Cat.API - :<|> "object" :> Stat.API :<|> "dag" :> DAG.API + :<|> "object" :> Stat.API + :<|> "pin" :> Pin.API -cat :: CID -> ClientM File.Serialized -stat :: CID -> ClientM Stat -pin :: CID -> ClientM Pin.Response -unpin :: CID -> Bool -> ClientM Pin.Response -dagPut :: Bool -> (Lazy.ByteString, File.Form) -> ClientM DAG.Put.Response -add :: Lazy.ByteString -> ClientM CID + :<|> "files" :> Files.API + +add :: Lazy.ByteString -> ClientM CID +cat :: CID -> ClientM File.Serialized +dagPut :: Bool -> (Lazy.ByteString, File.Form) -> ClientM DAG.Put.Response +stat :: CID -> ClientM Stat + +pin :: CID -> ClientM Pin.Response +unpin :: CID -> Bool -> ClientM Pin.Response + +filesCopy :: Text -> Text -> Bool -> ClientM () +filesRemove :: Text -> Bool -> Maybe Bool -> ClientM () +filesStat :: Text -> ClientM Files.Statistics.Response + +filesWrite + :: Text -> Bool -> Bool -> Bool + -> Maybe Bool -> Maybe Integer -> Maybe Text + -> (Lazy.ByteString, Files.Write.Form) + -> ClientM () add :<|> cat - :<|> stat :<|> dagPut - :<|> pin - :<|> unpin = client $ Proxy @API + :<|> stat + + :<|> (pin :<|> unpin) + :<|> (filesCopy :<|> filesRemove :<|> filesStat :<|> filesWrite) + + = client (Proxy @API :: Proxy API) diff --git a/ipfs/library/Network/IPFS/Client/Files.hs b/ipfs/library/Network/IPFS/Client/Files.hs new file mode 100644 index 000000000..37c724f59 --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files.hs @@ -0,0 +1,13 @@ +module Network.IPFS.Client.Files + ( API + ) where + +import Servant.API + +import qualified Network.IPFS.Client.Files.Copy.Types as Copy +import qualified Network.IPFS.Client.Files.Remove.Types as Remove +import qualified Network.IPFS.Client.Files.Statistics.Types as Statistics +import qualified Network.IPFS.Client.Files.Write.Types as Write + + +type API = Copy.API :<|> Remove.API :<|> Statistics.API :<|> Write.API diff --git a/ipfs/library/Network/IPFS/Client/Files/Copy/Types.hs b/ipfs/library/Network/IPFS/Client/Files/Copy/Types.hs new file mode 100644 index 000000000..0f267f56f --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files/Copy/Types.hs @@ -0,0 +1,12 @@ +module Network.IPFS.Client.Files.Copy.Types (API) where + +import Servant.API +import Network.IPFS.Prelude + + +type API + = "cp" + :> QueryParam' '[Required] "arg" Text -- from + :> QueryParam' '[Required] "arg" Text -- to + :> QueryParam' '[Required] "parents" Bool + :> Post '[JSON] () diff --git a/ipfs/library/Network/IPFS/Client/Files/Remove/Types.hs b/ipfs/library/Network/IPFS/Client/Files/Remove/Types.hs new file mode 100644 index 000000000..4e32ce40c --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files/Remove/Types.hs @@ -0,0 +1,12 @@ +module Network.IPFS.Client.Files.Remove.Types (API) where + +import Servant.API +import Network.IPFS.Prelude + + +type API + = "rm" + :> QueryParam' '[Required] "arg" Text -- path + :> QueryParam' '[Required] "recursive" Bool + :> QueryParam' '[] "force" Bool + :> Post '[JSON] () diff --git a/ipfs/library/Network/IPFS/Client/Files/Statistics/Types.hs b/ipfs/library/Network/IPFS/Client/Files/Statistics/Types.hs new file mode 100644 index 000000000..97b77042c --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files/Statistics/Types.hs @@ -0,0 +1,23 @@ +module Network.IPFS.Client.Files.Statistics.Types (API, Response (..)) where + +import Servant.API + +import Network.IPFS.CID.Types +import Network.IPFS.Prelude + + +type API + = "stat" + :> QueryParam' '[Required] "arg" Text -- path + :> Post '[JSON] Response + +newtype Response = Response { cid :: CID } + deriving (Eq, Show) + +instance Display Response where + textDisplay (Response cid) = textDisplay cid + +instance FromJSON Response where + parseJSON = withObject "IPFS.Files.Stat.Response" \obj -> do + cid <- obj .: "Hash" + return $ Response cid \ No newline at end of file diff --git a/ipfs/library/Network/IPFS/Client/Files/Write/Form/Types.hs b/ipfs/library/Network/IPFS/Client/Files/Write/Form/Types.hs new file mode 100644 index 000000000..10f23b1ba --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files/Write/Form/Types.hs @@ -0,0 +1,25 @@ +module Network.IPFS.Client.Files.Write.Form.Types (Form (..)) where + +import RIO + +import Servant.Multipart +import Servant.Multipart.API + +import Network.Mime +import qualified Network.IPFS.File.Types as File + +data Form = Form + { content :: File.Serialized + , fileName :: FileName + } + +instance ToMultipart Mem Form where + toMultipart Form { content = File.Serialized fileLBS, fileName } = + MultipartData + [] + [ FileData + "data" + fileName + (decodeUtf8Lenient $ defaultMimeLookup fileName) + fileLBS + ] diff --git a/ipfs/library/Network/IPFS/Client/Files/Write/Types.hs b/ipfs/library/Network/IPFS/Client/Files/Write/Types.hs new file mode 100644 index 000000000..47ac492f5 --- /dev/null +++ b/ipfs/library/Network/IPFS/Client/Files/Write/Types.hs @@ -0,0 +1,20 @@ +module Network.IPFS.Client.Files.Write.Types (API) where + +import Servant.API +import Servant.Multipart + +import Network.IPFS.Prelude +import Network.IPFS.Client.Files.Write.Form.Types + + +type API + = "write" + :> QueryParam' '[Required] "arg" Text -- path + :> QueryParam' '[Required] "create" Bool + :> QueryParam' '[Required] "parents" Bool + :> QueryParam' '[Required] "truncate" Bool + :> QueryParam' '[] "raw-leaves" Bool -- (experimental) Use raw blocks for newly created leaf nodes. + :> QueryParam' '[] "cid-version" Integer -- (experimental) Cid version to use. + :> QueryParam' '[] "hash" Text -- (experimental) Hash function to use. + :> MultipartForm Mem Form + :> Post '[JSON] () diff --git a/ipfs/library/Network/IPFS/Error.hs b/ipfs/library/Network/IPFS/Error.hs index 41d7abe38..c28ca4d2e 100644 --- a/ipfs/library/Network/IPFS/Error.hs +++ b/ipfs/library/Network/IPFS/Error.hs @@ -6,11 +6,13 @@ module Network.IPFS.Error import Network.IPFS.Prelude import Network.IPFS.Types -import qualified Network.IPFS.Add.Error as Add -import qualified Network.IPFS.Get.Error as Get +import qualified Network.IPFS.Add.Error as Add +import qualified Network.IPFS.Files.Error as Files +import qualified Network.IPFS.Get.Error as Get data Error = AddErr Add.Error + | FilesErr Files.Error | GetErr Get.Error | LinearizationErr Linearization deriving ( Exception diff --git a/ipfs/library/Network/IPFS/Files.hs b/ipfs/library/Network/IPFS/Files.hs new file mode 100644 index 000000000..9aa8453f7 --- /dev/null +++ b/ipfs/library/Network/IPFS/Files.hs @@ -0,0 +1,153 @@ +module Network.IPFS.Files (cp, rm, statCID, write) where + + +import Network.IPFS.File.Types +import Network.IPFS.Files.Error as IPFS.Files +import qualified Network.IPFS.Internal.UTF8 as UTF8 +import Network.IPFS.Remote.Class as IPFS +import Network.IPFS.Prelude hiding (link) +import Network.IPFS.Types as IPFS + +import qualified Network.IPFS.Client.Files.Statistics.Types as Files.Statistics +import qualified Network.IPFS.Client.Files.Write.Form.Types as Write + +import qualified RIO.ByteString.Lazy as Lazy +import RIO.FilePath +import qualified RIO.Text as Text + +import Servant.Client +import qualified Servant.Multipart.Client as Multipart.Client + + +{-| MFS Copying. + +Can be used for both copying to and from MFS. +Will create parent directories. + +-} +cp :: (MonadLogger m, MonadRemoteIPFS m) + => Either IPFS.CID FilePath + -> FilePath + -> m (Either IPFS.Files.Error ()) +cp cidOrFilePath destination = + let + from = + case cidOrFilePath of + Left (IPFS.CID hash) -> Text.unpack (Text.append "/ipfs/" hash) + Right path -> path + + args = MfsCopyArgs + { from = Text.pack from + , to = Text.pack destination + , parents = True + } + in + IPFS.mfsCopy args >>= \case + Right () -> + return $ Right () + + Left err -> do + formattedError <- parseClientError err + return $ Left formattedError + + +{-| MFS Removing. + +Remove something from MFS. + +-} +rm :: (MonadLogger m, MonadRemoteIPFS m) + => FilePath + -> m (Either IPFS.Files.Error ()) +rm path = + let + args = MfsRemoveArgs { path = Text.pack path, recursive = True, force = Nothing } + in + IPFS.mfsRemove args >>= \case + Right () -> + return $ Right () + + Left err -> do + formattedError <- parseClientError err + return $ Left formattedError + + +{-| MFS CID for path. + +Get the CID for a given path. + +-} +statCID :: (MonadLogger m, MonadRemoteIPFS m) + => FilePath + -> m (Either IPFS.Files.Error IPFS.CID) +statCID path = + let + args = MfsStatArgs { path = Text.pack path } + in + IPFS.mfsStat args >>= \case + Right (Files.Statistics.Response {cid}) -> + return $ Right cid + + Left err -> do + formattedError <- parseClientError err + return $ Left formattedError + + +{-| MFS Writing. + +Write to a file in MFS. + +-} +write :: (MonadLogger m, MonadRemoteIPFS m) + => FilePath + -> Lazy.ByteString + -> m (Either IPFS.Files.Error ()) +write path raw = + let + args = MfsWriteArgs + { path = Text.pack path + , create = True + , parents = True + , truncate = True + , rawLeaves = Just True + , cidVersion = Just 1 + , hash = Nothing + } + in do + boundary <- liftIO Multipart.Client.genBoundary + + let formData = Serialized raw + let fileName = Text.pack $ takeFileName path + + IPFS.mfsWrite args (boundary, Write.Form formData fileName) >>= \case + Right () -> + return $ Right () + + Left err -> do + formattedError <- parseClientError err + return $ Left formattedError + + + +-- 🛠 + + +{-| Parse and Log the Servant Client Error returned from the IPFS Daemon +-} +parseClientError :: MonadLogger m => ClientError -> m Error +parseClientError err = do + logError $ displayShow err + return $ case err of + FailureResponse _ response -> + response + |> responseBody + |> decode + |> \case + Just IPFS.ErrorBody {message} -> + IPFSDaemonErr $ UTF8.textShow message + + _ -> + UnexpectedOutput $ UTF8.textShow err + + unknownClientError -> + UnknownFilesErr $ UTF8.textShow unknownClientError \ No newline at end of file diff --git a/ipfs/library/Network/IPFS/Files/Error.hs b/ipfs/library/Network/IPFS/Files/Error.hs new file mode 100644 index 000000000..9c2651b19 --- /dev/null +++ b/ipfs/library/Network/IPFS/Files/Error.hs @@ -0,0 +1,57 @@ +module Network.IPFS.Files.Error (Error (..)) where + +import Network.IPFS.Prelude +import Network.IPFS.Types + +data Error + = DestinationAlreadyExists + | InvalidCID Text + | IPFSDaemonErr Text + | UnexpectedOutput Text + | UnknownFilesErr Text + | TimedOutCopy Natural + | TimedOutStat Natural + | TimedOutWrite Natural + deriving ( Exception + , Eq + , Generic + , Show + ) + +instance Display Error where + display = \case + DestinationAlreadyExists -> + "Cannot copy to destination, item already exists" + + InvalidCID hash -> + "Invalid CID: " <> display hash + + IPFSDaemonErr txt -> + "IPFS Daemon error: " <> display txt + + TimedOutCopy sec -> + mconcat + [ "Unable to copy before the timeout of " + , display sec + , " seconds." + ] + + TimedOutStat sec -> + mconcat + [ "Unable to get statistics before the timeout of " + , display sec + , " seconds." + ] + + TimedOutWrite sec -> + mconcat + [ "Unable to write before the timeout of " + , display sec + , " seconds." + ] + + UnexpectedOutput txt -> + "Unexpected IPFS output: " <> display txt + + UnknownFilesErr txt -> + "Unknown IPFS files error: " <> display txt diff --git a/ipfs/library/Network/IPFS/Remote/Class.hs b/ipfs/library/Network/IPFS/Remote/Class.hs index 710897dba..310b91925 100644 --- a/ipfs/library/Network/IPFS/Remote/Class.hs +++ b/ipfs/library/Network/IPFS/Remote/Class.hs @@ -1,23 +1,48 @@ module Network.IPFS.Remote.Class ( MonadRemoteIPFS + , MfsCopyArgs (..) + , MfsStatArgs (..) + , MfsRemoveArgs (..) + , MfsWriteArgs (..) , runRemote , ipfsAdd , ipfsCat , ipfsStat , ipfsPin , ipfsUnpin + , mfsCopy + , mfsRemove + , mfsStat + , mfsWrite ) where import Network.IPFS.Prelude -import qualified RIO.ByteString.Lazy as Lazy +import qualified RIO.ByteString.Lazy as Lazy import Servant.Client -import Network.IPFS.Types as IPFS +import Network.IPFS.Types as IPFS + +import qualified Network.IPFS.Client as IPFS.Client +import qualified Network.IPFS.Client.Pin as Pin +import qualified Network.IPFS.File.Types as File +import qualified Network.IPFS.Client.Files.Statistics.Types as Files.Statistics +import qualified Network.IPFS.Client.Files.Write.Form.Types as Files.Write + + +data MfsCopyArgs = MfsCopyArgs { from :: Text, to :: Text, parents :: Bool } +data MfsRemoveArgs = MfsRemoveArgs { path :: Text, recursive :: Bool, force :: Maybe Bool } +data MfsStatArgs = MfsStatArgs { path :: Text } +data MfsWriteArgs = MfsWriteArgs + { path :: Text + , create :: Bool + , parents :: Bool + , truncate :: Bool + , rawLeaves :: Maybe Bool + , cidVersion :: Maybe Integer + , hash :: Maybe Text + } -import qualified Network.IPFS.Client as IPFS.Client -import qualified Network.IPFS.Client.Pin as Pin -import qualified Network.IPFS.File.Types as File class MonadIO m => MonadRemoteIPFS m where runRemote :: ClientM a -> m (Either ClientError a) @@ -27,9 +52,19 @@ class MonadIO m => MonadRemoteIPFS m where ipfsPin :: CID -> m (Either ClientError Pin.Response) ipfsUnpin :: CID -> Bool -> m (Either ClientError Pin.Response) + mfsCopy :: MfsCopyArgs -> m (Either ClientError ()) + mfsRemove :: MfsRemoveArgs -> m (Either ClientError ()) + mfsStat :: MfsStatArgs -> m (Either ClientError Files.Statistics.Response) + mfsWrite :: MfsWriteArgs -> (Lazy.ByteString, Files.Write.Form) -> m (Either ClientError ()) + -- defaults - ipfsAdd raw = runRemote $ IPFS.Client.add raw + ipfsAdd raw = runRemote $ IPFS.Client.add raw ipfsCat cid = runRemote $ IPFS.Client.cat cid ipfsPin cid = runRemote $ IPFS.Client.pin cid ipfsUnpin cid recursive = runRemote $ IPFS.Client.unpin cid recursive ipfsStat cid = runRemote $ IPFS.Client.stat cid + + mfsCopy (MfsCopyArgs { .. }) = runRemote $ IPFS.Client.filesCopy from to parents + mfsRemove (MfsRemoveArgs { .. }) = runRemote $ IPFS.Client.filesRemove path recursive force + mfsStat (MfsStatArgs { .. }) = runRemote $ IPFS.Client.filesStat path + mfsWrite (MfsWriteArgs { .. }) raw = runRemote $ IPFS.Client.filesWrite path create parents truncate rawLeaves cidVersion hash raw diff --git a/ipfs/package.yaml b/ipfs/package.yaml index 4af674cc5..a662625da 100644 --- a/ipfs/package.yaml +++ b/ipfs/package.yaml @@ -88,6 +88,7 @@ dependencies: - Glob - http-media - lens + - mime-types - monad-logger - network-ip - regex-compat