diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 7cd78859..98679fb5 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -16,11 +16,79 @@ extra-doc-files: CHANGELOG.md common warnings ghc-options: -Wall +common shared-properties + ghc-options: + -Wall + -- -fno-warn-unused-matches + -- -fno-warn-unused-do-bind + -- -Werror=missing-methods + -- -Werror=incomplete-patterns + -- -fno-warn-unused-binds + -- -threaded + -- -rtsopts + -- "-with-rtsopts=-N4 -A64m -AL256m -I0" + + + default-language: Haskell2010 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + + + library - import: warnings - exposed-modules: MyLib + import: shared-properties + + exposed-modules: + HBS2.Hash + , HBS2.Prelude + , HBS2.Prelude.Plated + , HBS2.Storage + + -- other-modules: -- other-extensions: build-depends: base ^>=4.15.1.0 + , aeson + , async + , base58-bytestring + , binary + , bytestring + , cborg + , containers + , cryptonite + , deepseq + , hashable + , interpolatedstring-perl6 + , memory + , prettyprinter + , safe + , serialise + , text + , uniplate + hs-source-dirs: lib default-language: Haskell2010 diff --git a/hbs2-core/lib/HBS2/Hash.hs b/hbs2-core/lib/HBS2/Hash.hs new file mode 100644 index 00000000..21fc2246 --- /dev/null +++ b/hbs2-core/lib/HBS2/Hash.hs @@ -0,0 +1,88 @@ +{-# Language RankNTypes #-} +module HBS2.Hash + ( Serialise(..) + , module HBS2.Hash + ) + where + +import Codec.Serialise +import Crypto.Hash hiding (SHA1) +import Data.Aeson(FromJSON(..),ToJSON(..),Value(..)) +import Data.Binary (Binary(..)) +import Data.ByteArray qualified as BA +import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alphabet(..)) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Short qualified as SB +import Data.ByteString.Short (ShortByteString) +import Data.Data +import Data.Hashable (Hashable) +import Data.Kind +import Data.String(IsString(..)) +import Data.Text qualified as Text +import GHC.Generics +import Prettyprinter +import Text.InterpolatedString.Perl6 (qc) +import Control.DeepSeq (NFData,force) + +data HbSync = HbSync + deriving stock (Data) + + +data family Hash ( a :: Type ) + +data HsHash + +type family HashType ( a :: Type) where + HashType HbSync = Blake2b_256 + +newtype instance Hash HbSync = + HbSyncHash ShortByteString + deriving stock (Eq,Ord,Data,Generic) + deriving newtype (Hashable,Show) + +instance NFData (Hash HbSync) +instance Serialise (Hash HbSync) +instance Binary (Hash HbSync) + +newtype Internal a = Internal a + +class Hashed a where + hashObject :: a -> Hash HbSync + +alphabet :: Alphabet +alphabet = bitcoinAlphabet + +getAlphabet :: [Char] +getAlphabet = BS8.unpack (unAlphabet alphabet) + + +instance Hashed ByteString where + hashObject s = HbSyncHash $ force $ SB.toShort $ BA.convert digest + where + digest = hash s :: Digest (HashType HbSync) + +instance Hashed LBS.ByteString where + hashObject s = HbSyncHash $ force $ SB.toShort $ BA.convert digest + where + digest = hashlazy s :: Digest (HashType HbSync) + +instance IsString (Hash HbSync) where + fromString s = maybe (error ("invalid base58: " <> show s)) HbSyncHash doDecode + where + doDecode = SB.toShort <$> decodeBase58 alphabet (BS8.pack s) + +instance Pretty (Hash HbSync) where + pretty (HbSyncHash s) = pretty @String [qc|{encodeBase58 bitcoinAlphabet (SB.fromShort s)}|] + + +instance FromJSON (Hash HbSync) where + parseJSON = \case + String s -> pure (fromString (Text.unpack s)) + _ -> fail "expected string" + +instance ToJSON (Hash HbSync) where + toJSON s = toJSON (show $ pretty s) + + diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs new file mode 100644 index 00000000..a57ce280 --- /dev/null +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -0,0 +1,8 @@ +module HBS2.Prelude + ( module Data.String + ) where + +import Data.String (IsString(..)) + + + diff --git a/hbs2-core/lib/HBS2/Prelude/Plated.hs b/hbs2-core/lib/HBS2/Prelude/Plated.hs new file mode 100644 index 00000000..85ba5af0 --- /dev/null +++ b/hbs2-core/lib/HBS2/Prelude/Plated.hs @@ -0,0 +1,25 @@ +module HBS2.Prelude.Plated + ( module HBS2.Prelude.Plated + , module Data.Data + , module Data.Generics.Uniplate.Operations + , Data + , Generic + ) where + +import Data.Data +import Data.Generics.Uniplate.Data() +import Data.Generics.Uniplate.Operations +import GHC.Generics(Generic) +import Safe + +uniLastMay :: forall to from . (Data from, Data to) => from -> Maybe to +uniLastMay = lastMay . universeBi + +uniLastDef :: forall from to . (Data from, Data to) => to -> from -> to +uniLastDef d = lastDef d . universeBi + +uniFirstMay :: forall to from . (Data from, Data to) => from -> Maybe to +uniFirstMay = headMay . universeBi + +uniFirstDef :: forall from to . (Data from, Data to) => to -> from -> to +uniFirstDef d = headDef d . universeBi diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs new file mode 100644 index 00000000..98f8850b --- /dev/null +++ b/hbs2-core/lib/HBS2/Storage.hs @@ -0,0 +1,18 @@ +{-# Language FunctionalDependencies #-} +module HBS2.Storage where + +import Data.Kind + +type family Block block :: Type +type family Key block :: Type + +class Monad m => Storage a block m | a -> block where + + putBlock :: a -> Block block -> m (Maybe (Key block)) + getBlock :: a -> Key block -> m (Maybe (Block block)) + listBlocks :: a -> ( Key block -> m () ) -> m () + + + + + diff --git a/hbs2-core/lib/MyLib.hs b/hbs2-core/lib/MyLib.hs deleted file mode 100644 index e657c440..00000000 --- a/hbs2-core/lib/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 14fadcc8..d2cfacb7 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -13,14 +13,94 @@ build-type: Simple extra-doc-files: CHANGELOG.md -- extra-source-files: -common warnings - ghc-options: -Wall +common shared-properties + ghc-options: + -Wall + -- -fno-warn-unused-matches + -- -fno-warn-unused-do-bind + -- -Werror=missing-methods + -- -Werror=incomplete-patterns + -- -fno-warn-unused-binds + -- -threaded + -- -rtsopts + -- "-with-rtsopts=-N4 -A64m -AL256m -I0" + + default-language: Haskell2010 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + + library - import: warnings - exposed-modules: MyLib + import: shared-properties + exposed-modules: HBS2.Storage.Simple -- other-modules: -- other-extensions: - build-depends: base ^>=4.15.1.0 + build-depends: base ^>=4.15.1.0, hbs2-core + , bytestring + , containers + , directory + , filepath + , uniplate + , microlens-platform + + hs-source-dirs: lib default-language: Haskell2010 + + +test-suite test + import: shared-properties + default-language: Haskell2010 + + other-modules: + + -- other-extensions: + + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + build-depends: + base ^>=4.15.1.0, hbs2-storage-simple, hbs2-core + , bytestring + , cborg + , containers + , hashable + , microlens-platform + , mtl + , prettyprinter + , random + , safe + , serialise + , tasty + , tasty-hunit + , transformers + , uniplate + , vector + + diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs new file mode 100644 index 00000000..bc9d72a9 --- /dev/null +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -0,0 +1,53 @@ +{-# Language TemplateHaskell #-} +module HBS2.Storage.Simple where + +import Control.Monad.IO.Class +import System.FilePath.Posix +import Lens.Micro.Platform +import Data.ByteString.Lazy qualified as LBS +import System.Directory + +import HBS2.Storage +import HBS2.Prelude +import HBS2.Prelude.Plated + +newtype Raw a = Raw { fromRaw :: a } + + +newtype StoragePrefix = StoragePrefix { fromPrefix :: FilePath } + deriving stock (Data,Show) + deriving newtype (IsString) + +newtype SimpleStorage = + SimpleStorage + { _storageDir :: FilePath + } + +makeLenses ''SimpleStorage + +storageBlocksDir :: SimpleStorage -> FilePath +storageBlocksDir s = view storageDir s "blocks" + +storageBlocks :: SimpleGetter SimpleStorage FilePath +storageBlocks = to f + where + f b = _storageDir b "blocks" + + +simpleStorageInit :: (MonadIO m, Data opts) => opts -> m SimpleStorage +simpleStorageInit opts = liftIO $ do + let prefix = uniLastDef "." opts :: StoragePrefix + + pdir <- canonicalizePath (fromPrefix prefix) + + let stor = SimpleStorage + { _storageDir = pdir + } + + createDirectoryIfMissing True (stor ^. storageBlocks) + + pure stor + +instance MonadIO m => Storage SimpleStorage (Raw LBS.ByteString) m where + + diff --git a/hbs2-storage-simple/lib/MyLib.hs b/hbs2-storage-simple/lib/MyLib.hs deleted file mode 100644 index e657c440..00000000 --- a/hbs2-storage-simple/lib/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/hbs2-storage-simple/test/Main.hs b/hbs2-storage-simple/test/Main.hs new file mode 100644 index 00000000..0f4ff435 --- /dev/null +++ b/hbs2-storage-simple/test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import HBS2.Storage + + + +main = do + error "oops" + +