diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,86 @@ +# ipfs-haskell + +[![Build Status](https://travis-ci.org/fission-suite/PROJECTNAME.svg?branch=master)](https://travis-ci.org/fission-suite/ipfs-haskell) +[![License](https://img.shields.io/badge/License-Apache%202.0-blue.svg)](https://github.com/fission-suite/blob/master/LICENSE) +[![Maintainability](https://api.codeclimate.com/v1/badges/44fb6a8a0cfd88bc41ef/maintainability)](https://codeclimate.com/github/fission-suite/ipfs-haskell/maintainability) +[![Built by FISSION](https://img.shields.io/badge/⌘-Built_by_FISSION-purple.svg)](https://fission.codes) +[![Discord](https://img.shields.io/discord/478735028319158273.svg)](https://discord.gg/zAQBDEq) +[![Discourse](https://img.shields.io/discourse/https/talk.fission.codes/topics)](https://talk.fission.codes) + +Documentation: [ipfs on hackage](http://hackage.haskell.org/package/ipfs) + +A library for integrating IPFS into your haskell applications. Interact with the IPFS network by shelling out to a local IPFS node or communicating via the HTTP interface of a remote node. + +# QuickStart + +Define instances for `MonadLocalIPFS` and/or `MonadRemoteIPFS`. Each requires only one function: + +```haskell +class Monad m => MonadRemoteIPFS m where + runRemote :: Servant.ClientM a -> m (Either Servant.ClientError a) + +class Monad m => MonadLocalIPFS m where + runLocal :: + [IPFS.Opt] + -> Lazy.ByteString + -> m (Either Process.Error Process.RawMessage) +``` + +We use RIO processes to shell out to a local IPFS node and Servant for HTTP requests to a remote node. + +After that, simply add `MonadLocalIPFS m` as a constraint to a function and you'll be able to call IPFS within it. +For instance: +```haskell +import Network.IPFS +import qualified Network.IPFS.Add as IPFS +import Network.IPFS.File.Types as File + +add :: + MonadLocalIPFS m + => File.Serialzed + -> m () +add (Serialized rawData) = IPFS.addRaw rawData >>= \case + Right newCID -> + -- ... + Left err -> + -- ... + +``` + +You can see example instances below: +```haskell +instance + ( HasProcessContext cfg + , HasLogFunc cfg + , Has IPFS.BinPath cfg + , Has IPFS.Timeout cfg + ) + => MonadLocalIPFS (RIO cfg) where + runLocal opts arg = do + IPFS.BinPath ipfs <- view hasLens + IPFS.Timeout secs <- view hasLens + let opts' = ("--timeout=" <> show secs <> "s") : opts + + runProc readProcess ipfs (byteStringInput arg) byteStringOutput opts' >>= \case + (ExitSuccess, contents, _) -> + return $ Right contents + (ExitFailure _, _, stdErr) + | Lazy.isSuffixOf "context deadline exceeded" stdErr -> + return . Left $ Process.Timeout secs + | otherwise -> + return . Left $ Process.UnknownErr stdErr + +instance + ( Has IPFS.URL cfg + , Has HTTP.Manager cfg + ) + => MonadRemoteIPFS (RIO cfg) where + runRemote query = do + IPFS.URL url <- view hasLens + manager <- view hasLens + + url + & mkClientEnv manager + & runClientM query + & liftIO +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ipfs.cabal b/ipfs.cabal new file mode 100644 --- /dev/null +++ b/ipfs.cabal @@ -0,0 +1,148 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 0ce7658c51aedc29d36dcf7bc42ec1a99ebc4eb32b76ffb58916cf586f58ba7b + +name: ipfs +version: 1.0.0 +synopsis: Access IPFS locally and remotely +description: Interact with the IPFS network by shelling out to a local IPFS node or communicating via the HTTP interface of a remote IPFS node. +category: Network +homepage: https://github.com/fission-suite/ipfs-haskell#readme +bug-reports: https://github.com/fission-suite/ipfs-haskell/issues +author: Brooklyn Zelenka, + Daniel Holmgren, + Ben Church +maintainer: brooklyn@fission.codes, + daniel@fission.codes, + ben@fission.codes +copyright: © 2019 Fission Internet Software Services for Open Networks Inc. +license: AGPL-3.0-or-later +license-file: LICENSE +tested-with: GHC==8.6.5 +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/fission-suite/ipfs-haskell + +library + exposed-modules: + Network.IPFS + Network.IPFS.Add + Network.IPFS.Add.Error + Network.IPFS.BinPath.Types + Network.IPFS.CID.Types + Network.IPFS.Client + Network.IPFS.Client.Add + Network.IPFS.Client.Cat + Network.IPFS.Client.Error.Types + Network.IPFS.Client.Param + Network.IPFS.Client.Pin + Network.IPFS.Config + Network.IPFS.DAG + Network.IPFS.DAG.Link + Network.IPFS.DAG.Link.Types + Network.IPFS.DAG.Node.Types + Network.IPFS.Error + Network.IPFS.File.Types + Network.IPFS.Gateway.Types + Network.IPFS.Get + Network.IPFS.Get.Error + Network.IPFS.Ignored.Types + Network.IPFS.Info.Types + Network.IPFS.Internal.Constraint + Network.IPFS.Internal.Orphanage.ByteString.Lazy + Network.IPFS.Internal.Orphanage.Natural + Network.IPFS.Internal.Orphanage.Utf8Builder + Network.IPFS.Internal.UTF8 + Network.IPFS.Local.Class + Network.IPFS.Name.Types + Network.IPFS.Path.Types + Network.IPFS.Peer + Network.IPFS.Peer.Error + Network.IPFS.Peer.Types + Network.IPFS.Pin + Network.IPFS.Prelude + Network.IPFS.Process + Network.IPFS.Process.Error + Network.IPFS.Process.Types + Network.IPFS.Remote.Class + Network.IPFS.SparseTree + Network.IPFS.SparseTree.Types + Network.IPFS.Stat + Network.IPFS.Timeout.Types + Network.IPFS.Types + Network.IPFS.URL.Types + Paths_ipfs + autogen-modules: + Paths_ipfs + hs-source-dirs: + library + default-extensions: ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings OverloadedLabels OverloadedLists PostfixOperators RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeSynonymInstances TemplateHaskell TypeOperators ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wpartial-fields -Wredundant-constraints -fhide-source-paths + build-depends: + Glob + , aeson + , base <5 + , bytestring + , data-has + , envy + , flow + , http-client + , ip + , lens + , monad-logger + , regex-compat + , rio + , servant-client + , servant-client-core + , servant-multipart + , servant-server + , swagger2 + , text + , vector + default-language: Haskell2010 + +test-suite fission-doctest + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_ipfs + hs-source-dirs: + test/doctest + default-extensions: ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings OverloadedLabels OverloadedLists PostfixOperators RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeSynonymInstances TemplateHaskell TypeOperators ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wpartial-fields -Wredundant-constraints -fhide-source-paths -threaded -rtsopts -with-rtsopts=-N + build-depends: + Glob + , QuickCheck + , aeson + , base <5 + , bytestring + , data-has + , directory + , directory-tree + , doctest + , envy + , flow + , http-client + , ip + , lens + , lens-aeson + , monad-logger + , regex-compat + , rio + , servant-client + , servant-client-core + , servant-multipart + , servant-server + , swagger2 + , text + , vector + , yaml + default-language: Haskell2010 diff --git a/library/Network/IPFS.hs b/library/Network/IPFS.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS.hs @@ -0,0 +1,13 @@ +module Network.IPFS + ( MonadLocalIPFS + , runLocal + , MonadRemoteIPFS + , runRemote + , ipfsAdd + , ipfsCat + , ipfsPin + , ipfsUnpin + ) where + +import Network.IPFS.Local.Class +import Network.IPFS.Remote.Class diff --git a/library/Network/IPFS/Add.hs b/library/Network/IPFS/Add.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Add.hs @@ -0,0 +1,153 @@ +module Network.IPFS.Add + ( addRaw + , addFile + , addPath + , addDir + ) where + +import Network.IPFS.Prelude hiding (link) +import Network.IPFS.Local.Class as IPFS + +import Data.ByteString.Lazy.Char8 as CL +import Data.List as List + +import qualified System.FilePath.Glob as Glob + +import RIO.Directory +import RIO.FilePath +import qualified RIO.ByteString.Lazy as Lazy + +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +import Network.IPFS.Add.Error as IPFS.Add +import Network.IPFS.Types as IPFS +import Network.IPFS.DAG.Node.Types as DAG +import Network.IPFS.DAG.Link as DAG.Link + +import Network.IPFS.DAG as DAG + +addRaw :: + MonadLocalIPFS m + => Lazy.ByteString + -> m (Either IPFS.Add.Error IPFS.CID) +addRaw raw = + IPFS.runLocal ["add", "-HQ"] raw >>= \case + Right result -> + case CL.lines result of + [cid] -> + cid + |> UTF8.textShow + |> UTF8.stripN 1 + |> mkCID + |> Right + |> return + + bad -> + return . Left . UnexpectedOutput <| UTF8.textShow bad + + Left err -> + return . Left . UnknownAddErr <| UTF8.textShow err + +addFile :: + MonadLocalIPFS m + => Lazy.ByteString + -> IPFS.Name + -> m (Either IPFS.Add.Error (IPFS.SparseTree, IPFS.CID)) +addFile raw name = + IPFS.runLocal opts raw >>= \case + Right result -> + case CL.lines result of + [inner, outer] -> + let + sparseTree = Directory [(Hash rootCID, fileWrapper)] + fileWrapper = Directory [(fileName, Content fileCID)] + rootCID = CID <| UTF8.textShow outer + fileCID = CID . UTF8.stripN 1 <| UTF8.textShow inner + fileName = Key name + in + return <| Right (sparseTree, rootCID) + + bad -> + return . Left . UnexpectedOutput <| UTF8.textShow bad + + + Left err -> + return . Left . UnknownAddErr <| UTF8.textShow err + + where + opts = [ "add" + , "-wq" + , "--stdin-name" + , unName name + ] + +addPath :: + MonadLocalIPFS m + => FilePath + -> m (Either IPFS.Add.Error CID) +addPath path = IPFS.runLocal ["add", "-HQ", path] "" >>= pure . \case + Right result -> + case CL.lines result of + [cid] -> Right . mkCID . UTF8.stripN 1 <| UTF8.textShow cid + bad -> Left . UnexpectedOutput <| UTF8.textShow bad + + Left err -> + Left . UnknownAddErr <| UTF8.textShow err + +addDir :: + ( MonadIO m + , MonadLocalIPFS m + ) + => IPFS.Ignored + -> FilePath + -> m (Either IPFS.Add.Error IPFS.CID) +addDir ignored path = doesFileExist path >>= \case + True -> addPath path + False -> walkDir ignored path + +walkDir :: + ( MonadIO m + , MonadLocalIPFS m + ) + => IPFS.Ignored + -> FilePath + -> m (Either IPFS.Add.Error IPFS.CID) +walkDir ignored path = do + files <- listDirectory path + + let + toAdd = removeIgnored ignored files + reducer = foldResults path ignored + seed = Right <| Node + { dataBlock = "CAE=" + , links = [] + } + + foldM reducer seed toAdd >>= \case + Left err -> return <| Left err + Right node -> DAG.putNode node + +foldResults :: + ( MonadIO m + , MonadLocalIPFS m + ) + => FilePath + -> IPFS.Ignored + -> Either IPFS.Add.Error Node + -> FilePath + -> m (Either IPFS.Add.Error Node) +foldResults _ _ (Left err) _ = return <| Left err +foldResults path ignored (Right node) filename = do + addDir ignored (path filename) >>= \case + Left err -> return <| Left err + Right cid -> + DAG.Link.create cid (IPFS.Name filename) >>= \case + Left err -> return . Left <| RecursiveAddErr err + Right link -> + return <| Right <| node { links = link:(links node) } + +removeIgnored :: IPFS.Ignored -> [FilePath] -> [FilePath] +removeIgnored ignored files = List.filter (not . matchesAny ignored) files + +matchesAny :: IPFS.Ignored -> FilePath -> Bool +matchesAny globs path = List.any (\x -> Glob.match x path) globs diff --git a/library/Network/IPFS/Add/Error.hs b/library/Network/IPFS/Add/Error.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Add/Error.hs @@ -0,0 +1,25 @@ +module Network.IPFS.Add.Error (Error (..)) where + +import Network.IPFS.Prelude +import qualified Network.IPFS.Get.Error as Get + +data Error + = InvalidFile + | UnexpectedOutput Text + | RecursiveAddErr Get.Error + | IPFSDaemonErr Text + | UnknownAddErr Text + deriving ( Exception + , Eq + , Generic + , Show + , ToJSON + ) + +instance Display Error where + display = \case + InvalidFile -> "Invalid file" + UnexpectedOutput txt -> "Unexpected IPFS output: " <> display txt + RecursiveAddErr err -> "Error while adding directory" <> display err + IPFSDaemonErr txt -> "IPFS Daemon error: " <> display txt + UnknownAddErr txt -> "Unknown IPFS add error: " <> display txt diff --git a/library/Network/IPFS/BinPath/Types.hs b/library/Network/IPFS/BinPath/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/BinPath/Types.hs @@ -0,0 +1,20 @@ +module Network.IPFS.BinPath.Types (BinPath (..)) where + +import System.Envy + +import Network.IPFS.Prelude +import Network.IPFS.Internal.Orphanage.Natural () + +-- | Path to the IPFS binary +newtype BinPath = BinPath { getBinPath :: FilePath } + deriving ( Show + , Generic + ) + deriving newtype ( IsString ) + +instance FromEnv BinPath where + fromEnv _ = BinPath <$> env "IPFS_PATH" + +instance FromJSON BinPath where + parseJSON = withText "IPFS.BinPath" \txt -> + BinPath <$> parseJSON (String txt) diff --git a/library/Network/IPFS/CID/Types.hs b/library/Network/IPFS/CID/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/CID/Types.hs @@ -0,0 +1,71 @@ +module Network.IPFS.CID.Types + ( CID (..) + , mkCID + ) where + +import RIO.Char +import qualified RIO.ByteString.Lazy as Lazy +import qualified RIO.Text as Text + +import Data.Swagger +import Servant + +import Network.IPFS.Prelude +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +newtype CID = CID { unaddress :: Text } + deriving ( Eq + , Generic + , Ord + , Read + , Show + ) + deriving anyclass ( ToParamSchema ) + deriving newtype ( IsString + , ToHttpApiData + ) + +instance ToJSON CID where + toJSON (CID cid) = cid |> normalize |> toJSON + where + normalize (Text.take 1 -> "\"") = UTF8.stripN 1 cid + normalize cid' = cid' + +instance FromJSON CID where + parseJSON = withText "ContentAddress" (pure . CID) + +instance ToSchema CID where + declareNamedSchema _ = + mempty + |> type_ ?~ SwaggerString + |> example ?~ "QmW2WQi7j6c7UgJTarActp7tDNikE4B2qXtFCfLPdsgaTQ" + |> NamedSchema (Just "IPFSAddress") + |> pure + +instance Display CID where + textDisplay = unaddress + +instance MimeRender PlainText CID where + mimeRender _ = UTF8.textToLazyBS . unaddress + +instance MimeRender OctetStream CID where + mimeRender _ = UTF8.textToLazyBS . unaddress + +instance MimeUnrender PlainText CID where + mimeUnrender _proxy bs = + case bs |> Lazy.toStrict |> decodeUtf8' of + Left err -> Left <| show err + Right txt -> Right <| CID txt + +instance MimeUnrender PlainText [CID] where + mimeUnrender proxy bs = sequence cids + where + cids :: [Either String CID] + cids = mimeUnrender proxy <$> Lazy.split (fromIntegral <| ord ',') bs + +instance FromHttpApiData CID where + parseUrlPiece = Right . CID + +-- | Smart constructor for @CID@ +mkCID :: Text -> CID +mkCID = CID . Text.strip diff --git a/library/Network/IPFS/Client.hs b/library/Network/IPFS/Client.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client.hs @@ -0,0 +1,39 @@ +module Network.IPFS.Client + ( API + , add + , cat + , pin + , unpin + ) where + +import qualified RIO.ByteString.Lazy as Lazy +import Servant +import Servant.Client + +import Network.IPFS.Prelude +import Network.IPFS.Internal.Orphanage.ByteString.Lazy () + +import qualified Network.IPFS.File.Types as File +import Network.IPFS.CID.Types + +import qualified Network.IPFS.Client.Add as Add +import qualified Network.IPFS.Client.Cat as Cat +import qualified Network.IPFS.Client.Pin as Pin + +type API + = "api" + :> "v0" + :> V0API + +type V0API = "add" :> Add.API + :<|> "cat" :> Cat.API + :<|> "pin" :> Pin.API + +add :: Lazy.ByteString -> ClientM CID +cat :: Text -> ClientM File.Serialized +pin :: Text -> ClientM Pin.Response +unpin :: Text -> Bool -> ClientM Pin.Response + +add :<|> cat + :<|> pin + :<|> unpin = client <| Proxy @API diff --git a/library/Network/IPFS/Client/Add.hs b/library/Network/IPFS/Client/Add.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client/Add.hs @@ -0,0 +1,10 @@ +module Network.IPFS.Client.Add (API) where + +import qualified RIO.ByteString.Lazy as Lazy + +import Servant + +import Network.IPFS.CID.Types (CID) + +type API = ReqBody '[PlainText] Lazy.ByteString + :> Post '[PlainText] CID diff --git a/library/Network/IPFS/Client/Cat.hs b/library/Network/IPFS/Client/Cat.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client/Cat.hs @@ -0,0 +1,9 @@ +module Network.IPFS.Client.Cat (API) where + +import Servant + +import qualified Network.IPFS.File.Types as File +import qualified Network.IPFS.Client.Param as Param + +type API = Param.CID + :> Get '[PlainText] File.Serialized diff --git a/library/Network/IPFS/Client/Error/Types.hs b/library/Network/IPFS/Client/Error/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client/Error/Types.hs @@ -0,0 +1,10 @@ +module Network.IPFS.Client.Error.Types (ErrorBody (..)) where + +import Network.IPFS.Prelude + +data ErrorBody = ErrorBody {message :: String} + +instance FromJSON ErrorBody where + parseJSON = withObject "ErrorBody" \obj -> do + message <- obj .: "Message" + return ErrorBody {..} diff --git a/library/Network/IPFS/Client/Param.hs b/library/Network/IPFS/Client/Param.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client/Param.hs @@ -0,0 +1,10 @@ +module Network.IPFS.Client.Param + ( CID + , IsRecursive + ) where + +import Servant +import Network.IPFS.Prelude + +type CID = QueryParam' '[Required, Strict] "arg" Text +type IsRecursive = QueryFlag "recursive" diff --git a/library/Network/IPFS/Client/Pin.hs b/library/Network/IPFS/Client/Pin.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Client/Pin.hs @@ -0,0 +1,32 @@ +module Network.IPFS.Client.Pin + ( API + , AddAPI + , RemoveAPI + , Response (..) + ) where + +import Servant + +import Network.IPFS.Prelude +import Network.IPFS.CID.Types +import qualified Network.IPFS.Client.Param as Param + +type API = AddAPI :<|> RemoveAPI + +type AddAPI + = "add" + :> Param.CID + :> Put '[JSON] Response + +type RemoveAPI + = "rm" + :> Param.CID + :> Param.IsRecursive + :> Delete '[JSON] Response + +newtype Response = Response { cids :: [CID] } + deriving (Eq, Show) + +instance FromJSON Response where + parseJSON = withObject "Pin Response" \obj -> + Response <$> obj .: "Pins" diff --git a/library/Network/IPFS/Config.hs b/library/Network/IPFS/Config.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Config.hs @@ -0,0 +1,32 @@ +-- | Application configuration and top-level 'RIO' helpers +module Network.IPFS.Config + ( get + ) where + +import RIO +import Data.Has + +-- $setup +-- +-- >>> import RIO +-- >>> import Data.Has +-- >>> +-- >>> :set -XBlockArguments +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XOverloadedStrings + +-- | Get a value from the reader config +-- +-- >>> data Field = Field Text +-- >>> data Cfg = Cfg Field +-- >>> +-- >>> instance Has Field Cfg where hasLens = \f (Cfg field) -> Cfg <$> f field +-- >>> +-- >>> :{ +-- >>> runRIO (Cfg $ Field "hello world") do +-- >>> Field txt <- get +-- >>> return txt +-- >>> :} +-- "hello world" +get :: (MonadReader cfg m, Has a cfg) => m a +get = view hasLens diff --git a/library/Network/IPFS/DAG.hs b/library/Network/IPFS/DAG.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/DAG.hs @@ -0,0 +1,42 @@ +module Network.IPFS.DAG + ( put + , putNode + ) where + +import Network.IPFS.Prelude +import Network.IPFS.Local.Class as IPFS + +import qualified Network.IPFS.Internal.UTF8 as UTF8 +import Data.ByteString.Lazy.Char8 as CL +import qualified RIO.ByteString.Lazy as Lazy + +import Network.IPFS.Add.Error as IPFS.Add +import Network.IPFS.Types as IPFS +import Network.IPFS.DAG.Node.Types as DAG + +put :: + MonadLocalIPFS m + => Lazy.ByteString + -> m (Either IPFS.Add.Error IPFS.CID) +put raw = IPFS.runLocal ["dag", "put", "-f", "dag-pb"] raw >>= \case + Right result -> + case CL.lines result of + [cid] -> + cid + |> UTF8.textShow + |> UTF8.stripN 1 + |> mkCID + |> Right + |> return + + bad -> + pure . Left . UnexpectedOutput <| UTF8.textShow bad + + Left err -> + pure . Left . UnknownAddErr <| UTF8.textShow err + +putNode :: + MonadLocalIPFS m + => DAG.Node + -> m (Either IPFS.Add.Error IPFS.CID) +putNode node = put <| encode node diff --git a/library/Network/IPFS/DAG/Link.hs b/library/Network/IPFS/DAG/Link.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/DAG/Link.hs @@ -0,0 +1,22 @@ +module Network.IPFS.DAG.Link (create) where + +import Network.IPFS.Prelude +import Network.IPFS.Local.Class + +import Network.IPFS.Get.Error as IPFS.Get +import Network.IPFS.Types as IPFS +import Network.IPFS.DAG.Link.Types as DAG +import qualified Network.IPFS.Stat as Stat + +create :: + MonadLocalIPFS m + => IPFS.CID + -> IPFS.Name + -> m (Either IPFS.Get.Error Link) +create cid name = Stat.getSize cid >>= \case + Left err -> return <| Left err + Right size -> return . Right <| Link + { cid = cid + , name = name + , size = size + } diff --git a/library/Network/IPFS/DAG/Link/Types.hs b/library/Network/IPFS/DAG/Link/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/DAG/Link/Types.hs @@ -0,0 +1,21 @@ +module Network.IPFS.DAG.Link.Types (Link (..)) where + +import Network.IPFS.Prelude +import Network.IPFS.Types as IPFS +import Data.Text as T + + +data Link = Link + { cid :: IPFS.CID + , name :: IPFS.Name + , size :: Integer + } deriving (Show, Eq, Generic) + + +instance ToJSON Link where + toJSON (Link cid name size) = + Object [ ("Name", String . T.pack <| unName name) + , ("Size", Number <| fromIntegral size) + , ("Cid", Object [("/", String <| unaddress cid)]) + ] + diff --git a/library/Network/IPFS/DAG/Node/Types.hs b/library/Network/IPFS/DAG/Node/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/DAG/Node/Types.hs @@ -0,0 +1,19 @@ +module Network.IPFS.DAG.Node.Types (Node (..)) where + +import Network.IPFS.Prelude + +import Data.Vector +import Network.IPFS.DAG.Link.Types as DAG + + +data Node = Node + { dataBlock :: Text + , links :: [DAG.Link] + } deriving (Show, Eq) + +instance ToJSON Node where + toJSON (Node dataBlock links) = + Object [ ("data", String dataBlock) + , ("links", Array . fromList <| toJSON <$> links) + ] + diff --git a/library/Network/IPFS/Error.hs b/library/Network/IPFS/Error.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Error.hs @@ -0,0 +1,34 @@ +module Network.IPFS.Error + ( Error (..) + , Linearization (..) + ) where + +import Network.IPFS.Prelude +import Network.IPFS.Types + +import qualified Network.IPFS.Add.Error as Add +import qualified Network.IPFS.Get.Error as Get + +data Error + = AddErr Add.Error + | GetErr Get.Error + | LinearizationErr Linearization + deriving ( Exception + , Eq + , Generic + , Show + , ToJSON + ) + +-- NOTE Will not stay as a newtype in the long term +newtype Linearization = NonLinear SparseTree + deriving ( Eq + , Generic + , Show + ) + deriving anyclass ( Exception + , ToJSON + ) + +instance Display Linearization where + display (NonLinear sparseTree) = "Unable to linearize IPFS result: " <> display sparseTree diff --git a/library/Network/IPFS/File/Types.hs b/library/Network/IPFS/File/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/File/Types.hs @@ -0,0 +1,40 @@ +-- | File types +module Network.IPFS.File.Types (Serialized (..)) where + +import qualified Data.ByteString.Builder as Builder +import Data.Swagger +import Servant +import qualified RIO.ByteString.Lazy as Lazy + +import Network.IPFS.Prelude + +-- | A file serialized as a lazy bytestring +newtype Serialized = Serialized { unserialize :: Lazy.ByteString } + deriving ( Eq + , Show + ) + deriving newtype ( IsString ) + +instance ToSchema Serialized where + declareNamedSchema _ = + mempty + |> example ?~ "hello world" + |> description ?~ "A typical file's contents" + |> type_ ?~ SwaggerString + |> NamedSchema (Just "SerializedFile") + |> pure + +instance Display Serialized where + display = Utf8Builder . Builder.lazyByteString . unserialize + +instance MimeRender PlainText Serialized where + mimeRender _proxy = unserialize + +instance MimeUnrender PlainText Serialized where + mimeUnrender _proxy = Right . Serialized + +instance MimeRender OctetStream Serialized where + mimeRender _proxy = unserialize + +instance MimeUnrender OctetStream Serialized where + mimeUnrender _proxy = Right . Serialized diff --git a/library/Network/IPFS/Gateway/Types.hs b/library/Network/IPFS/Gateway/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Gateway/Types.hs @@ -0,0 +1,18 @@ +module Network.IPFS.Gateway.Types (Gateway (..)) where + +import Network.IPFS.Prelude +import Data.Swagger (ToSchema (..)) + +-- | Type safety wrapper for IPFS Gateway +-- Used as cname value for DNS updates +newtype Gateway = Gateway { getGateway :: Text } + deriving ( Eq + , Generic + , Show + ) + deriving anyclass ( ToSchema ) + deriving newtype ( IsString ) + +instance FromJSON Gateway where + parseJSON = withText "AWS.Gateway" \txt -> + Gateway <$> parseJSON (String txt) diff --git a/library/Network/IPFS/Get.hs b/library/Network/IPFS/Get.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Get.hs @@ -0,0 +1,40 @@ +module Network.IPFS.Get + ( getFile + , getFileOrDirectory + ) where + +import Network.IPFS.Prelude +import Network.IPFS.Local.Class as IPFS +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +import Data.ByteString.Lazy.Char8 as CL +import qualified RIO.ByteString.Lazy as Lazy +import qualified RIO.Text as Text + +import qualified Network.IPFS.File.Types as File +import Network.IPFS.Get.Error as IPFS.Get +import qualified Network.IPFS.Process.Error as Process +import Network.IPFS.Types as IPFS + +getFileOrDirectory :: + MonadLocalIPFS m + => IPFS.CID + -> m (Either IPFS.Get.Error CL.ByteString) +getFileOrDirectory cid@(IPFS.CID hash) = IPFS.runLocal ["get", Text.unpack hash] "" >>= \case + Right contents -> return <| Right contents + Left err -> case err of + Process.Timeout secs -> return . Left <| TimedOut cid secs + Process.UnknownErr raw -> return . Left . UnknownErr <| UTF8.textShow raw + +getFile :: + MonadLocalIPFS m + => IPFS.CID + -> m (Either IPFS.Get.Error File.Serialized) +getFile cid@(IPFS.CID hash) = IPFS.runLocal ["cat"] (UTF8.textToLazyBS hash) >>= \case + Right contents -> return . Right <| File.Serialized contents + Left err -> case err of + Process.Timeout secs -> return . Left <| TimedOut cid secs + Process.UnknownErr raw -> + if Lazy.isPrefixOf "Error: invalid 'ipfs ref' path" raw + then return . Left <| InvalidCID hash + else return . Left . UnknownErr <| UTF8.textShow raw diff --git a/library/Network/IPFS/Get/Error.hs b/library/Network/IPFS/Get/Error.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Get/Error.hs @@ -0,0 +1,36 @@ +module Network.IPFS.Get.Error (Error (..)) where + +import Network.IPFS.Prelude +import Network.IPFS.Types + +data Error + = InvalidCID Text + | TimedOut CID Natural + | UnexpectedOutput Text + | UnknownErr Text + deriving ( Exception + , Eq + , Generic + , Show + , ToJSON + ) + +instance Display Error where + display = \case + InvalidCID hash -> + "Invalid CID: " <> display hash + + TimedOut (CID hash) sec -> + mconcat + [ "Unable to find CID " + , display hash + , " before the timeout of " + , display sec + , " seconds." + ] + + UnexpectedOutput raw -> + "Unexpected IPFS output: " <> display raw + + UnknownErr raw -> + "Unknwon IPFS get error: " <> display raw diff --git a/library/Network/IPFS/Ignored/Types.hs b/library/Network/IPFS/Ignored/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Ignored/Types.hs @@ -0,0 +1,5 @@ +module Network.IPFS.Ignored.Types (Ignored) where + +import qualified System.FilePath.Glob as Glob + +type Ignored = [Glob.Pattern] diff --git a/library/Network/IPFS/Info/Types.hs b/library/Network/IPFS/Info/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Info/Types.hs @@ -0,0 +1,22 @@ +module Network.IPFS.Info.Types (Info (..)) where + +import Network.IPFS.Prelude +import Network.IPFS.Peer.Types + +data Info = Info + { id :: Text + , publicKey :: Text + , addresses :: [Peer] + , agentVersion :: Text + , protocolVersion :: Text + } deriving (Show, Eq) + +instance FromJSON Info where + parseJSON = withObject "IPFS.Info" \obj -> do + id <- obj .: "ID" + publicKey <- obj .: "PublicKey" + addresses <- obj .: "Addresses" + agentVersion <- obj .: "AgentVersion" + protocolVersion <- obj .: "ProtocolVersion" + + return Info {..} diff --git a/library/Network/IPFS/Internal/Constraint.hs b/library/Network/IPFS/Internal/Constraint.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Internal/Constraint.hs @@ -0,0 +1,5 @@ +module Network.IPFS.Internal.Constraint (MonadRIO) where + +import RIO + +type MonadRIO cfg m = (MonadIO m, MonadReader cfg m) diff --git a/library/Network/IPFS/Internal/Orphanage/ByteString/Lazy.hs b/library/Network/IPFS/Internal/Orphanage/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Internal/Orphanage/ByteString/Lazy.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.IPFS.Internal.Orphanage.ByteString.Lazy () where + +import qualified RIO.ByteString.Lazy as Lazy +import Servant + +import Network.IPFS.Prelude + +instance MimeRender PlainText Lazy.ByteString where + mimeRender _proxy = identity + +instance FromJSON ByteString where + parseJSON = withText "ByteString" (pure . encodeUtf8) diff --git a/library/Network/IPFS/Internal/Orphanage/Natural.hs b/library/Network/IPFS/Internal/Orphanage/Natural.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Internal/Orphanage/Natural.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +module Network.IPFS.Internal.Orphanage.Natural () where + +import System.Envy + +import Network.IPFS.Prelude + +instance Display Natural where + display nat = display (fromIntegral nat :: Integer) + +instance Var Natural where + fromVar = readMaybe diff --git a/library/Network/IPFS/Internal/Orphanage/Utf8Builder.hs b/library/Network/IPFS/Internal/Orphanage/Utf8Builder.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Internal/Orphanage/Utf8Builder.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.IPFS.Internal.Orphanage.Utf8Builder () where + +import RIO + +import Control.Monad.Logger + +instance ToLogStr Utf8Builder where + toLogStr (Utf8Builder builder) = toLogStr builder diff --git a/library/Network/IPFS/Internal/UTF8.hs b/library/Network/IPFS/Internal/UTF8.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Internal/UTF8.hs @@ -0,0 +1,32 @@ +-- | UTF8 text helpers +module Network.IPFS.Internal.UTF8 + ( Textable (..) + , stripN + , textToLazyBS + , textShow + ) where + +import RIO +import qualified RIO.ByteString.Lazy as Lazy +import qualified RIO.Text as Text + +class Textable a where + encode :: a -> Either UnicodeException Text + +instance Textable ByteString where + encode = decodeUtf8' + +instance Textable Lazy.ByteString where + encode = encode . Lazy.toStrict + +textToLazyBS :: Text -> Lazy.ByteString +textToLazyBS = Lazy.fromStrict . Text.encodeUtf8 + +textShow :: Show a => a -> Text +textShow = textDisplay . displayShow + +stripN :: Natural -> Text -> Text +stripN n = Text.dropEnd i . Text.drop i + where + i :: Int + i = fromIntegral n diff --git a/library/Network/IPFS/Local/Class.hs b/library/Network/IPFS/Local/Class.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Local/Class.hs @@ -0,0 +1,17 @@ +module Network.IPFS.Local.Class + ( MonadLocalIPFS + , runLocal + ) where + +import Network.IPFS.Prelude + +import qualified RIO.ByteString.Lazy as Lazy + +import Network.IPFS.Types as IPFS +import qualified Network.IPFS.Process.Error as Process + +class Monad m => MonadLocalIPFS m where + runLocal :: + [Opt] + -> Lazy.ByteString + -> m (Either Process.Error Process.RawMessage) diff --git a/library/Network/IPFS/Name/Types.hs b/library/Network/IPFS/Name/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Name/Types.hs @@ -0,0 +1,33 @@ +module Network.IPFS.Name.Types (Name (..)) where + +import qualified RIO.Text as Text + +import Servant +import Data.Swagger (ToParamSchema, ToSchema (..)) + +import Network.IPFS.Prelude + +newtype Name = Name { unName :: String } + deriving ( Eq + , Generic + , Show + , Ord + ) + deriving newtype ( IsString + , ToSchema + , ToParamSchema + ) + +instance Display Name where + display = displayShow + +instance ToJSON Name where + toJSON (Name n) = toJSON n + +instance FromJSON Name where + parseJSON = withText "IPFSName" (pure . Name . Text.unpack) + +instance FromHttpApiData Name where + parseUrlPiece = \case + "" -> Left "Empty Name field" + txt -> Right . Name <| Text.unpack txt diff --git a/library/Network/IPFS/Path/Types.hs b/library/Network/IPFS/Path/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Path/Types.hs @@ -0,0 +1,29 @@ +module Network.IPFS.Path.Types (Path (..)) where + +import Data.Swagger (ToSchema (..)) +import Servant + +import Network.IPFS.Prelude +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +-- | CID path +-- +-- Exmaple +-- +-- > "QmcaHAFzUPRCRaUK12dC6YyhcqEEtdfg94XrPwgCxZ1ihD/myfile.txt" +newtype Path = Path { unpath :: Text } + deriving ( Eq + , Generic + , Show + , Ord + ) + deriving newtype ( IsString + , ToHttpApiData + , ToSchema + ) + +instance MimeRender PlainText Path where + mimeRender _ = UTF8.textToLazyBS . unpath + +instance MimeRender OctetStream Path where + mimeRender _ = UTF8.textToLazyBS . unpath diff --git a/library/Network/IPFS/Peer.hs b/library/Network/IPFS/Peer.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Peer.hs @@ -0,0 +1,89 @@ +module Network.IPFS.Peer + ( all + , rawList + , connect + , connectRetry + , getExternalAddress + ) where + +import qualified RIO.Text as Text +import qualified RIO.List as List + +import qualified Net.IPv4 as IPv4 +import Text.Regex + +import Network.IPFS.Prelude hiding (all) +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +import qualified Network.IPFS.Types as IPFS +import qualified Network.IPFS.Process.Error as Process +import Network.IPFS.Local.Class as IPFS +import Network.IPFS.Peer.Error as IPFS.Peer +import Network.IPFS.Peer.Types +import Network.IPFS.Info.Types + +all :: + MonadLocalIPFS m + => m (Either IPFS.Peer.Error [IPFS.Peer]) +all = rawList <&> \case + Right raw -> case UTF8.encode raw of + Left _ -> Left <| DecodeFailure <| show raw + Right text -> Right <| IPFS.Peer <$> Text.lines text + Left err -> Left . UnknownErr <| UTF8.textShow err + +rawList :: + MonadLocalIPFS m + => m (Either Process.Error Process.RawMessage) +rawList = IPFS.runLocal ["bootstrap", "list"] "" + +connect :: + MonadLocalIPFS m + => Peer + -> m (Either IPFS.Peer.Error ()) +connect peer@(Peer peerID) = IPFS.runLocal ["swarm", "connect"] (UTF8.textToLazyBS peerID) >>= pure . \case + Left _ -> Left <| CannotConnect peer + Right _ -> Right () + +connectRetry :: + MonadLocalIPFS m + => Peer + -> Int + -> m (Either IPFS.Peer.Error ()) +connectRetry peer (-1) = return . Left <| CannotConnect peer +connectRetry peer tries = connect peer >>= \case + Right _ -> return <| Right () + Left _err -> connectRetry peer (tries - 1) + +peerAddressRe :: Regex +peerAddressRe = mkRegex "^/ip[46]/([a-zA-Z0-9.:]*)/" + +-- | Retrieve just the ip address from a peer address +extractIPfromPeerAddress :: String -> Maybe String +extractIPfromPeerAddress peer = matchRegex peerAddressRe peer >>= List.headMaybe + +-- | True if a given peer address is externally accessable +isExternalIPv4 :: Text -> Bool +isExternalIPv4 ip = maybe False not isReserved + where + isReserved :: Maybe Bool + isReserved = do + ipAddress <- extractIPfromPeerAddress <| Text.unpack ip + normalized <- IPv4.decode <| Text.pack ipAddress + return <| IPv4.reserved normalized + +-- | Filter a list of peers to include only the externally accessable addresses +filterExternalPeers :: [Peer] -> [Peer] +filterExternalPeers = filter (isExternalIPv4 . peer) + +-- | Get all external ipfs peer addresses +getExternalAddress :: + MonadLocalIPFS m + => m (Either IPFS.Peer.Error [Peer]) +getExternalAddress = IPFS.runLocal ["id"] "" >>= \case + Left err -> return <| Left <| UnknownErr <| UTF8.textShow err + Right raw -> + raw + |> decode + |> maybe [] addresses + |> Right . filterExternalPeers + |> pure diff --git a/library/Network/IPFS/Peer/Error.hs b/library/Network/IPFS/Peer/Error.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Peer/Error.hs @@ -0,0 +1,20 @@ +module Network.IPFS.Peer.Error (Error (..)) where + +import Network.IPFS.Prelude +import Network.IPFS.Peer.Types + +data Error + = DecodeFailure String + | CannotConnect Peer + | UnknownErr Text + deriving ( Exception + , Eq + , Generic + , Show + ) + +instance Display Error where + display = \case + DecodeFailure err -> "Unable to decode: " <> displayShow err + CannotConnect peer -> "Unable to connect to " <> display peer + UnknownErr msg -> "Unknown IPFS peer list error: " <> display msg diff --git a/library/Network/IPFS/Peer/Types.hs b/library/Network/IPFS/Peer/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Peer/Types.hs @@ -0,0 +1,35 @@ +module Network.IPFS.Peer.Types (Peer (..)) where + +import RIO + +import Control.Lens +import Data.Aeson +import Data.Swagger +import Servant + +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +newtype Peer = Peer { peer :: Text } + deriving ( Eq + , Show + ) + deriving newtype ( Display + , IsString + , FromJSON + ) + +instance ToJSON Peer where + toJSON = String . peer + +instance ToSchema Peer where + declareNamedSchema _ = + return $ NamedSchema (Just "IPFSPeer") $ mempty + & type_ ?~ SwaggerString + & example ?~ "/ip4/178.62.158.247/tcp/4001/ipfs/QmSoLer265NRgSp2LA3dPaeykiS1J6DifTC88f5uVQKNAd" + & description ?~ "An IPFS peer address" + +instance MimeRender PlainText Peer where + mimeRender _ = UTF8.textToLazyBS . peer + +instance MimeRender OctetStream Peer where + mimeRender _ = UTF8.textToLazyBS . peer diff --git a/library/Network/IPFS/Pin.hs b/library/Network/IPFS/Pin.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Pin.hs @@ -0,0 +1,98 @@ +module Network.IPFS.Pin + ( add + , rm + ) where + +import Network.IPFS.Prelude +import Network.IPFS.Remote.Class +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +import qualified Network.IPFS.Client.Pin as Pin +import Network.IPFS.Add.Error as IPFS.Add +import Network.IPFS.Types as IPFS +import Servant.Client.Core + +-- | Pin a CID +add :: + ( MonadRIO cfg m + , MonadRemoteIPFS m + , MonadLogger m + ) + => IPFS.CID + -> m (Either IPFS.Add.Error CID) +add cid = ipfsPin cid >>= \case + Right Pin.Response { cids } -> + case cids of + [cid'] -> do + logDebug <| "Pinned CID " <> display cid' + return <| Right cid' + + _ -> do + formattedErr <- parseUnexpectedOutput <| UTF8.textShow cids + return <| Left formattedErr + + Left err -> do + formattedError <- parseClientError err + return <| Left formattedError + +-- | Unpin a CID +rm :: + ( MonadRIO cfg m + , MonadRemoteIPFS m + , MonadLogger m + ) + => IPFS.CID + -> m (Either IPFS.Add.Error CID) +rm cid = ipfsUnpin cid False >>= \case + Right Pin.Response { cids } -> + case cids of + [cid'] -> do + logDebug <| "Unpinned CID " <> display cid' + return <| Right cid' + + _ -> do + formattedErr <- parseUnexpectedOutput <| UTF8.textShow cids + return <| Left formattedErr + + Left _ -> do + logDebug <| "Cannot unpin CID " <> display cid <> " because it was not pinned" + return <| Right cid + +-- | Parse and Log the Servant Client Error returned from the IPFS Daemon +parseClientError :: + ( MonadRIO cfg m + , 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 -> + UnknownAddErr <| UTF8.textShow unknownClientError + +-- | Parse and Log unexpected output when attempting to pin +parseUnexpectedOutput :: + ( MonadRIO cfg m + , MonadLogger m + ) + => Text + -> m IPFS.Add.Error +parseUnexpectedOutput errStr = do + let + baseError = UnexpectedOutput errStr + err = UnknownAddErr <| UTF8.textShow baseError + + logError <| display baseError + return err diff --git a/library/Network/IPFS/Prelude.hs b/library/Network/IPFS/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Prelude.hs @@ -0,0 +1,65 @@ +-- | A custom @Prelude@-like module for this project +module Network.IPFS.Prelude + ( module Control.Lens + , module Control.Monad.Logger + , module Data.Aeson + , module Data.Has + , module Network.IPFS.Internal.Constraint + , module Flow + , module RIO + , module RIO.Process + , identity + , logInfo + , logDebug + , logWarn + , logError + , logOther + ) where + +import Control.Lens ((%~), (.~), (?~), (^?)) +import Control.Monad.Logger (MonadLogger (..), ToLogStr (..), LogLevel (..), logWithoutLoc) +import Data.Aeson +import Data.Has + +import Network.IPFS.Internal.Constraint +import Network.IPFS.Internal.Orphanage.Utf8Builder () + +import Flow + +import RIO.Process +import RIO hiding ( Handler + , LogLevel (..) + , LogSource + , logDebug + , logDebugS + , logError + , logErrorS + , logInfo + , logInfoS + , logOther + , logOtherS + , logWarn + , logWarnS + , id + , timeout + , ($) + , (&) + ) + +identity :: a -> a +identity a = a + +logInfo :: (ToLogStr msg, MonadLogger m) => msg -> m () +logInfo = logWithoutLoc "" LevelInfo + +logDebug :: (ToLogStr msg, MonadLogger m) => msg -> m () +logDebug = logWithoutLoc "" LevelDebug + +logWarn :: (ToLogStr msg, MonadLogger m) => msg -> m () +logWarn = logWithoutLoc "" LevelWarn + +logError :: (ToLogStr msg, MonadLogger m) => msg -> m () +logError = logWithoutLoc "" LevelError + +logOther :: (ToLogStr msg, MonadLogger m) => LogLevel -> msg -> m () +logOther = logWithoutLoc "" diff --git a/library/Network/IPFS/Process.hs b/library/Network/IPFS/Process.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Process.hs @@ -0,0 +1,20 @@ +module Network.IPFS.Process (runProc) where + +import Network.IPFS.Prelude +import Network.IPFS.Process.Types + +runProc :: + ( MonadRIO cfg m + , HasProcessContext cfg + , HasLogFunc cfg + ) + => (ProcessConfig stdin stdout () -> m a) + -> FilePath + -> StreamIn stdin + -> StreamOut stdout + -> [Opt] + -> m a +runProc processor binPath inStream outStream opts = + proc binPath opts <| processor + . setStdin inStream + . setStdout outStream diff --git a/library/Network/IPFS/Process/Error.hs b/library/Network/IPFS/Process/Error.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Process/Error.hs @@ -0,0 +1,21 @@ +module Network.IPFS.Process.Error + ( Error (..) + , RawMessage + ) where + +import Network.IPFS.Prelude +import Network.IPFS.Process.Types + +data Error + = Timeout Natural + | UnknownErr RawMessage + deriving ( Exception + , Eq + , Generic + , Show + ) + +instance Display Error where + display = \case + Timeout _ -> "IPFS timed out" + UnknownErr raw -> displayShow raw diff --git a/library/Network/IPFS/Process/Types.hs b/library/Network/IPFS/Process/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Process/Types.hs @@ -0,0 +1,16 @@ +module Network.IPFS.Process.Types + ( Opt + , Command + , StreamIn + , StreamOut + , RawMessage + ) where + +import Network.IPFS.Prelude +import Data.ByteString.Lazy.Char8 as CL + +type Opt = String +type Command = String +type StreamIn stdin = StreamSpec 'STInput stdin +type StreamOut stdout = StreamSpec 'STOutput stdout +type RawMessage = CL.ByteString diff --git a/library/Network/IPFS/Remote/Class.hs b/library/Network/IPFS/Remote/Class.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Remote/Class.hs @@ -0,0 +1,31 @@ +module Network.IPFS.Remote.Class + ( MonadRemoteIPFS + , runRemote + , ipfsAdd + , ipfsCat + , ipfsPin + , ipfsUnpin + ) where + +import Network.IPFS.Prelude + +import Servant.Client +import qualified RIO.ByteString.Lazy as Lazy + +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 + +class Monad m => MonadRemoteIPFS m where + runRemote :: ClientM a -> m (Either ClientError a) + ipfsAdd :: Lazy.ByteString -> m (Either ClientError CID) + ipfsCat :: CID -> m (Either ClientError File.Serialized) + ipfsPin :: CID -> m (Either ClientError Pin.Response) + ipfsUnpin :: CID -> Bool -> m (Either ClientError Pin.Response) + -- defaults + ipfsAdd raw = runRemote <| IPFS.Client.add raw + ipfsCat (CID cid) = runRemote <| IPFS.Client.cat cid + ipfsPin (CID cid) = runRemote <| IPFS.Client.pin cid + ipfsUnpin (CID cid) recursive = runRemote <| IPFS.Client.unpin cid recursive diff --git a/library/Network/IPFS/SparseTree.hs b/library/Network/IPFS/SparseTree.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/SparseTree.hs @@ -0,0 +1,39 @@ +module Network.IPFS.SparseTree + ( SparseTree (..) + , Error.Linearization (..) + , linearize + , cIDs + ) where + +import Network.IPFS.Prelude +import qualified Network.IPFS.Internal.UTF8 as UTF8 +import qualified Network.IPFS.Error as Error + +import Network.IPFS.CID.Types +import Network.IPFS.Name.Types +import Network.IPFS.Path.Types +import Network.IPFS.SparseTree.Types + +linearize :: SparseTree -> Either Error.Linearization Path +linearize = fmap Path . go + where + go :: SparseTree -> Either Error.Linearization Text + go = \case + Stub (Name name) -> Right <| UTF8.textShow name + Content (CID _) -> Right "" + Directory [(tag, value)] -> fromPath tag <$> go value + badDir -> Left <| Error.NonLinear badDir + where + fromPath tag "" = fromKey tag + fromPath tag text = fromKey tag <> "/" <> text + + fromKey :: Tag -> Text + fromKey = UTF8.stripN 1 . \case + Hash (CID cid) -> cid + Key (Name name) -> UTF8.textShow name + +-- | Get all CIDs from a 'SparseTree' (all levels) +cIDs :: (Monoid (f CID), Applicative f) => SparseTree -> f CID +cIDs (Stub _) = mempty +cIDs (Content cid) = pure cid +cIDs (Directory kv) = foldMap cIDs kv diff --git a/library/Network/IPFS/SparseTree/Types.hs b/library/Network/IPFS/SparseTree/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/SparseTree/Types.hs @@ -0,0 +1,91 @@ +module Network.IPFS.SparseTree.Types + ( SparseTree (..) + , Tag (..) + ) where + +import qualified RIO.HashMap as HashMap +import qualified RIO.Map as Map +import qualified RIO.Text as Text + +import Data.Swagger hiding (Tag, name) +import Servant + +import Network.IPFS.Prelude +import qualified Network.IPFS.Internal.UTF8 as UTF8 +import Network.IPFS.CID.Types +import Network.IPFS.Name.Types + +-- | Directory structure for CIDs and other identifiers +-- +-- Examples: +-- +-- > Content "abcdef" +-- +-- > show $ Directory [(Key "abcdef", Stub "myfile.txt")])] +-- "abcdef/myfile.txt" +data SparseTree + = Stub Name + | Content CID + | Directory (Map Tag SparseTree) + deriving ( Eq + , Generic + , Show + ) + +instance ToSchema SparseTree where + declareNamedSchema _ = + mempty + |> type_ ?~ SwaggerString + |> description ?~ "A tree of IPFS paths" + |> example ?~ toJSON (Directory [(Key "abcdef", Stub "myfile.txt")]) + |> NamedSchema (Just "IPFSTree") + |> pure + +instance Display (Map Tag SparseTree) where + display sparseMap = + "{" <> foldr (\e acc -> e <> ", " <> acc) "}" (prettyKV <$> Map.toList sparseMap) + where + prettyKV (k, v) = display k <> " => " <> display v + +instance Display SparseTree where + display = \case + Stub name -> display name + Content cid -> display cid + Directory dir -> display dir + +instance ToJSON SparseTree where + toJSON = \case + Stub (Name name) -> String <| Text.pack name + Content (CID cid) -> String <| UTF8.stripN 1 cid + Directory dirMap -> Object <| HashMap.fromList (jsonKV <$> Map.toList dirMap) + where + jsonKV :: (Tag, SparseTree) -> (Text, Value) + jsonKV (tag, subtree) = (jsonTag tag, toJSON subtree) + + jsonTag (Key (Name n)) = Text.pack n + jsonTag (Hash (CID cid)) = UTF8.stripN 1 cid + +data Tag + = Key Name + | Hash CID + deriving ( Eq + , Generic + , Ord + , Show + ) + +instance Display Tag where + display (Key name) = display name + display (Hash cid) = display cid + +instance FromJSON Tag +instance ToJSON Tag where + toJSON (Key k) = toJSON k + toJSON (Hash h) = toJSON h + +instance FromJSONKey Tag +instance ToJSONKey Tag +instance ToSchema Tag + +instance FromHttpApiData Tag where + parseUrlPiece txt = Key <$> parseUrlPiece txt diff --git a/library/Network/IPFS/Stat.hs b/library/Network/IPFS/Stat.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Stat.hs @@ -0,0 +1,30 @@ +module Network.IPFS.Stat (getSize) where + +import Data.ByteString.Lazy.Char8 as CL +import Data.List as List + +import qualified RIO.ByteString.Lazy as Lazy + +import Network.IPFS.Prelude +import Network.IPFS.Local.Class as IPFS +import qualified Network.IPFS.Internal.UTF8 as UTF8 + +import Network.IPFS.Get.Error as IPFS.Get +import qualified Network.IPFS.Process.Error as Process +import Network.IPFS.Types as IPFS + +getSize :: + MonadLocalIPFS m + => IPFS.CID + -> m (Either IPFS.Get.Error Integer) +getSize cid@(CID hash) = IPFS.runLocal ["object", "stat"] (Lazy.fromStrict <| encodeUtf8 hash) >>= \case + Left err -> case err of + Process.Timeout secs -> return . Left <| TimedOut cid secs + Process.UnknownErr raw -> return . Left . UnknownErr <| UTF8.textShow raw + Right contents -> do + case parseSize contents of + Nothing -> return . Left . UnexpectedOutput <| "Could not parse CumulativeSize" + Just (size, _) -> return <| Right size + +parseSize :: Lazy.ByteString -> Maybe (Integer, Lazy.ByteString) +parseSize = CL.readInteger . List.last . CL.words . List.last . CL.lines diff --git a/library/Network/IPFS/Timeout/Types.hs b/library/Network/IPFS/Timeout/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Timeout/Types.hs @@ -0,0 +1,20 @@ +module Network.IPFS.Timeout.Types (Timeout (..)) where + +import System.Envy + +import Network.IPFS.Prelude +import Network.IPFS.Internal.Orphanage.Natural () + +newtype Timeout = Timeout { getSeconds :: Natural } + deriving ( Eq + , Show + , Generic + ) + deriving newtype ( Num ) + +instance FromEnv Timeout where + fromEnv _ = Timeout <$> env "IPFS_TIMEOUT" + +instance FromJSON Timeout where + parseJSON = withScientific "IPFS.Timeout" \num -> + Timeout <$> parseJSON (Number num) diff --git a/library/Network/IPFS/Types.hs b/library/Network/IPFS/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/Types.hs @@ -0,0 +1,32 @@ +-- | Types related to IPFS +module Network.IPFS.Types + ( BinPath (..) + , CID (..) + , mkCID + , Name (..) + , Opt + , Command + , RawMessage + , Peer (..) + , Path (..) + , SparseTree (..) + , Tag (..) + , Timeout (..) + , URL (..) + , Ignored + , Gateway (..) + , ErrorBody (..) + ) where + +import Network.IPFS.BinPath.Types +import Network.IPFS.CID.Types +import Network.IPFS.Name.Types +import Network.IPFS.Path.Types +import Network.IPFS.Peer.Types +import Network.IPFS.Process.Types +import Network.IPFS.SparseTree.Types +import Network.IPFS.Timeout.Types +import Network.IPFS.URL.Types +import Network.IPFS.Ignored.Types +import Network.IPFS.Gateway.Types +import Network.IPFS.Client.Error.Types diff --git a/library/Network/IPFS/URL/Types.hs b/library/Network/IPFS/URL/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/IPFS/URL/Types.hs @@ -0,0 +1,13 @@ +module Network.IPFS.URL.Types (URL (..)) where + +import qualified Servant.Client as Client + +import Network.IPFS.Prelude + +-- | IPFS client URL +newtype URL = URL { getURL :: Client.BaseUrl } + deriving ( Eq + , Generic + , Show + ) + deriving newtype ( FromJSON ) diff --git a/test/doctest/Main.hs b/test/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/test/doctest/Main.hs @@ -0,0 +1,66 @@ +module Main (main) where + +import RIO +import qualified RIO.List as List + +import Data.Aeson.Lens +import Data.Yaml + +import System.Directory +import System.Directory.Tree +import System.FilePath.Glob (glob) + +import Test.DocTest (doctest) + +main :: IO () +main = do + let tmp = ".doctest-tmp" + setup tmp "library" + + source <- glob tmp + doctest source + + removeDirectoryRecursive tmp + +setup :: FilePath -> FilePath -> IO () +setup tmp src = do + pwd <- getCurrentDirectory + hasTmp <- doesDirectoryExist tmp + if hasTmp + then removeDirectoryRecursive tmp + else return () + + createDirectory tmp + exts <- getExts + + (_ :/ files) <- readDirectoryWithL readFileBinary src + go (pwd <> "/" <> tmp) (header exts) files + where + go :: FilePath -> ByteString -> DirTree ByteString -> IO () + go dirPath exts' = \case + Failed { err } -> + error $ show err + + Dir { name, contents } -> do + let path = dirPath <> "/" <> name + createDirectory path + contents `forM_` go path exts' + + File { name, file } -> + writeFileBinary (dirPath <> "/" <> name) (exts' <> file) + +header :: [ByteString] -> ByteString +header raw = mconcat + [ "{-# LANGUAGE " + , mconcat $ List.intersperse ", " raw + , " #-}\n" + ] + +getExts :: IO [ByteString] +getExts = do + pkg <- decodeFileThrow "package.yaml" :: IO Value + let exts = pkg ^. key "default-extensions" . _Array + return $ extract <$> toList exts + where + extract (String txt) = encodeUtf8 txt + extract _ = error "Malformed package.yaml"